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

remove original CHR from tree.

Browse Source
This commit is contained in:
Vitor Santos Costa 2008-08-26 00:45:53 +01:00
parent 42bed282b4
commit 9821770ce4
63 changed files with 0 additions and 15696 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

208
CHR/CHR.LICENSE
View File

@ -1,208 +0,0 @@
------------------------------------------------------------------------
LMU COPYRIGHT NOTICE ---------------------------------------------------
------------------------------------------------------------------------
(c) Copyright 1996,1997
Ludwig-Maximilians-Universitaet Muenchen (LMU)
Institut fuer Informatik
Lehr- und Forschungseinheit fuer Programmierung und Softwaretechnik
Oettingenstrasse 67
D-80538 Munich, Germany
Contact:
Dr. Fruehwirth Thom
<<mailto:fruehwir@informatik.uni-muenchen.de
<<http://www.pst.informatik.uni-muenchen.de/personen/fruehwir/
Tel: +(49) 89 2178-2181
Fax: +(49) 89 2178-2175
------------------------------------------------------------------------
RESEARCH SOFTWARE DISCLAIMER -------------------------------------------
------------------------------------------------------------------------
As unestablished, research software, this program is provided
free of charge on an "as is" basis without warranty of any kind,
either
expressed or implied, including but not limited to implied
warranties of merchantability and fitness for a particular purpose.
LMU does not warrant that the functions contained in this program will
meet the user's
requirements or that the operation of this program will be
uninterrupted or error-free. Acceptance and use of this program
constitutes the user's
understanding that he will have no recourse to LMU for any
actual or
consequential damages, including, but not limited to, lost
profits or savings, arising out of the use or inability to use this
program. Even if the user informs LMU of the possibility of such
damages, LMU expects the user of this program to accept the risk of
any harm arising out of the use of this program, or the user shall not
attempt to use this
program for any purpose.
------------------------------------------------------------------------
USER AGREEMENT ---------------------------------------------------------
------------------------------------------------------------------------
BY ACCEPTANCE AND USE OF THIS EXPERIMENTAL PROGRAM
THE USER AGREES TO THE FOLLOWING:
a. This program is provided for the user's personal,
non-commercial,
experimental use and the user is granted permission to copy this
program to the extent reasonably required for such use.
b. All title, ownership and rights to this program and any copies
remain with LMU, irrespective of the ownership of the media on
which the program resides.
c. The user is permitted to create derivative works to this
program.
However, all copies of the program and its derivative works must
contain the LMU COPYRIGHT NOTICE, the UNESTABLISHED SOFTWARE
DISCLAIMER and this USER AGREEMENT.
d. By furnishing this program to the user, LMU does NOT grant
either
directly or by implication, estoppel, or otherwise any license
under any patents, patent applications, trademarks, copyrights
or other
rights belonging to LMU or to any third party, except as
expressly provided herein.
e. The user understands and agrees that this program and any
derivative
works are to be used solely for experimental uses and are not to be
sold, distributed to a commercial organization, or be
commercially
exploited in any manner.
f. LMU requests that the user supply to LMU a copy of any changes,
enhancements, or derivative works which the user may create.
The user
grants LMU and its subsidiaries an irrevocable, nonexclusive,
worldwide and
royalty-free license to use, execute, reproduce,
display, perform, prepare derivative works based upon, and
distribute, internally and externally copies of any and all
such
materials and derivative works thereof, and to sublicense others to
do any, some, or
all of the foregoing, including supporting
documentation.
g. For users willing to sell software containing this program or any
program code resulting from using it, a one time fee and/or a
percentage of the sale price chosen by the user shall be negotiated
and paid to LMU as royalties.
h. This agreement shall be governed by German law.
------------------------------------------------------------------------
LMU COPYRIGHT NOTICE
---------------------------------------------------
------------------------------------------------------------------------
(c) Copyright 1996,1997
Ludwig-Maximilians-Universitaet Muenchen (LMU)
Institut fuer Informatik
Lehr- und Forschungseinheit fuer Programmierung und Softwaretechnik
Oettingenstrasse 67
D-80538 Munich, Germany
Contact:
Dr. Fruehwirth Thom
<mailto:fruehwir@informatik.uni-muenchen.de
<http://www.pst.informatik.uni-muenchen.de/personen/fruehwir/
Tel: +(49) 89 2178-2181
Fax: +(49) 89 2178-2175
------------------------------------------------------------------------
RESEARCH SOFTWARE DISCLAIMER
-------------------------------------------
------------------------------------------------------------------------
As unestablished, research software, this program is provided free
of charge on an
"as is" basis without warranty of any kind, either
expressed or implied, including but not limited to implied
warranties of
merchantability and fitness for a particular purpose. LMU does not
warrant that the
functions contained in this program will meet the user's
requirements or that the operation of this program will be
uninterrupted or
error-free. Acceptance and use of this program constitutes the user's
understanding that he will have no recourse to LMU for any actual or
consequential damages, including, but not limited to, lost profits
or savings,
arising out of the use or inability to use this program. Even if the
user informs LMU of
the possibility of such damages, LMU expects the user of this program to
accept the risk of
any harm arising out of the use of this program, or the user shall not
attempt to use this
program for any purpose.
------------------------------------------------------------------------
USER AGREEMENT
---------------------------------------------------------
------------------------------------------------------------------------
BY ACCEPTANCE AND USE OF THIS EXPERIMENTAL PROGRAM
THE USER AGREES TO THE FOLLOWING:
a. This program is provided for the user's personal,
non-commercial,
experimental use and the user is granted permission to copy this
program to the extent reasonably required for such use.
b. All title, ownership and rights to this program and any copies
remain with LMU, irrespective of the ownership of the media on
which the program resides.
c. The user is permitted to create derivative works to this
program.
However, all copies of the program and its derivative works must
contain the LMU COPYRIGHT NOTICE, the UNESTABLISHED SOFTWARE
DISCLAIMER and this USER AGREEMENT.
d. By furnishing this program to the user, LMU does NOT grant
either
directly or by implication, estoppel, or otherwise any license
under any patents, patent applications, trademarks, copyrights
or other
rights belonging to LMU or to any third party, except as
expressly provided herein.
e. The user understands and agrees that this program and any
derivative
works are to be used solely for experimental uses and are not to be
sold, distributed to a commercial organization, or be
commercially
exploited in any manner.
f. LMU requests that the user supply to LMU a copy of any changes,
enhancements, or derivative works which the user may create.
The user
grants LMU and its subsidiaries an irrevocable, nonexclusive,
worldwide and
royalty-free license to use, execute, reproduce,
display, perform, prepare derivative works based upon, and
distribute, internally and externally copies of any and all
such
materials and derivative works thereof, and to sublicense others to
do any, some, or
all of the foregoing, including supporting
documentation.
g. For users willing to sell software containing this program or any
program code resulting from using it, a one time fee and/or a
percentage of the sale price chosen by the user shall be negotiated
and paid to LMU as royalties.
h. This agreement shall be governed by German law.
========================================================================
=======================================================================

92
CHR/Makefile.in
View File

@ -1,92 +0,0 @@
#
# default base directory for YAP installation
#
ROOTDIR = @prefix@
#
# where the binary should be
#
BINDIR = $(ROOTDIR)/bin
#
# where YAP should look for architecture-independent Prolog libraries
#
SHAREDIR=$(ROOTDIR)/share/Yap
#
#
# You shouldn't need to change what follows.
#
INSTALL=@INSTALL@
INSTALL_DATA=@INSTALL_DATA@
INSTALL_PROGRAM=@INSTALL_PROGRAM@
srcdir=@srcdir@
CHR_PROGRAMS= $(srcdir)/chr/chrcmp.pl \
$(srcdir)/chr/compenv.pl \
$(srcdir)/chr/concat.pl \
$(srcdir)/chr/getval.pl \
$(srcdir)/chr/matching.pl \
$(srcdir)/chr/operator.pl \
$(srcdir)/chr/ordering.pl \
$(srcdir)/chr/sbag.pl \
$(srcdir)/chr/sbag_a.pl \
$(srcdir)/chr/sbag_l.pl \
$(srcdir)/chr/trace.yap
CHR_TOP= $(srcdir)/chr.yap
CHR_LICENSE= $(srcdir)/CHR.LICENSE
CHR_EXAMPLES= $(srcdir)/chr/examples/allentable.pl \
$(srcdir)/chr/examples/arc.pl \
$(srcdir)/chr/examples/bool.pl \
$(srcdir)/chr/examples/cft.pl \
$(srcdir)/chr/examples/domain.pl \
$(srcdir)/chr/examples/examples-adder.bool \
$(srcdir)/chr/examples/examples-benchmark.math \
$(srcdir)/chr/examples/examples-deussen.bool \
$(srcdir)/chr/examples/examples-diaz.bool \
$(srcdir)/chr/examples/examples-fourier.math \
$(srcdir)/chr/examples/examples-holzbaur.math \
$(srcdir)/chr/examples/examples-lim1.math \
$(srcdir)/chr/examples/examples-lim2.math \
$(srcdir)/chr/examples/examples-lim3.math \
$(srcdir)/chr/examples/examples-puzzle.bool \
$(srcdir)/chr/examples/examples-queens.bool \
$(srcdir)/chr/examples/examples-queens.domain \
$(srcdir)/chr/examples/examples-stuckey.math \
$(srcdir)/chr/examples/examples-thom.math \
$(srcdir)/chr/examples/gcd.pl \
$(srcdir)/chr/examples/interval.pl \
$(srcdir)/chr/examples/kl-one.pl \
$(srcdir)/chr/examples/leq.pl \
$(srcdir)/chr/examples/list.pl \
$(srcdir)/chr/examples/listdom.pl \
$(srcdir)/chr/examples/math-elim.pl \
$(srcdir)/chr/examples/math-fougau.pl \
$(srcdir)/chr/examples/math-fourier.pl \
$(srcdir)/chr/examples/math-gauss.pl \
$(srcdir)/chr/examples/math-utilities.pl \
$(srcdir)/chr/examples/minmax.pl \
$(srcdir)/chr/examples/modelgenerator.pl \
$(srcdir)/chr/examples/osf.pl \
$(srcdir)/chr/examples/oztype.pl \
$(srcdir)/chr/examples/path.pl \
$(srcdir)/chr/examples/pathc.pl \
$(srcdir)/chr/examples/primes.pl \
$(srcdir)/chr/examples/scheduling.pl \
$(srcdir)/chr/examples/tarski.pl \
$(srcdir)/chr/examples/term.pl \
$(srcdir)/chr/examples/time-pc.pl \
$(srcdir)/chr/examples/time-point.pl \
$(srcdir)/chr/examples/time-rnd.pl \
$(srcdir)/chr/examples/time.pl \
$(srcdir)/chr/examples/tree.pl \
$(srcdir)/chr/examples/type.pl
install: $(CHR_TOP) $(CHR_LICENSE) $(CHR_PROGRAMS) $(CHR_EXAMPLES)
mkdir -p $(DESTDIR)$(SHAREDIR)/chr/examples
for h in $(CHR_TOP); do $(INSTALL_DATA) $$h $(DESTDIR)$(SHAREDIR); done
for h in $(CHR_LICENSE); do $(INSTALL_DATA) $$h $(DESTDIR)$(SHAREDIR); done
for h in $(CHR_PROGRAMS); do $(INSTALL_DATA) $$h $(DESTDIR)$(SHAREDIR)/chr; done
for h in $(CHR_EXAMPLES); do $(INSTALL_DATA) $$h $(DESTDIR)$(SHAREDIR)/chr/examples; done

893
CHR/chr.pl
View File

@ -1,893 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Constraint Handling Rules version 2.2 %
% %
% (c) Copyright 1996-98 %
% LMU, Muenchen %
% %
% File: chr.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% The CHR runtime system,
% the constraint store.
%
% Two functions: a) storage b) reactivation triggered by bindings
%
% Reactivation is symmetric: if two variables with suspensions
% are unified, both suspensions run. (Both variables got more
% constrained)
%
% *** Sequence of wakeups determines termination of handler leq ***
%
% Another sequence that could matter is the one
% generated by the iterators
%
% Layout:
%
% suspension(Id,State,Closure,Generation,PropagationHistory,F|Args)
%
% Id is 1st to allow for direct comparisons (sort) and avoids
% unifiability if the Id is nonvar.
% F is the constraint functor
%
%
:- module( chr,
[
find_constraint/2,
find_constraint/3,
findall_constraints/2,
findall_constraints/3,
remove_constraint/1,
current_handler/2,
current_constraint/2,
unconstrained/1,
notify_constrained/1,
chr_trace/0, chr_notrace/0,
chr_debug/0, chr_nodebug/0, chr_debugging/0,
chr_leash/1, chr_spy/1, chr_nospy/1
]).
:- use_module( library('chr/getval')).
:- use_module( library(lists),
[
append/3,
member/2,
is_list/1,
nth/3,
select/3
]).
:- use_module( library(terms),
[
term_variables/2,
subsumes_chk/2,
subsumes/2
]).
:- use_module( library(assoc), % propagation history
[
empty_assoc/1,
put_assoc/4,
get_assoc/3,
assoc_to_list/2
]).
:- use_module(library('chr/sbag')). % link to sbag_l.pl or sbag_a.pl
:- use_module(library('chr/chrcmp')).
:- use_module(library('chr/trace')).
:- use_module(library(atts)).
:- attribute locked/0, exposed/1, dbg_state/1.
%
% Problem with cyclic structures:
% error reporters seem to use write ...
%
:- multifile
user:portray/1,
user:portray_message/2,
user:goal_expansion/3.
:- dynamic
user:portray/1,
user:portray_message/2,
user:goal_expansion/3.
%
user:portray( Susp) :-
Susp =.. [suspension,Id,Mref,_,_,_,_|_],
nonvar( Mref),
!,
write('<c'), write(Id), write('>'). % (c)onstraint
%
user:portray( '$want_duplicates'(_,Term)) :- !, % cf. attribute_goal/2
prolog_flag( toplevel_print_options, Options),
write_term( Term, Options).
:- initialization
setval( id, 0). % counter for portray/debugger
%
user:portray_message( error, chr(multiple_handlers(Old,New,Module))) :- !,
format( user_error, '{CHR ERROR: registering ~p, module ~p already hosts ~p}~n',
[New,Module,Old]).
% -----------------------------------------------------------------
%
% *** MACROS ***
%
%
user:goal_expansion( lock_some(L), chr, Exp) :- is_list(L),
unravel( L, lock, Exp).
user:goal_expansion( unlock_some(L), chr, Exp) :- is_list(L),
unravel( L, unlock, Exp).
user:goal_expansion( via([],V), chr, global_term_ref_1(V)).
user:goal_expansion( via([X],V), chr, via_1(X,V)).
user:goal_expansion( via([X,Y],V), chr, via_2(X,Y,V)).
user:goal_expansion( via([X,Y,Z],V), chr, via_3(X,Y,Z,V)).
user:goal_expansion( load_args(S,State,Args), chr, Exp) :-
is_list( Args),
Susp =.. [suspension,_,Mref,_,_,_,_|Args],
Exp = ( S=Susp, get_mutable( State, Mref) ).
%
%
%
user:goal_expansion( nd_init_iteration(V,_,_,Att,S), _, Exp) :-
arg( 1, Att, Stack),
Exp = ( get_atts(V,Att), chr:sbag_member(S,Stack) ).
%
user:goal_expansion( init_iteration(V,_,_,Att,L), _, Exp) :-
arg( 1, Att, Stack),
Exp = ( get_atts(V,Att), chr:iter_init(Stack,L) ).
unravel( [], _, true).
unravel( [X|Xs], F, (G,Gs)) :-
G =.. [F,X],
unravel( Xs, F, Gs).
% ----------------------- runtime user predicates -----------------
remove_constraint( Susp) :-
nonvar( Susp),
functor( Susp, suspension, N),
N >= 6,
!,
debug_event( remove(Susp)),
remove_constraint_internal( Susp, Vars),
arg( 3, Susp, Module:_),
arg( 6, Susp, F),
A is N-6,
Module:detach( F/A, Susp, Vars).
remove_constraint( S) :-
raise_exception( type_error(remove_constraint(S),1,'a constraint object',S)).
find_constraint( Term, Susp) :-
global_term_ref_1( Global),
find_constraint( Global, Term, Susp).
find_constraint( V, Term, Susp) :- var( V), !,
find_constraint_internal( V, Term, Susp, active, _).
find_constraint( A, B, C) :-
raise_exception( instantiation_error( find_constraint(A,B,C), 1)).
find_constraint_internal( V, Term, Susp, State, Module) :-
constraint( Handler, F/A, Att),
functor( Term, F, A), % prune some
arg( 1, Att, Stack),
current_handler( Handler, Module),
Module:get_atts( V, Att),
length( Args, A),
Try =.. [F|Args],
sbag_member( Susp, Stack),
Susp =.. [suspension,_,Mref,_,_,_,_|Args],
get_mutable( State, Mref),
subsumes( Term, Try).
%
% Test for unconstrained var
% Used by some math solvers
%
unconstrained( X) :-
% var(X), prolog:'$get_cva'(X,[],_).
find_constraint( X, _, _), !, fail.
unconstrained( _).
findall_constraints( C, L) :-
global_term_ref_1( Global),
findall_constraints( Global, C, L).
findall_constraints( V, C, L) :- var( V), !,
findall( M:Att, (
constraint( H, F/A, Att),
functor( C, F, A),
current_handler( H, M)
),
Agenda),
findall_constraints( Agenda, C, V, L, []).
findall_constraints( V, C, L) :-
raise_exception( instantiation_error( findall_constraints(V,C,L), 1)).
findall_constraints( [], _, _) --> [].
findall_constraints( [Module:Att|Agenda], C, V) -->
( {
arg( 1, Att, Stack),
Module:get_atts( V, Att),
iter_init( Stack, State)
} ->
findall_constraints_( State, C, Module)
;
[]
),
findall_constraints( Agenda, C, V).
findall_constraints_( State, _, _) --> {iter_last(State)}.
findall_constraints_( State, General, Module) -->
{
iter_next( State, S, Next)
},
( {
S =.. [suspension,_,Mref,_,_,_,F|Args],
get_mutable( active, Mref),
Term =.. [F|Args],
subsumes_chk( General, Term)
} ->
[ Term#S ]
;
[]
),
findall_constraints_( Next, General, Module).
%
% Decorate a constraint Term from Module
% with a module prefix if needed.
%
module_wrap( Term, Module, Wrapped) :-
prolog_flag( typein_module, Typein),
( Module == Typein ->
Wrapped = Term
; predicate_property( Typein:Term, imported_from(_)) ->
Wrapped = Term
;
Wrapped = Module:Term
).
% -----------------------------------------------------------------
/*
Two namespaces handler/module actually only justified if there
can be more than one handler per module ...
*/
:- dynamic handler/2.
:- dynamic constraint/3.
current_handler( Handler, Module) :-
handler( Handler, Module).
current_constraint( Handler, C) :-
constraint( Handler, C, _).
register_handler( Handler, Cs, Slots) :-
prolog_load_context( module, Module),
( handler(Other,Module),
Other \== Handler ->
raise_exception( chr(multiple_handlers(Other,Handler,Module)))
; handler( Handler, Module) ->
true % simple reload
;
assert( handler(Handler,Module))
),
retractall( constraint(Handler,_,_)),
reg_handler( Cs, Slots, Handler).
reg_handler( [], [], _).
reg_handler( [C|Cs], [S|Ss], Handler) :-
assert( constraint(Handler,C,S)),
reg_handler( Cs, Ss, Handler).
% ----------------------------------------------------------------
notify_constrained( X) :- var( X),
findall( M, handler(_,M), Modules),
notify_constrained( Modules, X).
notify_constrained( X) :- nonvar( X),
raise_exception( instantitation_error( notify_constrained(X),1)).
notify_constrained( [], _).
notify_constrained( [M|Ms], X) :-
M:get_suspensions( X, S),
run_suspensions( S),
notify_constrained( Ms, X).
%
% support for verify_attributes/3, notify_constrained/1
%
% Approximation because debug state might change between calls ...
%
run_suspensions( Slots) :-
getval( debug, State),
( State == off ->
run_suspensions_loop( Slots)
;
run_suspensions_loop_d( Slots)
),
true.
run_suspensions_loop( []).
run_suspensions_loop( [A|As]) :-
arg( 1, A, Stack),
iter_init( Stack, State),
run_suspensions_( State),
run_suspensions_loop( As).
run_suspensions_loop_d( []).
run_suspensions_loop_d( [A|As]) :-
arg( 1, A, Stack),
iter_init( Stack, State),
run_suspensions_d( State),
run_suspensions_loop_d( As).
%
% Transition active->triggered->removed instead of
% active->removed is to avoid early gc of suspensions.
% The suspension's generation is incremented to signal
% to the revive scheme that the constraint has been
% processed already.
%
run_suspensions_( State) :- iter_last( State).
run_suspensions_( State) :-
iter_next( State, S, Next),
arg( 2, S, Mref),
get_mutable( Status, Mref),
( Status==active ->
update_mutable( triggered, Mref),
arg( 4, S, Gref),
get_mutable( Gen, Gref),
Generation is Gen+1,
update_mutable( Generation, Gref),
arg( 3, S, Goal),
call( Goal),
get_mutable( Post, Mref),
( Post==triggered ->
update_mutable( removed, Mref)
;
true
)
;
true
),
run_suspensions_( Next).
run_suspensions_d( State) :- iter_last( State).
run_suspensions_d( State) :-
iter_next( State, S, Next),
arg( 2, S, Mref),
get_mutable( Status, Mref),
( Status==active ->
update_mutable( triggered, Mref),
arg( 4, S, Gref),
get_mutable( Gen, Gref),
Generation is Gen+1,
update_mutable( Generation, Gref),
arg( 3, S, Goal),
byrd( S, Goal),
get_mutable( Post, Mref),
( Post==triggered ->
update_mutable( removed, Mref)
;
true
)
;
true
),
run_suspensions_d( Next).
byrd( Self, Goal) :-
( debug_event( wake(Self)), call( Goal)
; debug_event( fail(Self)), !, fail
),
( debug_event( exit(Self))
; debug_event( redo(Self)), fail
).
%
% Merge 2 sorted lists of Name/1 terms.
% The argument of each term is a sbag.
%
merge_attributes( [], Bs, Bs).
merge_attributes( [A|As], Bs, Cs) :-
merge_attributes( Bs, Cs, A, As).
merge_attributes( [], [A|As], A, As).
merge_attributes( [B|Bs], Cs, A, As) :-
functor( A, NameA, 1),
functor( B, NameB, 1),
compare( R, NameA, NameB),
( R == < -> Cs = [A|Css], merge_attributes( As, Css, B, Bs)
; R == > -> Cs = [B|Css], merge_attributes( Bs, Css, A, As)
;
Cs = [C|Css],
functor( C, NameA, 1),
arg( 1, A, StackA),
arg( 1, B, StackB),
arg( 1, C, StackC),
sbag_union( StackA, StackB, StackC),
merge_attributes( As, Bs, Css)
).
show_bag( Bag) :-
iter_init( Bag, State),
show_bag_( State),
nl.
show_bag_( State) :- iter_last( State).
show_bag_( State) :-
iter_next( State, S, Next),
arg( 2, S, Ref),
get_mutable( St, Ref),
format( ' ~p:~p', [S,St]),
show_bag_( Next).
%
% Support for attribute_goal/2.
%
% Complication: the Sicstus kernel removes duplicates
% via call_residue/2 - that includes the toplevel.
% We may want to see them ->
% tag Term with Suspension, 'untag' via portray/1
%
% Called with a list of slots once per module
%
attribute_goals( L, Goal, Module) :-
attribute_goal_loop( L, Module, GL, []),
l2c( GL, Goal).
attribute_goal_loop( [], _) --> [].
attribute_goal_loop( [A|As], Mod) -->
{
arg( 1, A, Stack),
iter_init( Stack, State)
},
attgs_( State, Mod),
attribute_goal_loop( As, Mod).
attgs_( State, _) --> {iter_last( State)}.
attgs_( State, Module) -->
{
iter_next( State, S, Next),
S =.. [suspension,_,Mref,_,_,_,F|Args]
},
( {get_mutable(active,Mref)} ->
{
Term =.. [F|Args],
module_wrap( Term, Module, Wrapped)
},
[ '$want_duplicates'(S,Wrapped) ]
;
[]
),
attgs_( Next, Module).
%
% fail for empty list
%
l2c( [C], C) :- !.
l2c( [C|Cs], (C,Cj)) :-
l2c( Cs, Cj).
%
% Unlink removed constraints cleanly from all chains
% Still need gc state because of wake,
% but re-insertion = insert because of complete removal.
%
chr_gc :-
global_term_ref_1( Global),
findall( M, handler(_,M), Modules),
chr_gcm( Modules, Global).
chr_gcm( [], _).
chr_gcm( [M|Ms], Global) :-
M:get_suspensions( Global, AllS),
term_variables( [Global|AllS], Vars), % AllS may be ground
chr_gcv( Vars, M),
chr_gcm( Ms, Global).
%
% Have compiler generated support?
%
chr_gcv( [], _).
chr_gcv( [V|Vs], M) :-
M:get_suspensions( V, Old),
chr_gcb( Old, New),
M:put_suspensions( V, New),
chr_gcv( Vs, M).
chr_gcb( [], []).
chr_gcb( [S|Ss], [Sgc|Ts]) :-
arg( 1, S, Bag),
iter_init( Bag, State),
functor( S, N, 1),
functor( T, N, 1),
gc_bag( State, Lgc),
( Lgc==[] ->
Sgc = -T
;
Sgc = T,
list_to_sbag( Lgc, BagGc),
arg( 1, T, BagGc)
),
chr_gcb( Ss, Ts).
gc_bag( State, []) :- iter_last( State).
gc_bag( State, L) :-
iter_next( State, Susp, Next),
arg( 2, Susp, Mref),
get_mutable( SuspState, Mref),
( SuspState==removed ->
L = Tail,
update_mutable( gc, Mref)
; SuspState==gc ->
L = Tail
;
L = [Susp|Tail]
),
gc_bag( Next, Tail).
% --------------------------------------------------------------------
%
% Incremental allocation & activation of constraints.
% Attachment code of closures to variables is generated
% by the compiler.
%
% States {passive(Term),inactive,triggered,active,removed,gc}
%
%
:- meta_predicate allocate_constraint(:,-,+,+).
%
allocate_constraint( Closure, Self, F, Args) :-
empty_history( History),
create_mutable( passive(Args), Mref),
create_mutable( 0, Gref),
create_mutable( History, Href),
gen_id( Id),
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
%
% activate_constraint( -, +, -).
%
% The transition gc->active should be rare
%
activate_constraint( Vars, Susp, Generation) :-
arg( 2, Susp, Mref),
get_mutable( State, Mref),
update_mutable( active, Mref),
( nonvar(Generation) -> % aih
true
;
arg( 4, Susp, Gref),
get_mutable( Gen, Gref),
Generation is Gen+1,
update_mutable( Generation, Gref)
),
( compound(State) -> % passive/1
term_variables( State, Vs),
none_locked( Vs),
global_term_ref_1( Global),
Vars = [Global|Vs]
; State==gc -> % removed from all chains
Susp =.. [_,_,_,_,_,_,_|Args],
term_variables( Args, Vs),
global_term_ref_1( Global),
Vars = [Global|Vs]
; State==removed -> % the price for eager removal ...
Susp =.. [_,_,_,_,_,_,_|Args],
term_variables( Args, Vs),
global_term_ref_1( Global),
Vars = [Global|Vs]
;
Vars = []
).
%
% Combination of the prev. two
%
:- meta_predicate insert_constraint_internal(-,-,:,+,+).
%
insert_constraint_internal( [Global|Vars], Self, Closure, F, Args) :-
term_variables( Args, Vars),
none_locked( Vars),
global_term_ref_1( Global),
empty_history( History),
create_mutable( active, Mref),
create_mutable( 0, Gref),
create_mutable( History, Href),
gen_id( Id),
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
:- meta_predicate insert_constraint_internal(-,-,?,:,+,+).
%
insert_constraint_internal( [Global|Vars], Self, Term, Closure, F, Args) :-
term_variables( Term, Vars),
none_locked( Vars),
global_term_ref_1( Global),
empty_history( History),
create_mutable( active, Mref),
create_mutable( 0, Gref),
create_mutable( History, Href),
gen_id( Id),
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
gen_id( Id) :-
incval( id, Id).
/* no undo/1 in sicstus3.7
( Id =:= 1 -> % first time called
undo( setval(id,0))
;
true
).
*/
%
% Eager removal from all chains.
%
remove_constraint_internal( Susp, Agenda) :-
arg( 2, Susp, Mref),
get_mutable( State, Mref),
update_mutable( removed, Mref), % mark in any case
( compound(State) -> % passive/1
Agenda = []
; State==removed ->
Agenda = []
; State==triggered ->
Agenda = []
;
Susp =.. [_,_,_,_,_,_,_|Args],
term_variables( Args, Vars),
global_term_ref_1( Global),
Agenda = [Global|Vars]
).
%
% Protect the goal against any binding
% or attachment of constraints. The latter is
% via the notify_constrained/1 convention.
%
lock( T) :- var(T), put_atts( T, locked).
lock( T) :- nonvar( T),
functor( T, _, N),
lock_arg( N, T).
lock_arg( 0, _) :- !.
lock_arg( 1, T) :- !, arg( 1, T, A), lock( A).
lock_arg( 2, T) :- !, arg( 1, T, A), lock( A), arg( 2, T, B), lock( B).
lock_arg( N, T) :-
arg( N, T, A),
lock( A),
M is N-1,
lock_arg( M, T).
unlock( T) :- var(T), put_atts( T, -locked).
unlock( T) :- nonvar( T),
functor( T, _, N),
unlock_arg( N, T).
unlock_arg( 0, _) :- !.
unlock_arg( 1, T) :- !, arg( 1, T, A), unlock( A).
unlock_arg( 2, T) :- !, arg( 1, T, A), unlock( A), arg( 2, T, B), unlock( B).
unlock_arg( N, T) :-
arg( N, T, A),
unlock( A),
M is N-1,
unlock_arg( M, T).
verify_attributes( X, Y, []) :-
get_atts( X, locked),
!,
var(Y),
get_atts( Y, -locked),
put_atts( Y, locked).
verify_attributes( _, _, []).
none_locked( []).
none_locked( [V|Vs]) :-
not_locked( V),
none_locked( Vs).
not_locked( V) :- var( V), get_atts( V, -locked).
not_locked( V) :- nonvar( V).
% -------------------------- access to constraints ------------------
%
% Try a list of candidates. V may be nonvar but
% bound to a term with variables in it.
%
via( L, V) :-
member( X, L),
var( X),
!,
V = X.
via( L, V) :-
compound( L),
nonground( L, V),
!.
via( _, V) :-
global_term_ref_1( V).
%
% specialization(s)
%
via_1( X, V) :- var(X), !, X=V.
via_1( T, V) :- compound(T), nonground( T, V), !.
via_1( _, V) :- global_term_ref_1( V).
via_2( X, _, V) :- var(X), !, X=V.
via_2( _, Y, V) :- var(Y), !, Y=V.
via_2( T, _, V) :- compound(T), nonground( T, V), !.
via_2( _, T, V) :- compound(T), nonground( T, V), !.
via_2( _, _, V) :- global_term_ref_1( V).
via_3( X, _, _, V) :- var(X), !, X=V.
via_3( _, Y, _, V) :- var(Y), !, Y=V.
via_3( _, _, Z, V) :- var(Z), !, Z=V.
via_3( T, _, _, V) :- compound(T), nonground( T, V), !.
via_3( _, T, _, V) :- compound(T), nonground( T, V), !.
via_3( _, _, T, V) :- compound(T), nonground( T, V), !.
via_3( _, _, _, V) :- global_term_ref_1( 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.
%
nonground( Term, V) :-
term_variables( Term, Vs),
Vs = [V|_].
/*
nonground( Term, V) :- var( Term), V=Term.
nonground( Term, V) :- compound( Term),
functor( Term, _, N),
nonground( N, Term, V).
%
% assert: N > 0
%
nonground( 1, Term, V) :- !,
arg( 1, Term, Arg),
nonground( Arg, V).
nonground( 2, Term, V) :- !,
arg( 2, Term, Arg2),
( nonground( Arg2, V) ->
true
;
arg( 1, Term, Arg1),
nonground( Arg1, V)
).
nonground( N, Term, V) :-
arg( N, Term, Arg),
( nonground( Arg, V) ->
true
;
M is N-1,
nonground( M, Term, V)
).
*/
constraint_generation( Susp, State, Generation) :-
arg( 2, Susp, Mref),
get_mutable( State, Mref),
arg( 4, Susp, Gref),
get_mutable( Generation, Gref). % not incremented meanwhile
change_state( Susp, State) :-
arg( 2, Susp, Mref),
update_mutable( State, Mref).
:- meta_predicate expose(-,+,+,+,:).
%
expose_active( Ref, Head, Tid, Heads, Continuation) :-
get_exposed( Ref),
get_mutable( Exposed, Ref),
update_mutable( [active(Head,Tid,Heads,Continuation)|Exposed], Ref).
expose_passive( Ref, Heads) :-
get_exposed( Ref),
get_mutable( Exposed, Ref),
update_mutable( [passive(Heads)|Exposed], Ref).
de_expose( Ref) :-
get_mutable( [_|Exposed], Ref),
update_mutable( Exposed, Ref).
%
% Prefer passive over active (cheaper to deal with).
%
is_exposed( Constraint, Suspension, Continuation) :-
get_exposed( Ref),
get_mutable( Exposed, Ref),
is_exposed( Exposed, Constraint, Suspension, Continuation).
is_exposed( [E|Es], Constraint, Suspension, Continuation) :-
is_exposed( E, Constraint, Suspension, Continuation, Es).
is_exposed( active(Head,Susp,Heads,Cont), Constraint, Suspension, Continuation, Es) :-
( member( C#Suspension, Heads),
Constraint == C ->
Continuation = true
; Constraint == Head ->
( is_exposed( Es, Constraint, Suspension, true) -> % prefer
Continuation = true
;
Continuation = Cont,
Suspension = Susp
)
;
is_exposed( Es, Constraint, Suspension, Continuation)
).
is_exposed( passive(Heads), Constraint, Suspension, Continuation, Es) :-
( member( C#Suspension, Heads),
Constraint == C ->
Continuation = true
;
is_exposed( Es, Constraint, Suspension, Continuation)
).
get_exposed( Ref) :-
global_term_ref_1( Global),
( get_atts( Global, exposed(Ref)) ->
true
;
create_mutable( [], Ref),
put_atts( Global, exposed(Ref))
).
get_dbg_state( Ref) :-
global_term_ref_1( Global),
( get_atts( Global, dbg_state(Ref)) ->
true
;
create_mutable( [], Ref),
put_atts( Global, dbg_state(Ref))
).
% ------------------- abstract data type for propagation rules -------------
empty_history( E) :- empty_assoc( E).
%
% assert: constraints/tuples are comparable directly
%
novel_production( Self, Tuple) :-
arg( 5, Self, Ref),
get_mutable( History, Ref),
( get_assoc( Tuple, History, _) ->
fail
;
true
).
%
% Not folded with novel_production/2 because guard checking
% goes in between the two calls.
%
extend_history( Self, Tuple) :-
arg( 5, Self, Ref),
get_mutable( History, Ref),
put_assoc( Tuple, History, x, NewHistory),
update_mutable( NewHistory, Ref).
:- load_foreign_resource(library(system(chr))).
end_of_file.

908
CHR/chr.yap
View File

@ -1,908 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Constraint Handling Rules version 2.2 %
% %
% (c) Copyright 1996-98 %
% LMU, Muenchen %
% %
% File: chr.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% The CHR runtime system,
% the constraint store.
%
% Two functions: a) storage b) reactivation triggered by bindings
%
% Reactivation is symmetric: if two variables with suspensions
% are unified, both suspensions run. (Both variables got more
% constrained)
%
% *** Sequence of wakeups determines termination of handler leq ***
%
% Another sequence that could matter is the one
% generated by the iterators
%
% Layout:
%
% suspension(Id,State,Closure,Generation,PropagationHistory,F|Args)
%
% Id is 1st to allow for direct comparisons (sort) and avoids
% unifiability if the Id is nonvar.
% F is the constraint functor
%
%
:- module( chr,
[
find_constraint/2,
find_constraint/3,
findall_constraints/2,
findall_constraints/3,
remove_constraint/1,
current_handler/2,
current_constraint/2,
unconstrained/1,
notify_constrained/1,
chr_trace/0, chr_notrace/0,
chr_debug/0, chr_nodebug/0, chr_debugging/0,
chr_leash/1, chr_spy/1, chr_nospy/1
]).
:- use_module( library('chr/getval')).
:- use_module( library(lists),
[
append/3,
member/2,
is_list/1,
nth/3,
select/3
]).
:- use_module( library(terms),
[
term_variables/2,
subsumes_chk/2,
subsumes/2
]).
:- use_module( library(assoc), % propagation history
[
empty_assoc/1,
put_assoc/4,
get_assoc/3,
assoc_to_list/2
]).
:- use_module('chr/sbag'). % link to sbag_l.pl or sbag_a.pl
:- use_module('chr/chrcmp').
:- use_module('chr/trace').
:- use_module(library(atts)).
:- attribute locked/0, exposed/1, dbg_state/1.
%
% Problem with cyclic structures:
% error reporters seem to use write ...
%
:- multifile
user:portray/1,
user:portray_message/2,
user:goal_expansion/3.
:- dynamic
user:portray/1,
user:portray_message/2,
user:goal_expansion/3.
%
user:portray( Susp) :-
Susp =.. [suspension,Id,Mref,_,_,_,_|_],
nonvar( Mref),
!,
write('<c'), write(Id), write('>'). % (c)onstraint
%
user:portray( '$want_duplicates'(_,Term)) :- !, % cf. attribute_goal/2
prolog_flag( toplevel_print_options, Options),
write_term( Term, Options).
:- initialization
setval( id, 0). % counter for portray/debugger
%
user:portray_message( error, chr(multiple_handlers(Old,New,Module))) :- !,
format( user_error, '{CHR ERROR: registering ~p, module ~p already hosts ~p}~n',
[New,Module,Old]).
% -----------------------------------------------------------------
%
% *** MACROS ***
%
%
user:goal_expansion( lock_some(L), chr, Exp) :- is_list(L),
unravel( L, lock, Exp).
user:goal_expansion( unlock_some(L), chr, Exp) :- is_list(L),
unravel( L, unlock, Exp).
user:goal_expansion( via([],V), chr, global_term_ref_1(V)).
user:goal_expansion( via([X],V), chr, via_1(X,V)).
user:goal_expansion( via([X,Y],V), chr, via_2(X,Y,V)).
user:goal_expansion( via([X,Y,Z],V), chr, via_3(X,Y,Z,V)).
user:goal_expansion( load_args(S,State,Args), chr, Exp) :-
is_list( Args),
Susp =.. [suspension,_,Mref,_,_,_,_|Args],
Exp = ( S=Susp, get_mutable( State, Mref) ).
%
%
%
user:goal_expansion( nd_init_iteration(V,_,_,Att,S), _, Exp) :-
arg( 1, Att, Stack),
Exp = ( get_atts(V,Att), chr:sbag_member(S,Stack) ).
%
user:goal_expansion( init_iteration(V,_,_,Att,L), _, Exp) :-
arg( 1, Att, Stack),
Exp = ( get_atts(V,Att), chr:iter_init(Stack,L) ).
unravel( [], _, true).
unravel( [X|Xs], F, (G,Gs)) :-
G =.. [F,X],
unravel( Xs, F, Gs).
% ----------------------- runtime user predicates -----------------
remove_constraint( Susp) :-
nonvar( Susp),
functor( Susp, suspension, N),
N >= 6,
!,
debug_event( remove(Susp)),
remove_constraint_internal( Susp, Vars),
arg( 3, Susp, Module:_),
arg( 6, Susp, F),
A is N-6,
Module:detach( F/A, Susp, Vars).
remove_constraint( S) :-
raise_exception( type_error(remove_constraint(S),1,'a constraint object',S)).
find_constraint( Term, Susp) :-
global_term_ref_1( Global),
find_constraint( Global, Term, Susp).
find_constraint( V, Term, Susp) :- var( V), !,
find_constraint_internal( V, Term, Susp, active, _).
find_constraint( A, B, C) :-
raise_exception( instantiation_error( find_constraint(A,B,C), 1)).
find_constraint_internal( V, Term, Susp, State, Module) :-
constraint( Handler, F/A, Att),
functor( Term, F, A), % prune some
arg( 1, Att, Stack),
current_handler( Handler, Module),
Module:get_atts( V, Att),
length( Args, A),
Try =.. [F|Args],
sbag_member( Susp, Stack),
Susp =.. [suspension,_,Mref,_,_,_,_|Args],
get_mutable( State, Mref),
subsumes( Term, Try).
%
% Test for unconstrained var
% Used by some math solvers
%
unconstrained( X) :-
% var(X), prolog:'$get_cva'(X,[],_).
find_constraint( X, _, _), !, fail.
unconstrained( _).
findall_constraints( C, L) :-
global_term_ref_1( Global),
findall_constraints( Global, C, L).
findall_constraints( V, C, L) :- var( V), !,
findall( M:Att, (
constraint( H, F/A, Att),
functor( C, F, A),
current_handler( H, M)
),
Agenda),
findall_constraints( Agenda, C, V, L, []).
findall_constraints( V, C, L) :-
raise_exception( instantiation_error( findall_constraints(V,C,L), 1)).
findall_constraints( [], _, _) --> [].
findall_constraints( [Module:Att|Agenda], C, V) -->
( {
arg( 1, Att, Stack),
Module:get_atts( V, Att),
iter_init( Stack, State)
} ->
findall_constraints_( State, C, Module)
;
[]
),
findall_constraints( Agenda, C, V).
findall_constraints_( State, _, _) --> {iter_last(State)}.
findall_constraints_( State, General, Module) -->
{
iter_next( State, S, Next)
},
( {
S =.. [suspension,_,Mref,_,_,_,F|Args],
get_mutable( active, Mref),
Term =.. [F|Args],
subsumes_chk( General, Term)
} ->
[ Term#S ]
;
[]
),
findall_constraints_( Next, General, Module).
%
% Decorate a constraint Term from Module
% with a module prefix if needed.
%
module_wrap( Term, Module, Wrapped) :-
prolog_flag( typein_module, Typein),
( Module == Typein ->
Wrapped = Term
; predicate_property( Typein:Term, imported_from(_)) ->
Wrapped = Term
;
Wrapped = Module:Term
).
% -----------------------------------------------------------------
/*
Two namespaces handler/module actually only justified if there
can be more than one handler per module ...
*/
:- dynamic handler/2.
:- dynamic constraint/3.
current_handler( Handler, Module) :-
handler( Handler, Module).
current_constraint( Handler, C) :-
constraint( Handler, C, _).
register_handler( Handler, Cs, Slots) :-
prolog_load_context( module, Module),
( handler(Other,Module),
Other \== Handler ->
raise_exception( chr(multiple_handlers(Other,Handler,Module)))
; handler( Handler, Module) ->
true % simple reload
;
assert( handler(Handler,Module))
),
retractall( constraint(Handler,_,_)),
reg_handler( Cs, Slots, Handler).
reg_handler( [], [], _).
reg_handler( [C|Cs], [S|Ss], Handler) :-
assert( constraint(Handler,C,S)),
reg_handler( Cs, Ss, Handler).
% ----------------------------------------------------------------
notify_constrained( X) :- var( X),
findall( M, handler(_,M), Modules),
notify_constrained( Modules, X).
notify_constrained( X) :- nonvar( X),
raise_exception( instantitation_error( notify_constrained(X),1)).
notify_constrained( [], _).
notify_constrained( [M|Ms], X) :-
M:get_suspensions( X, S),
run_suspensions( S),
notify_constrained( Ms, X).
%
% support for verify_attributes/3, notify_constrained/1
%
% Approximation because debug state might change between calls ...
%
run_suspensions( Slots) :-
getval( debug, State),
( State == off ->
run_suspensions_loop( Slots)
;
run_suspensions_loop_d( Slots)
),
true.
run_suspensions_loop( []).
run_suspensions_loop( [A|As]) :-
arg( 1, A, Stack),
iter_init( Stack, State),
run_suspensions_( State),
run_suspensions_loop( As).
run_suspensions_loop_d( []).
run_suspensions_loop_d( [A|As]) :-
arg( 1, A, Stack),
iter_init( Stack, State),
run_suspensions_d( State),
run_suspensions_loop_d( As).
%
% Transition active->triggered->removed instead of
% active->removed is to avoid early gc of suspensions.
% The suspension's generation is incremented to signal
% to the revive scheme that the constraint has been
% processed already.
%
run_suspensions_( State) :- iter_last( State).
run_suspensions_( State) :-
iter_next( State, S, Next),
arg( 2, S, Mref),
get_mutable( Status, Mref),
( Status==active ->
update_mutable( triggered, Mref),
arg( 4, S, Gref),
get_mutable( Gen, Gref),
Generation is Gen+1,
update_mutable( Generation, Gref),
arg( 3, S, Goal),
call( Goal),
get_mutable( Post, Mref),
( Post==triggered ->
update_mutable( removed, Mref)
;
true
)
;
true
),
run_suspensions_( Next).
run_suspensions_d( State) :- iter_last( State).
run_suspensions_d( State) :-
iter_next( State, S, Next),
arg( 2, S, Mref),
get_mutable( Status, Mref),
( Status==active ->
update_mutable( triggered, Mref),
arg( 4, S, Gref),
get_mutable( Gen, Gref),
Generation is Gen+1,
update_mutable( Generation, Gref),
arg( 3, S, Goal),
byrd( S, Goal),
get_mutable( Post, Mref),
( Post==triggered ->
update_mutable( removed, Mref)
;
true
)
;
true
),
run_suspensions_d( Next).
byrd( Self, Goal) :-
( debug_event( wake(Self)), call( Goal)
; debug_event( fail(Self)), !, fail
),
( debug_event( exit(Self))
; debug_event( redo(Self)), fail
).
%
% Merge 2 sorted lists of Name/1 terms.
% The argument of each term is a sbag.
%
merge_attributes( [], Bs, Bs).
merge_attributes( [A|As], Bs, Cs) :-
merge_attributes( Bs, Cs, A, As).
merge_attributes( [], [A|As], A, As).
merge_attributes( [B|Bs], Cs, A, As) :-
functor( A, NameA, 1),
functor( B, NameB, 1),
compare( R, NameA, NameB),
( R == < -> Cs = [A|Css], merge_attributes( As, Css, B, Bs)
; R == > -> Cs = [B|Css], merge_attributes( Bs, Css, A, As)
;
Cs = [C|Css],
functor( C, NameA, 1),
arg( 1, A, StackA),
arg( 1, B, StackB),
arg( 1, C, StackC),
sbag_union( StackA, StackB, StackC),
merge_attributes( As, Bs, Css)
).
show_bag( Bag) :-
iter_init( Bag, State),
show_bag_( State),
nl.
show_bag_( State) :- iter_last( State).
show_bag_( State) :-
iter_next( State, S, Next),
arg( 2, S, Ref),
get_mutable( St, Ref),
format( ' ~p:~p', [S,St]),
show_bag_( Next).
%
% Support for attribute_goal/2.
%
% Complication: the Sicstus kernel removes duplicates
% via call_residue/2 - that includes the toplevel.
% We may want to see them ->
% tag Term with Suspension, 'untag' via portray/1
%
% Called with a list of slots once per module
%
attribute_goals( L, Goal, Module) :-
attribute_goal_loop( L, Module, GL, []),
l2c( GL, Goal).
attribute_goal_loop( [], _) --> [].
attribute_goal_loop( [A|As], Mod) -->
{
arg( 1, A, Stack),
iter_init( Stack, State)
},
attgs_( State, Mod),
attribute_goal_loop( As, Mod).
attgs_( State, _) --> {iter_last( State)}.
attgs_( State, Module) -->
{
iter_next( State, S, Next),
S =.. [suspension,_,Mref,_,_,_,F|Args]
},
( {get_mutable(active,Mref)} ->
{
Term =.. [F|Args],
module_wrap( Term, Module, Wrapped)
},
[ '$want_duplicates'(S,Wrapped) ]
;
[]
),
attgs_( Next, Module).
%
% fail for empty list
%
l2c( [C], C) :- !.
l2c( [C|Cs], (C,Cj)) :-
l2c( Cs, Cj).
%
% Unlink removed constraints cleanly from all chains
% Still need gc state because of wake,
% but re-insertion = insert because of complete removal.
%
chr_gc :-
global_term_ref_1( Global),
findall( M, handler(_,M), Modules),
chr_gcm( Modules, Global).
chr_gcm( [], _).
chr_gcm( [M|Ms], Global) :-
M:get_suspensions( Global, AllS),
term_variables( [Global|AllS], Vars), % AllS may be ground
chr_gcv( Vars, M),
chr_gcm( Ms, Global).
%
% Have compiler generated support?
%
chr_gcv( [], _).
chr_gcv( [V|Vs], M) :-
M:get_suspensions( V, Old),
chr_gcb( Old, New),
M:put_suspensions( V, New),
chr_gcv( Vs, M).
chr_gcb( [], []).
chr_gcb( [S|Ss], [Sgc|Ts]) :-
arg( 1, S, Bag),
iter_init( Bag, State),
functor( S, N, 1),
functor( T, N, 1),
gc_bag( State, Lgc),
( Lgc==[] ->
Sgc = -T
;
Sgc = T,
list_to_sbag( Lgc, BagGc),
arg( 1, T, BagGc)
),
chr_gcb( Ss, Ts).
gc_bag( State, []) :- iter_last( State).
gc_bag( State, L) :-
iter_next( State, Susp, Next),
arg( 2, Susp, Mref),
get_mutable( SuspState, Mref),
( SuspState==removed ->
L = Tail,
update_mutable( gc, Mref)
; SuspState==gc ->
L = Tail
;
L = [Susp|Tail]
),
gc_bag( Next, Tail).
% --------------------------------------------------------------------
%
% Incremental allocation & activation of constraints.
% Attachment code of closures to variables is generated
% by the compiler.
%
% States {passive(Term),inactive,triggered,active,removed,gc}
%
%
:- meta_predicate allocate_constraint(:,-,+,+).
%
allocate_constraint( Closure, Self, F, Args) :-
empty_history( History),
create_mutable( passive(Args), Mref),
create_mutable( 0, Gref),
create_mutable( History, Href),
gen_id( Id),
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
%
% activate_constraint( -, +, -).
%
% The transition gc->active should be rare
%
activate_constraint( Vars, Susp, Generation) :-
arg( 2, Susp, Mref),
get_mutable( State, Mref),
update_mutable( active, Mref),
( nonvar(Generation) -> % aih
true
;
arg( 4, Susp, Gref),
get_mutable( Gen, Gref),
Generation is Gen+1,
update_mutable( Generation, Gref)
),
( compound(State) -> % passive/1
term_variables( State, Vs),
none_locked( Vs),
global_term_ref_1( Global),
Vars = [Global|Vs]
; State==gc -> % removed from all chains
Susp =.. [_,_,_,_,_,_,_|Args],
term_variables( Args, Vs),
global_term_ref_1( Global),
Vars = [Global|Vs]
; State==removed -> % the price for eager removal ...
Susp =.. [_,_,_,_,_,_,_|Args],
term_variables( Args, Vs),
global_term_ref_1( Global),
Vars = [Global|Vs]
;
Vars = []
).
%
% Combination of the prev. two
%
:- meta_predicate insert_constraint_internal(-,-,:,+,+).
%
insert_constraint_internal( [Global|Vars], Self, Closure, F, Args) :-
term_variables( Args, Vars),
none_locked( Vars),
global_term_ref_1( Global),
empty_history( History),
create_mutable( active, Mref),
create_mutable( 0, Gref),
create_mutable( History, Href),
gen_id( Id),
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
:- meta_predicate insert_constraint_internal(-,-,?,:,+,+).
%
insert_constraint_internal( [Global|Vars], Self, Term, Closure, F, Args) :-
term_variables( Term, Vars),
none_locked( Vars),
global_term_ref_1( Global),
empty_history( History),
create_mutable( active, Mref),
create_mutable( 0, Gref),
create_mutable( History, Href),
gen_id( Id),
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
gen_id( Id) :-
incval( id, Id).
/* no undo/1 in sicstus3.7
( Id =:= 1 -> % first time called
undo( setval(id,0))
;
true
).
*/
%
% Eager removal from all chains.
%
remove_constraint_internal( Susp, Agenda) :-
arg( 2, Susp, Mref),
get_mutable( State, Mref),
update_mutable( removed, Mref), % mark in any case
( compound(State) -> % passive/1
Agenda = []
; State==removed ->
Agenda = []
; State==triggered ->
Agenda = []
;
Susp =.. [_,_,_,_,_,_,_|Args],
term_variables( Args, Vars),
global_term_ref_1( Global),
Agenda = [Global|Vars]
).
%
% Protect the goal against any binding
% or attachment of constraints. The latter is
% via the notify_constrained/1 convention.
%
lock( T) :- var(T), put_atts( T, locked).
lock( T) :- nonvar( T),
functor( T, _, N),
lock_arg( N, T).
lock_arg( 0, _) :- !.
lock_arg( 1, T) :- !, arg( 1, T, A), lock( A).
lock_arg( 2, T) :- !, arg( 1, T, A), lock( A), arg( 2, T, B), lock( B).
lock_arg( N, T) :-
arg( N, T, A),
lock( A),
M is N-1,
lock_arg( M, T).
unlock( T) :- var(T), put_atts( T, -locked).
unlock( T) :- nonvar( T),
functor( T, _, N),
unlock_arg( N, T).
unlock_arg( 0, _) :- !.
unlock_arg( 1, T) :- !, arg( 1, T, A), unlock( A).
unlock_arg( 2, T) :- !, arg( 1, T, A), unlock( A), arg( 2, T, B), unlock( B).
unlock_arg( N, T) :-
arg( N, T, A),
unlock( A),
M is N-1,
unlock_arg( M, T).
verify_attributes( X, Y, []) :-
get_atts( X, locked),
!,
var(Y),
get_atts( Y, -locked),
put_atts( Y, locked).
verify_attributes( _, _, []).
none_locked( []).
none_locked( [V|Vs]) :-
not_locked( V),
none_locked( Vs).
not_locked( V) :- var( V), get_atts( V, -locked).
not_locked( V) :- nonvar( V).
% -------------------------- access to constraints ------------------
%
% Try a list of candidates. V may be nonvar but
% bound to a term with variables in it.
%
via( L, V) :-
member( X, L),
var( X),
!,
V = X.
via( L, V) :-
compound( L),
nonground( L, V),
!.
via( _, V) :-
global_term_ref_1( V).
%
% specialization(s)
%
via_1( X, V) :- var(X), !, X=V.
via_1( T, V) :- compound(T), nonground( T, V), !.
via_1( _, V) :- global_term_ref_1( V).
via_2( X, _, V) :- var(X), !, X=V.
via_2( _, Y, V) :- var(Y), !, Y=V.
via_2( T, _, V) :- compound(T), nonground( T, V), !.
via_2( _, T, V) :- compound(T), nonground( T, V), !.
via_2( _, _, V) :- global_term_ref_1( V).
via_3( X, _, _, V) :- var(X), !, X=V.
via_3( _, Y, _, V) :- var(Y), !, Y=V.
via_3( _, _, Z, V) :- var(Z), !, Z=V.
via_3( T, _, _, V) :- compound(T), nonground( T, V), !.
via_3( _, T, _, V) :- compound(T), nonground( T, V), !.
via_3( _, _, T, V) :- compound(T), nonground( T, V), !.
via_3( _, _, _, V) :- global_term_ref_1( 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.
%
nonground( Term, V) :-
term_variables( Term, Vs),
Vs = [V|_].
/*
nonground( Term, V) :- var( Term), V=Term.
nonground( Term, V) :- compound( Term),
functor( Term, _, N),
nonground( N, Term, V).
%
% assert: N > 0
%
nonground( 1, Term, V) :- !,
arg( 1, Term, Arg),
nonground( Arg, V).
nonground( 2, Term, V) :- !,
arg( 2, Term, Arg2),
( nonground( Arg2, V) ->
true
;
arg( 1, Term, Arg1),
nonground( Arg1, V)
).
nonground( N, Term, V) :-
arg( N, Term, Arg),
( nonground( Arg, V) ->
true
;
M is N-1,
nonground( M, Term, V)
).
*/
constraint_generation( Susp, State, Generation) :-
arg( 2, Susp, Mref),
get_mutable( State, Mref),
arg( 4, Susp, Gref),
get_mutable( Generation, Gref). % not incremented meanwhile
change_state( Susp, State) :-
arg( 2, Susp, Mref),
update_mutable( State, Mref).
:- meta_predicate expose(-,+,+,+,:).
%
expose_active( Ref, Head, Tid, Heads, Continuation) :-
get_exposed( Ref),
get_mutable( Exposed, Ref),
update_mutable( [active(Head,Tid,Heads,Continuation)|Exposed], Ref).
expose_passive( Ref, Heads) :-
get_exposed( Ref),
get_mutable( Exposed, Ref),
update_mutable( [passive(Heads)|Exposed], Ref).
de_expose( Ref) :-
get_mutable( [_|Exposed], Ref),
update_mutable( Exposed, Ref).
%
% Prefer passive over active (cheaper to deal with).
%
is_exposed( Constraint, Suspension, Continuation) :-
get_exposed( Ref),
get_mutable( Exposed, Ref),
is_exposed( Exposed, Constraint, Suspension, Continuation).
is_exposed( [E|Es], Constraint, Suspension, Continuation) :-
is_exposed( E, Constraint, Suspension, Continuation, Es).
is_exposed( active(Head,Susp,Heads,Cont), Constraint, Suspension, Continuation, Es) :-
( member( C#Suspension, Heads),
Constraint == C ->
Continuation = true
; Constraint == Head ->
( is_exposed( Es, Constraint, Suspension, true) -> % prefer
Continuation = true
;
Continuation = Cont,
Suspension = Susp
)
;
is_exposed( Es, Constraint, Suspension, Continuation)
).
is_exposed( passive(Heads), Constraint, Suspension, Continuation, Es) :-
( member( C#Suspension, Heads),
Constraint == C ->
Continuation = true
;
is_exposed( Es, Constraint, Suspension, Continuation)
).
get_exposed( Ref) :-
global_term_ref_1( Global),
( get_atts( Global, exposed(Ref)) ->
true
;
create_mutable( [], Ref),
put_atts( Global, exposed(Ref))
).
get_dbg_state( Ref) :-
global_term_ref_1( Global),
( get_atts( Global, dbg_state(Ref)) ->
true
;
create_mutable( [], Ref),
put_atts( Global, dbg_state(Ref))
).
% ------------------- abstract data type for propagation rules -------------
empty_history( E) :- empty_assoc( E).
%
% assert: constraints/tuples are comparable directly
%
novel_production( Self, Tuple) :-
arg( 5, Self, Ref),
get_mutable( History, Ref),
( get_assoc( Tuple, History, _) ->
fail
;
true
).
%
% Not folded with novel_production/2 because guard checking
% goes in between the two calls.
%
extend_history( Self, Tuple) :-
arg( 5, Self, Ref),
get_mutable( History, Ref),
put_assoc( Tuple, History, x, NewHistory),
update_mutable( NewHistory, Ref).
% vsc
%
global_term_ref(I,X) :- array_element(global_term_ref, I, X).
global_term_ref_0(X) :- array_element(global_term_ref, 0, X).
global_term_ref_1(X) :- array_element(global_term_ref, 1, X).
:- yap_flag(toplevel_hook,chr:create_global_array).
create_global_array :- ( array(global_term_ref,2) -> true ; true).
%
% vsc
%
%:- load_foreign_resource(library(system(chr))).
end_of_file.

1495
CHR/chr/chrcmp.pl
View File

File diff suppressed because it is too large Load Diff

29
CHR/chr/compenv.pl
View File

@ -1,29 +0,0 @@
%
% Provides compile time environment for fcompiling CHR
%
env_fcompile( File) :-
( file_mod( File, Module) ->
fcompile( Module:File)
; File = library(File0), file_mod( File0, Module ) ->
fcompile( Module:File)
; fcompile( File)
).
file_mod( chr, chr) :-
use_module( library(atts)),
use_module( getval),
use_module( sbag).
file_mod( trace, chr) :-
use_module( getval).
file_mod( operator, chrcmp).
file_mod( chrcmp, chrcmp) :-
[library(operator)],
use_module( matching),
use_module( getval).
file_mod( ordering, ordering) :-
use_module( library(atts)).

26
CHR/chr/concat.pl
View File

@ -1,26 +0,0 @@
:- module( concat, [concat_name/2]).
concat_name( List, Name) :- List=[_|_],
conc_parts( List, Chs, []),
atom_codes( Name, Chs).
concat_name( F/A, Name) :-
conc_part( F/A, Chs, []),
atom_codes( Name, Chs).
conc_parts( []) --> [].
conc_parts( [P]) --> !, conc_part( P).
conc_parts( [P|Ps]) -->
conc_part( P),
"_",
conc_parts( Ps).
conc_part( F/A) --> !, name( F), "/", name( A).
conc_part( X ) --> name( X).
name( A) --> {name(A,Chars)}, copy( Chars).
copy( []) --> [].
copy( [C|Cs]) --> [ C ], copy( Cs).

411
CHR/chr/examples/allentable.pl
View File

@ -1,411 +0,0 @@
cons_tri(1, 1, 1).
cons_tri(1, 2, 1).
cons_tri(1, 2, 2).
cons_tri(1, 2, 3).
cons_tri(1, 2, 4).
cons_tri(1, 2, 5).
cons_tri(1, 2, 6).
cons_tri(1, 2, 7).
cons_tri(1, 2, 8).
cons_tri(1, 2, 9).
cons_tri(1, 2, 10).
cons_tri(1, 2, 11).
cons_tri(1, 2, 12).
cons_tri(1, 2, 13).
cons_tri(1, 3, 1).
cons_tri(1, 3, 3).
cons_tri(1, 3, 5).
cons_tri(1, 3, 7).
cons_tri(1, 3, 9).
cons_tri(1, 4, 1).
cons_tri(1, 5, 1).
cons_tri(1, 6, 1).
cons_tri(1, 6, 3).
cons_tri(1, 6, 5).
cons_tri(1, 6, 7).
cons_tri(1, 6, 9).
cons_tri(1, 7, 1).
cons_tri(1, 8, 1).
cons_tri(1, 8, 3).
cons_tri(1, 8, 5).
cons_tri(1, 8, 7).
cons_tri(1, 8, 9).
cons_tri(1, 9, 1).
cons_tri(1, 10, 1).
cons_tri(1, 11, 1).
cons_tri(1, 11, 3).
cons_tri(1, 11, 5).
cons_tri(1, 11, 7).
cons_tri(1, 11, 9).
cons_tri(1, 12, 1).
cons_tri(2, 1, 1).
cons_tri(2, 1, 2).
cons_tri(2, 1, 3).
cons_tri(2, 1, 4).
cons_tri(2, 1, 5).
cons_tri(2, 1, 6).
cons_tri(2, 1, 7).
cons_tri(2, 1, 8).
cons_tri(2, 1, 9).
cons_tri(2, 1, 10).
cons_tri(2, 1, 11).
cons_tri(2, 1, 12).
cons_tri(2, 1, 13).
cons_tri(2, 2, 2).
cons_tri(2, 3, 2).
cons_tri(2, 3, 3).
cons_tri(2, 3, 6).
cons_tri(2, 3, 8).
cons_tri(2, 3, 11).
cons_tri(2, 4, 2).
cons_tri(2, 5, 2).
cons_tri(2, 5, 3).
cons_tri(2, 5, 6).
cons_tri(2, 5, 8).
cons_tri(2, 5, 11).
cons_tri(2, 6, 2).
cons_tri(2, 7, 2).
cons_tri(2, 7, 3).
cons_tri(2, 7, 6).
cons_tri(2, 7, 8).
cons_tri(2, 7, 11).
cons_tri(2, 8, 2).
cons_tri(2, 9, 2).
cons_tri(2, 9, 3).
cons_tri(2, 9, 6).
cons_tri(2, 9, 8).
cons_tri(2, 9, 11).
cons_tri(2, 10, 2).
cons_tri(2, 11, 2).
cons_tri(2, 12, 2).
cons_tri(3, 1, 1).
cons_tri(3, 2, 2).
cons_tri(3, 3, 3).
cons_tri(3, 4, 1).
cons_tri(3, 4, 2).
cons_tri(3, 4, 3).
cons_tri(3, 4, 4).
cons_tri(3, 4, 5).
cons_tri(3, 4, 6).
cons_tri(3, 4, 7).
cons_tri(3, 4, 8).
cons_tri(3, 4, 9).
cons_tri(3, 4, 10).
cons_tri(3, 4, 11).
cons_tri(3, 4, 12).
cons_tri(3, 4, 13).
cons_tri(3, 5, 1).
cons_tri(3, 5, 3).
cons_tri(3, 5, 5).
cons_tri(3, 5, 7).
cons_tri(3, 5, 9).
cons_tri(3, 6, 2).
cons_tri(3, 6, 3).
cons_tri(3, 6, 6).
cons_tri(3, 6, 8).
cons_tri(3, 6, 11).
cons_tri(3, 7, 1).
cons_tri(3, 8, 2).
cons_tri(3, 9, 3).
cons_tri(3, 10, 2).
cons_tri(3, 10, 3).
cons_tri(3, 10, 6).
cons_tri(3, 10, 8).
cons_tri(3, 10, 11).
cons_tri(3, 11, 3).
cons_tri(3, 12, 1).
cons_tri(3, 12, 3).
cons_tri(3, 12, 5).
cons_tri(3, 12, 7).
cons_tri(3, 12, 9).
cons_tri(4, 1, 1).
cons_tri(4, 1, 4).
cons_tri(4, 1, 5).
cons_tri(4, 1, 7).
cons_tri(4, 1, 12).
cons_tri(4, 2, 2).
cons_tri(4, 2, 4).
cons_tri(4, 2, 6).
cons_tri(4, 2, 8).
cons_tri(4, 2, 10).
cons_tri(4, 3, 3).
cons_tri(4, 3, 4).
cons_tri(4, 3, 5).
cons_tri(4, 3, 6).
cons_tri(4, 3, 9).
cons_tri(4, 3, 10).
cons_tri(4, 3, 11).
cons_tri(4, 3, 12).
cons_tri(4, 3, 13).
cons_tri(4, 4, 4).
cons_tri(4, 5, 4).
cons_tri(4, 5, 5).
cons_tri(4, 5, 12).
cons_tri(4, 6, 4).
cons_tri(4, 6, 6).
cons_tri(4, 6, 10).
cons_tri(4, 7, 4).
cons_tri(4, 7, 5).
cons_tri(4, 7, 12).
cons_tri(4, 8, 4).
cons_tri(4, 8, 6).
cons_tri(4, 8, 10).
cons_tri(4, 9, 4).
cons_tri(4, 9, 5).
cons_tri(4, 9, 12).
cons_tri(4, 10, 4).
cons_tri(4, 11, 4).
cons_tri(4, 11, 6).
cons_tri(4, 11, 10).
cons_tri(4, 12, 4).
cons_tri(5, 1, 1).
cons_tri(5, 2, 2).
cons_tri(5, 2, 4).
cons_tri(5, 2, 6).
cons_tri(5, 2, 8).
cons_tri(5, 2, 10).
cons_tri(5, 3, 3).
cons_tri(5, 3, 5).
cons_tri(5, 3, 9).
cons_tri(5, 4, 1).
cons_tri(5, 4, 4).
cons_tri(5, 4, 5).
cons_tri(5, 4, 7).
cons_tri(5, 4, 12).
cons_tri(5, 5, 1).
cons_tri(5, 5, 5).
cons_tri(5, 5, 7).
cons_tri(5, 6, 3).
cons_tri(5, 6, 4).
cons_tri(5, 6, 5).
cons_tri(5, 6, 6).
cons_tri(5, 6, 9).
cons_tri(5, 6, 10).
cons_tri(5, 6, 11).
cons_tri(5, 6, 12).
cons_tri(5, 6, 13).
cons_tri(5, 7, 1).
cons_tri(5, 8, 4).
cons_tri(5, 8, 6).
cons_tri(5, 8, 10).
cons_tri(5, 9, 5).
cons_tri(5, 10, 4).
cons_tri(5, 10, 5).
cons_tri(5, 10, 12).
cons_tri(5, 11, 3).
cons_tri(5, 11, 5).
cons_tri(5, 11, 9).
cons_tri(5, 12, 1).
cons_tri(5, 12, 5).
cons_tri(5, 12, 7).
cons_tri(6, 1, 1).
cons_tri(6, 1, 4).
cons_tri(6, 1, 5).
cons_tri(6, 1, 7).
cons_tri(6, 1, 12).
cons_tri(6, 2, 2).
cons_tri(6, 3, 3).
cons_tri(6, 3, 6).
cons_tri(6, 3, 11).
cons_tri(6, 4, 2).
cons_tri(6, 4, 4).
cons_tri(6, 4, 6).
cons_tri(6, 4, 8).
cons_tri(6, 4, 10).
cons_tri(6, 5, 3).
cons_tri(6, 5, 4).
cons_tri(6, 5, 5).
cons_tri(6, 5, 6).
cons_tri(6, 5, 9).
cons_tri(6, 5, 10).
cons_tri(6, 5, 11).
cons_tri(6, 5, 12).
cons_tri(6, 5, 13).
cons_tri(6, 6, 2).
cons_tri(6, 6, 6).
cons_tri(6, 6, 8).
cons_tri(6, 7, 4).
cons_tri(6, 7, 5).
cons_tri(6, 7, 12).
cons_tri(6, 8, 2).
cons_tri(6, 9, 3).
cons_tri(6, 9, 6).
cons_tri(6, 9, 11).
cons_tri(6, 10, 2).
cons_tri(6, 10, 6).
cons_tri(6, 10, 8).
cons_tri(6, 11, 6).
cons_tri(6, 12, 4).
cons_tri(6, 12, 6).
cons_tri(6, 12, 10).
cons_tri(7, 1, 1).
cons_tri(7, 2, 2).
cons_tri(7, 2, 4).
cons_tri(7, 2, 6).
cons_tri(7, 2, 8).
cons_tri(7, 2, 10).
cons_tri(7, 3, 3).
cons_tri(7, 3, 5).
cons_tri(7, 3, 9).
cons_tri(7, 4, 1).
cons_tri(7, 5, 1).
cons_tri(7, 6, 3).
cons_tri(7, 6, 5).
cons_tri(7, 6, 9).
cons_tri(7, 7, 1).
cons_tri(7, 8, 11).
cons_tri(7, 8, 12).
cons_tri(7, 8, 13).
cons_tri(7, 9, 7).
cons_tri(7, 10, 7).
cons_tri(7, 11, 3).
cons_tri(7, 11, 5).
cons_tri(7, 11, 9).
cons_tri(7, 12, 1).
cons_tri(8, 1, 1).
cons_tri(8, 1, 4).
cons_tri(8, 1, 5).
cons_tri(8, 1, 7).
cons_tri(8, 1, 12).
cons_tri(8, 2, 2).
cons_tri(8, 3, 3).
cons_tri(8, 3, 6).
cons_tri(8, 3, 11).
cons_tri(8, 4, 2).
cons_tri(8, 5, 3).
cons_tri(8, 5, 6).
cons_tri(8, 5, 11).
cons_tri(8, 6, 1).
cons_tri(8, 6, 3).
cons_tri(8, 7, 9).
cons_tri(8, 7, 10).
cons_tri(8, 7, 13).
cons_tri(8, 8, 2).
cons_tri(8, 9, 3).
cons_tri(8, 9, 6).
cons_tri(8, 9, 11).
cons_tri(8, 10, 2).
cons_tri(8, 11, 8).
cons_tri(8, 12, 8).
cons_tri(9, 1, 1).
cons_tri(9, 2, 2).
cons_tri(9, 3, 3).
cons_tri(9, 4, 1).
cons_tri(9, 4, 4).
cons_tri(9, 4, 5).
cons_tri(9, 4, 7).
cons_tri(9, 4, 12).
cons_tri(9, 5, 1).
cons_tri(9, 5, 5).
cons_tri(9, 5, 7).
cons_tri(9, 6, 3).
cons_tri(9, 6, 6).
cons_tri(9, 6, 11).
cons_tri(9, 7, 1).
cons_tri(9, 8, 8).
cons_tri(9, 9, 9).
cons_tri(9, 10, 9).
cons_tri(9, 10, 10).
cons_tri(9, 10, 13).
cons_tri(9, 11, 3).
cons_tri(9, 12, 1).
cons_tri(9, 12, 5).
cons_tri(9, 12, 7).
cons_tri(10, 1, 1).
cons_tri(10, 1, 4).
cons_tri(10, 1, 5).
cons_tri(10, 1, 7).
cons_tri(10, 1, 12).
cons_tri(10, 2, 2).
cons_tri(10, 3, 3).
cons_tri(10, 3, 6).
cons_tri(10, 3, 11).
cons_tri(10, 4, 4).
cons_tri(10, 5, 4).
cons_tri(10, 5, 5).
cons_tri(10, 5, 12).
cons_tri(10, 6, 6).
cons_tri(10, 7, 4).
cons_tri(10, 7, 5).
cons_tri(10, 7, 12).
cons_tri(10, 8, 8).
cons_tri(10, 9, 9).
cons_tri(10, 9, 10).
cons_tri(10, 9, 13).
cons_tri(10, 10, 10).
cons_tri(10, 11, 6).
cons_tri(10, 12, 4).
cons_tri(11, 1, 1).
cons_tri(11, 2, 2).
cons_tri(11, 3, 3).
cons_tri(11, 4, 2).
cons_tri(11, 4, 4).
cons_tri(11, 4, 6).
cons_tri(11, 4, 8).
cons_tri(11, 4, 10).
cons_tri(11, 5, 3).
cons_tri(11, 5, 5).
cons_tri(11, 5, 9).
cons_tri(11, 6, 2).
cons_tri(11, 6, 6).
cons_tri(11, 6, 8).
cons_tri(11, 7, 7).
cons_tri(11, 8, 2).
cons_tri(11, 9, 3).
cons_tri(11, 10, 2).
cons_tri(11, 10, 6).
cons_tri(11, 10, 8).
cons_tri(11, 11, 11).
cons_tri(11, 12, 11).
cons_tri(11, 12, 12).
cons_tri(11, 12, 13).
cons_tri(12, 1, 1).
cons_tri(12, 2, 2).
cons_tri(12, 2, 4).
cons_tri(12, 2, 6).
cons_tri(12, 2, 8).
cons_tri(12, 2, 10).
cons_tri(12, 3, 3).
cons_tri(12, 3, 5).
cons_tri(12, 3, 9).
cons_tri(12, 4, 4).
cons_tri(12, 5, 5).
cons_tri(12, 6, 4).
cons_tri(12, 6, 6).
cons_tri(12, 6, 10).
cons_tri(12, 7, 7).
cons_tri(12, 8, 4).
cons_tri(12, 8, 6).
cons_tri(12, 8, 10).
cons_tri(12, 9, 5).
cons_tri(12, 10, 4).
cons_tri(12, 11, 11).
cons_tri(12, 11, 12).
cons_tri(12, 11, 13).
cons_tri(12, 12, 12).
cons_tri(13, 1, 1).
cons_tri(13, 2, 2).
cons_tri(13, 3, 3).
cons_tri(13, 4, 4).
cons_tri(13, 5, 5).
cons_tri(13, 6, 6).
cons_tri(13, 7, 7).
cons_tri(13, 8, 8).
cons_tri(13, 9, 9).
cons_tri(13, 10, 10).
cons_tri(13, 11, 11).
cons_tri(13, 12, 12).
cons_tri(13, 13, 13).
cons_tri(1, 13, 1).
cons_tri(2, 13, 2).
cons_tri(3, 13, 3).
cons_tri(4, 13, 4).
cons_tri(5, 13, 5).
cons_tri(6, 13, 6).
cons_tri(7, 13, 7).
cons_tri(8, 13, 8).
cons_tri(9, 13, 9).
cons_tri(10, 13, 10).
cons_tri(11, 13, 11).
cons_tri(12, 13, 12).
cons_tri(13, 13, 13).

86
CHR/chr/examples/arc.pl
View File

@ -1,86 +0,0 @@
% arc-consistency
% thom fruehwirth, ECRC 941128, LMU 980312
:- use_module( library(chr)).
:- use_module( library(lists), [member/2]).
delete( X, [X|L], L).
delete( Y, [X|Xs], [X|Xt]) :-
delete( Y, Xs, Xt).
handler arc.
constraints dom/2, con/3.
% dom(X,D) variable X can take values from finite domain D, a ground list
% con(C,X,Y) there is a constraint C between variables X and Y
dom(X,[Y]) ==> X=Y. % only to make unique solutions visible as bindings
con(C,X,Y) \ dom(X,XD), dom(Y,YD) <=>
reduce(x_y,X,XD,Y,YD,C, NYD),
reduce(y_x,Y,YD,X,XD,C, NXD),
\+ (XD=NXD,YD=NYD)
|
dom(X,NXD),dom(Y,NYD).
reduce(CXY,X,XD,Y,YD,C, NYD):- % try to reduce domain by one element
delete(GY,YD,NYD1),
\+ (member(GX,XD),test(CXY,C,GX,GY))
-> reduce(CXY,X,XD,Y,NYD1,C, NYD)
;
YD=NYD.
test(x_y,C,GX,GY):-
test(C,GX,GY).
test(y_x,C,GX,GY):-
test(C,GY,GX).
% An Instance: Santa Claus Example (in German)
example([anna-Anna,berta-Berta,carola-Carola,carl-Carl]):-
dom(Anna,[laetzchen,schlafmuetze,filzpantoffel]),
dom(Berta,[laetzchen,schlafmuetze,filzpantoffel]),
dom(Carola,[laetzchen,schlafmuetze,filzpantoffel]),
dom(Carl,[schlafmuetze,filzpantoffel]),
con(mehr_als,Carl,Anna),
con(mehr_als,Berta,Carl),
con(mehr_als,Berta,Carola),
con(mindestens_wie,Berta,Carola),
con(gleich_wie,Carl,Carola).
test(mehr_als,Geschenk,Geschenk1) :-
preis(Geschenk,Preis),
preis(Geschenk1,Preis1),
Preis > Preis1.
test(mindestens_wie,Geschenk,Geschenk1) :-
preis(Geschenk,Preis),
preis(Geschenk1,Preis1),
Preis >= Preis1.
test(gleich_wie,Geschenk,Geschenk1) :-
preis(Geschenk,Preis),
preis(Geschenk1,Preis).
preis(laetzchen,10).
preis(schlafmuetze,20).
preis(filzpantoffel,30).
% eof handler arc -------------------------------------

282
CHR/chr/examples/bool.pl
View File

@ -1,282 +0,0 @@
% Thom Fruehwirth ECRC 1991-1993
% 910528 started boolean,and,or constraints
% 910904 added xor,neg constraints
% 911120 added imp constraint
% 931110 ported to new release
% 931111 added card constraint
% 961107 Christian Holzbaur, SICStus mods
:- use_module( library(chr)).
handler bool.
constraints boolean/1, and/3, or/3, xor/3, neg/2, imp/2.
constraints labeling/0.
boolean(0) <=> true.
boolean(1) <=> true.
labeling, boolean(A)#Pc <=>
(A=0 ; A=1),
labeling
pragma passive(Pc).
% and/3 specification
%and(0,0,0).
%and(0,1,0).
%and(1,0,0).
%and(1,1,1).
and(0,X,Y) <=> Y=0.
and(X,0,Y) <=> Y=0.
and(1,X,Y) <=> Y=X.
and(X,1,Y) <=> Y=X.
and(X,Y,1) <=> X=1,Y=1.
and(X,X,Z) <=> X=Z.
%and(X,Y,X) <=> imp(X,Y).
%and(X,Y,Y) <=> imp(Y,X).
and(X,Y,A) \ and(X,Y,B) <=> A=B.
and(X,Y,A) \ and(Y,X,B) <=> A=B.
labeling, and(A,B,C)#Pc <=>
label_and(A,B,C),
labeling
pragma passive(Pc).
label_and(0,X,0).
label_and(1,X,X).
% or/3 specification
%or(0,0,0).
%or(0,1,1).
%or(1,0,1).
%or(1,1,1).
or(0,X,Y) <=> Y=X.
or(X,0,Y) <=> Y=X.
or(X,Y,0) <=> X=0,Y=0.
or(1,X,Y) <=> Y=1.
or(X,1,Y) <=> Y=1.
or(X,X,Z) <=> X=Z.
%or(X,Y,X) <=> imp(Y,X).
%or(X,Y,Y) <=> imp(X,Y).
or(X,Y,A) \ or(X,Y,B) <=> A=B.
or(X,Y,A) \ or(Y,X,B) <=> A=B.
labeling, or(A,B,C)#Pc <=>
label_or(A,B,C),
labeling
pragma passive(Pc).
label_or(0,X,X).
label_or(1,X,1).
% xor/3 specification
%xor(0,0,0).
%xor(0,1,1).
%xor(1,0,1).
%xor(1,1,0).
xor(0,X,Y) <=> X=Y.
xor(X,0,Y) <=> X=Y.
xor(X,Y,0) <=> X=Y.
xor(1,X,Y) <=> neg(X,Y).
xor(X,1,Y) <=> neg(X,Y).
xor(X,Y,1) <=> neg(X,Y).
xor(X,X,Y) <=> Y=0.
xor(X,Y,X) <=> Y=0.
xor(Y,X,X) <=> Y=0.
xor(X,Y,A) \ xor(X,Y,B) <=> A=B.
xor(X,Y,A) \ xor(Y,X,B) <=> A=B.
labeling, xor(A,B,C)#Pc <=>
label_xor(A,B,C),
labeling
pragma passive(Pc).
label_xor(0,X,X).
label_xor(1,X,Y):- neg(X,Y).
% neg/2 specification
%neg(0,1).
%neg(1,0).
neg(0,X) <=> X=1.
neg(X,0) <=> X=1.
neg(1,X) <=> X=0.
neg(X,1) <=> X=0.
neg(X,X) <=> fail.
neg(X,Y) \ neg(Y,Z) <=> X=Z.
neg(X,Y) \ neg(Z,Y) <=> X=Z.
neg(Y,X) \ neg(Y,Z) <=> X=Z.
% Interaction with other boolean constraints
neg(X,Y) \ and(X,Y,Z) <=> Z=0.
neg(Y,X) \ and(X,Y,Z) <=> Z=0.
neg(X,Z) , and(X,Y,Z) <=> X=1,Y=0,Z=0.
neg(Z,X) , and(X,Y,Z) <=> X=1,Y=0,Z=0.
neg(Y,Z) , and(X,Y,Z) <=> X=0,Y=1,Z=0.
neg(Z,Y) , and(X,Y,Z) <=> X=0,Y=1,Z=0.
neg(X,Y) \ or(X,Y,Z) <=> Z=1.
neg(Y,X) \ or(X,Y,Z) <=> Z=1.
neg(X,Z) , or(X,Y,Z) <=> X=0,Y=1,Z=1.
neg(Z,X) , or(X,Y,Z) <=> X=0,Y=1,Z=1.
neg(Y,Z) , or(X,Y,Z) <=> X=1,Y=0,Z=1.
neg(Z,Y) , or(X,Y,Z) <=> X=1,Y=0,Z=1.
neg(X,Y) \ xor(X,Y,Z) <=> Z=1.
neg(Y,X) \ xor(X,Y,Z) <=> Z=1.
neg(X,Z) \ xor(X,Y,Z) <=> Y=1.
neg(Z,X) \ xor(X,Y,Z) <=> Y=1.
neg(Y,Z) \ xor(X,Y,Z) <=> X=1.
neg(Z,Y) \ xor(X,Y,Z) <=> X=1.
neg(X,Y) , imp(X,Y) <=> X=0,Y=1.
neg(Y,X) , imp(X,Y) <=> X=0,Y=1.
labeling, neg(A,B)#Pc <=>
label_neg(A,B),
labeling
pragma passive(Pc).
label_neg(0,1).
label_neg(1,0).
% imp/2 specification (implication)
%imp(0,0).
%imp(0,1).
%imp(1,1).
imp(0,X) <=> true.
imp(X,0) <=> X=0.
imp(1,X) <=> X=1.
imp(X,1) <=> true.
imp(X,X) <=> true.
imp(X,Y),imp(Y,X) <=> X=Y.
labeling, imp(A,B)#Pc <=>
label_imp(A,B),
labeling
pragma passive(Pc).
label_imp(0,X).
label_imp(1,1).
% Boolean cardinality operator
% card(A,B,L,N) constrains list L of length N to have between A and B 1s
constraints card/4.
card(A,B,L):-
length(L,N),
A=<B,0=<B,A=<N,%0=<N
card(A,B,L,N).
% card/4 specification
%card(A,B,[],0):- A=<0,0=<B.
%card(A,B,[0|L],N):-
% N1 is N-1,
% card(A,B,L,N1).
%card(A,B,[1|L],N):-
% A1 is A-1, B1 is B-1, N1 is N-1,
% card(A1,B1,L,N1).
triv_sat @ card(A,B,L,N) <=> A=<0,N=<B | true. % trivial satisfaction
pos_sat @ card(N,B,L,N) <=> set_to_ones(L). % positive satisfaction
neg_sat @ card(A,0,L,N) <=> set_to_zeros(L). % negative satisfaction
pos_red @ card(A,B,L,N) <=> delete(X,L,L1),X==1 | % positive reduction
A1 is A-1, B1 is B-1, N1 is N-1,
card(A1,B1,L1,N1).
neg_red @ card(A,B,L,N) <=> delete(X,L,L1),X==0 | % negative reduction
N1 is N-1,
card(A,B,L1,N1).
% special cases with two variables
card2nand @ card(0,1,[X,Y],2) <=> and(X,Y,0).
card2neg @ card(1,1,[X,Y],2) <=> neg(X,Y).
card2or @ card(1,2,[X,Y],2) <=> or(X,Y,1).
delete( X, [X|L], L).
delete( Y, [X|Xs], [X|Xt]) :-
delete( Y, Xs, Xt).
labeling, card(A,B,L,N)#Pc <=>
label_card(A,B,L,N),
labeling
pragma passive(Pc).
label_card(A,B,[],0):- A=<0,0=<B.
label_card(A,B,[0|L],N):-
N1 is N-1,
card(A,B,L).
label_card(A,B,[1|L],N):-
A1 is A-1, B1 is B-1, N1 is N-1,
card(A1,B1,L).
set_to_ones([]).
set_to_ones([1|L]):-
set_to_ones(L).
set_to_zeros([]).
set_to_zeros([0|L]):-
set_to_zeros(L).
% Auxiliary predicates
operator(100,fy,(~~)).
operator(100,xfy,(#)).
solve_bool(A,C) :- var(A), !, A=C.
solve_bool(A,C) :- atomic(A), !, A=C.
solve_bool(A * B, C) ?- !,
solve_bool(A,A1),
solve_bool(B,B1),
and(A1,B1,C).
solve_bool(A + B, C) ?- !,
solve_bool(A,A1),
solve_bool(B,B1),
or(A1,B1,C).
solve_bool(A # B, C) ?- !,
solve_bool(A,A1),
solve_bool(B,B1),
xor(A1,B1,C).
solve_bool(~~A,C) ?- !,
solve_bool(A,A1),
neg(A1,C).
solve_bool((A -> B), C) ?- !,
solve_bool(A,A1),
solve_bool(B,B1),
imp(A1,B1),C=1.
solve_bool(A = B, C) ?- !,
solve_bool(A,A1),
solve_bool(B,B1),
A1=B1,C=1.
% Labeling
label_bool([]).
label_bool([X|L]) :-
(X=0;X=1),
label_bool(L).
/* % no write macros in SICStus
bool_portray(and(A,B,C),Out)?- !, Out = (A*B = C).
bool_portray(or(A,B,C),Out)?- !, Out = (A+B = C).
bool_portray(xor(A,B,C),Out)?- !, Out = (A#B = C).
bool_portray(neg(A,B),Out)?- !, Out = (A= ~~B).
bool_portray(imp(A,B),Out)?- !, Out = (A -> B).
bool_portray(card(A,B,L,N),Out)?- !, Out = card(A,B,L).
:- define_macro(type(compound),bool_portray/2,[write]).
*/
/* end of handler bool */

141
CHR/chr/examples/cft.pl
View File

@ -1,141 +0,0 @@
% Feature Tree Constraints (CFT) ---------------------------------------------
% following Records for Logic Programming (Smolka,Treinen) JLP 1994:18:229-258
% 950512 Thom Fruehwirth ECRC, based on osf.pl, see also kl-one.pl, type.pl
% 980211, 980311 Thom Fruehwirth LMU for Sicstus CHR
:- use_module( library(chr)).
handler cft.
operator(100,xfx,'::'). % Variable::Sort/Expression sort constraint
operator(100,xfx,'@@'). % Variable@@LabelList arity/label constraint
operator(450,xfy,'##'). % Variable##Feature##Value feature constraint
% in X@@A assumes that A is a sorted list of ground features
% in X##F##Y assumes that feature F is a ground term and Y stays a variable or is atomic
constraints (::)/2, (@@)/2, (##)/2.
% CFT Term Dissolution
X::T <=> nonvar(T), \+ atomic(T) | dissolve(X,T).
dissolve(X,T):-
T=..[S|Ls], X::S, dissolve1(X,Ls,A), sort(A,As), X@@As.
dissolve1(X,[],[]).
dissolve1(X,[L1::T1|Ls],[L1|Ls1]):-
X##L1##TV,
(nonvar(T1) -> dissolve(TV,T1) ; TV=T1),
dissolve1(X,Ls,Ls1).
%!!! sort arity list, load member/2
% CFT Axiom scheme
% see section 3, p.235, p.236
% see proof of proposition 6.5, p.245
% (S) sort are pairwise disjoint
X::S1 \ X::S2 <=> S1=S2.
% (F) features are functional
X##L##Y \ X##L##Z <=> Y=Z.
% (A2) arities are unique
% sorting removes duplicate features
X@@A1 \ X@@A2 <=> A1=A2.
% (A1) If X has arity A, exactly the features in A are defined on X
X@@A, X##F##Y ==> member(F,A).
member(X,[Y|L]):- X=Y ; member(X,L).
% (D) determinant
% not implemented yet
% EXAMPLES ---------------------------------------------------------------
% page 236, determinant
eg0([U,V,W]-[X,Y,Z]):-
X::a(f::V,g::Y),
Y::b(f::X,g::Z,h::u),
Z::a(f::W,g::Y,h::Z).
% cyclic structure, adapted from page 1, DEC-PRL RR 32
eg1(P):-
P::person(name::id(first::_,
last::S),
age::30,
spouse::person(name::id(last::S),
spouse::P)).
% cyclic list, adapted from p. 3, DEC-PRL RR 32
eg2(X):-
X::cons(head::1,tail::X).
eg2a(X):- % same result as eg2(X)
X::cons(head::1,tail::X), X::cons(head::1,tail::cons(head::1,tail::X)).
% adapted from p.17, DEC-PRL RR 32
eg3(X):-
X::s1(l1::s),X::s2(l2::s).
/*
| ?- eg0(X); eg1(X) ; eg2(X) ; eg2a(X) ; eg3(X).
X = [_A,_B,_C]-[_D,_E,_F],
_D::a,
_D##f##_B,
_D##g##_E,
_D@@[f,g],
_E::b,
_E##f##_D,
_E##g##_F,
_E##h##_G,
_G::u,
_G@@[],
_E@@[f,g,h],
_F::a,
_F##f##_C,
_F##g##_E,
_F##h##_F,
_F@@[f,g,h] ? ;
X::person,
X##name##_A,
_A::id,
_A##first##_B,
_A##last##_C,
_A@@[first,last],
X##age##_D,
_D::30,
_D@@[],
X##spouse##_E,
_E::person,
_E##name##_F,
_F::id,
_F##last##_C,
_F@@[last],
_E##spouse##X,
_E@@[name,spouse],
X@@[age,name,spouse] ? ;
X::cons,
X##head##_A,
_A::1,
_A@@[],
X##tail##X,
X@@[head,tail] ? ;
X::cons,
X##head##_A,
_A::1,
_A@@[],
X##tail##X,
X@@[head,tail] ? ;
*/
% end of handler cft ----------------------------------------------------------

472
CHR/chr/examples/domain.pl
View File

@ -1,472 +0,0 @@
% FINITE and INFINITE DOMAINS
% 910527 ECRC thom fruehwirth
% 910913 modified
% 920409 element/3 added
% 920616 more CHIP predicates added
% 930726 started porting to CHR release
% 931014 mult/3 added for CHIC user meeting
% 931201 ported to CHR release
% 931208 removed special case of integer domain
% 940304 element/3 constraint loop fixed
% 961017 Christian Holzbaur SICStus mods
% 980714 Thom Fruehwirth, some updates reagrding alread_in*
% just quick port from Eclipse CHR library version
% does not take advantage of Sicstus CHR library features!
% Simplifies domains together with inequalities and some more CHIP predicates:
% element/3, atmost/3, alldistinct/1, circuit/1 and mult/3
% It also includes paired (!) domains (see element constraint)
:- use_module( library(chr)).
:- use_module( library('chr/getval')).
:- use_module( library(lists), [member/2,last/2]).
:- use_module( library(ordsets),
[
list_to_ord_set/2,
ord_intersection/3
]).
handler domain.
option(already_in_store, on).
option(already_in_heads, off). % see pragma already_in_heads
option(check_guard_bindings, off).
% for domain constraints
operator(700,xfx,'::').
operator(600,xfx,'..').
operator(600,xfx,':'). % clash with module operator?
% for inequality constraints
operator(700,xfx,lt).
operator(700,xfx,le).
operator(700,xfx,gt).
operator(700,xfx,ge).
operator(700,xfx,ne).
% X::Dom - X must be element of the finite or infinite domain Dom
% Domains can be either numbers (including arithemtic expressions)
% or arbitrary ground terms (!), the domain is set with setval(domain,Kind),
% where Kind is either number or term. Default for Kind is term.
:- setval(domain,term). % set default
% INEQUALITIES ===============================================================
% inequalities over numbers (including arithmetic expressions) or terms
constraints lt/2,le/2,ne/2.
A gt B :- B lt A. % constraints gt/2,ge/2
A ge B :- B le A.
% some basic simplifications
A lt A <=> fail.
A le A <=> true.
A ne A <=> fail.
A lt B,B lt A <=> fail.
A le B,B le A <=> A=B.
A ne B \ B ne A <=> true.
% for number domain, allow arithmetic expressions in the arguments
A lt B <=> domain(number),ground(A),\+ number(A) | A1 is A, A1 lt B.
B lt A <=> domain(number),ground(A),\+ number(A) | A1 is A, B lt A1.
A le B <=> domain(number),ground(A),\+ number(A) | A1 is A, A1 le B.
B le A <=> domain(number),ground(A),\+ number(A) | A1 is A, B le A1.
A ne B <=> domain(number),ground(A),\+ number(A) | A1 is A, A1 ne B.
B ne A <=> domain(number),ground(A),\+ number(A) | A1 is A, B ne A1.
% use built-ins to solve the predicates if arguments are known
A lt B <=> ground(A),ground(B) | (domain(number) -> A < B ; A @< B).
A le B <=> ground(A),ground(B) | (domain(number) -> A =< B ; A @=< B).
A ne B <=> ground(A),ground(B) | (domain(number) -> A =\= B ; A \== B).
% FINITE and INFINITE DOMAINS ================================================
constraints (::)/2.
% enforce groundness of domain expression
X::Dom <=> nonground(Dom) |
raise_exception( instantiation_error(X::Dom,2)).
constraints labeling/0.
labeling, (X::[Y|L]) # Ph <=>
member(X,[Y|L]), labeling
pragma passive(Ph).
% binary search by splitting domain in halves
labeling, (X::Min:Max) # Ph <=> domain(number),Min+0.5<Max | % ensure termination
(integer(Min),integer(Max) -> % assume we have integer domain
Mid is (Min+Max)//2, Next is Mid+1
;
Mid is (Min+Max)/2, Next=Mid % splitted domains overlap at Mid for floats
),
(
X::Min:Mid
;
X::Next:Max
% ;
% Min+1>Max, % for floats only, to get X also bound
% X=Min % or X=Max etc.
),
labeling
pragma passive(Ph).
nonground(X) :- ground(X), !, fail.
nonground(_).
domain(Kind) :- getval(domain,Kind).
% CHIP list shorthand for domain variables
% list must be known (end in the empty list)
[X|L]::Dom <=> makedom([X|L],Dom).
makedom([],D) :- true.
makedom([X|L],D) :-
nonvar(L),
X::D,
makedom(L,D).
% Consecutive integer domain ---------------------------------------------
% X::Min..Max - X is an integer between the numbers Min and Max (included)
% constraint is mapped to enumeration domain constraint
X::Min..Max <=>
Min0 is Min,
(Min0=:=round(float(Min0)) -> Min1 is integer(Min0) ; Min1 is integer(Min0+1)),
Max1 is integer(Max),
interval(Min1,Max1,L),
X::L.
interval(M,N,[M|Ns]):-
M<N,
!,
M1 is M+1,
interval(M1,N,Ns).
interval(N,N,[N]).
% Enumeration domain -----------------------------------------------------
% X::Dom - X must be a ground term in the ascending sorted ground list Dom
X::[A|L] <=> list_to_ord_set([A|L],SL), SL\==[A|L] | X::SL.
% for number domain, allow arithmetic expressions in domain
X::[A|L] <=> domain(number), member(X,[A|L]), \+ number(X) |
eval_list([A|L],L1),list_to_ord_set(L1,L2), X::L2.
eval_list([],[]).
eval_list([X|L1],[Y|L2]):-
Y is X,
eval_list(L1,L2).
% special cases
X::[] <=> fail.
X::[Y] <=> X=Y.
X::[A|L] <=> ground(X) | (member(X,[A|L]) -> true).
% intersection of domains for the same variable
% without pragma already_in_heads, needs already_in_store
X::[A1|L1] \ X::[A2|L2] <=>
ord_intersection([A1|L1],[A2|L2],L),
L \== [A2|L2]
|
X::L.
% interaction with inequalities
X::[A|L] \ X ne Y <=> integer(Y), remove(Y,[A|L],L1) | X::L1.
X::[A|L] \ Y ne X <=> integer(Y), remove(Y,[A|L],L1) | X::L1.
X::[A|L], Y le X ==> ground(Y), remove_lower(Y,[A|L],L1) | X::L1.
X::[A|L], X le Y ==> ground(Y), remove_higher(Y,[A|L],L1) | X::L1.
X::[A|L], Y lt X ==> ground(Y), remove_lower(Y,[A|L],L1),remove(Y,L1,L2) | X::L2.
X::[A|L], X lt Y ==> ground(Y), remove_higher(Y,[A|L],L1),remove(Y,L1,L2) | X::L2.
% interaction with interval domain
X::[A|L], X::Min:Max ==> remove_lower(Min,[A|L],L1),remove_higher(Max,L1,L2) | X::L2.
% propagation of bounds
X le Y, Y::[A|L] ==> var(X) | last([A|L],Max), X le Max.
X le Y, X::[Min|_] ==> var(Y) | Min le Y.
X lt Y, Y::[A|L] ==> var(X) | last([A|L],Max), X lt Max.
X lt Y, X::[Min|_] ==> var(Y) | Min lt Y.
% Interval domain ---------------------------------------------------------
% X::Min:Max - X must be a ground term between Min and Max (included)
% for number domain, allow for arithmetic expressions ind omain
% for integer domains, X::Min..Max should be used
X::Min:Max <=> domain(number), \+ (number(Min),number(Max)) |
Min1 is Min, Max1 is Max, X::Min1:Max1.
% special cases
X::Min:Min <=> X=Min.
X::Min:Max <=> (domain(number) -> Min>Max ; Min@>Max) | fail.
X::Min:Max <=> ground(X) |
(domain(number) -> Min=<X,X=<Max ; Min@=<X,X@=<Max).
% intersection of domains for the same variable
% without pragma already_in_heads, needs already_in_store
X::Min1:Max1 \ X::Min2:Max2 <=> maximum(Min1,Min2,Min),
minimum(Max1,Max2,Max),
(Min \== Min2 ; Max \== Max2 ) |
X::Min:Max.
minimum(A,B,C):- (domain(number) -> A<B ; A@<B) -> A=C ; B=C.
maximum(A,B,C):- (domain(number) -> A<B ; A@<B) -> B=C ; A=C.
% interaction with inequalities
X::Min:Max \ X ne Y <=> ground(Y),
(domain(number) -> (Y<Min;Y>Max) ; (Y@<Min;Y@>Max)) | true.
X::Min:Max \ Y ne X <=> ground(Y),
(domain(number) -> (Y<Min;Y>Max) ; (Y@<Min;Y@>Max)) | true.
X::Min1:Max \ Min2 le X <=> ground(Min2) , maximum(Min1,Min2,Min) | X::Min:Max.
X::Min:Max1 \ X le Max2 <=> ground(Max2) , minimum(Max1,Max2,Max) | X::Min:Max.
X::Min1:Max \ Min2 lt X <=> ground(Min2) , maximum(Min1,Min2,Min) |
X::Min:Max, X ne Min.
X::Min:Max1 \ X lt Max2 <=> ground(Max2) , minimum(Max1,Max2,Max) |
X::Min:Max, X ne Max.
% propagation of bounds
X le Y, Y::Min:Max ==> var(X) | X le Max.
X le Y, X::Min:Max ==> var(Y) | Min le Y.
X lt Y, Y::Min:Max ==> var(X) | X lt Max.
X lt Y, X::Min:Max ==> var(Y) | Min lt Y.
% MULT/3 EXAMPLE EXTENSION ==================================================
% mult(X,Y,C) - integer X multiplied by integer Y gives the integer constant C.
constraints mult/3.
mult(X,Y,C) <=> ground(X) | (X=:=0 -> C=:=0 ; 0=:=C mod X, Y is C//X).
mult(Y,X,C) <=> ground(X) | (X=:=0 -> C=:=0 ; 0=:=C mod X, Y is C//X).
mult(X,Y,C), X::MinX:MaxX ==>
%(Dom=MinX:MaxX -> true ; Dom=[MinX|L],last(L,MaxX)),
MinY is (C-1)//MaxX+1,
MaxY is C//MinX,
Y::MinY:MaxY.
mult(Y,X,C), X::MinX:MaxX ==>
%(Dom=MinX:MaxX -> true ; Dom=[MinX|L],last(L,MaxX)),
MinY is (C-1)//MaxX+1,
MaxY is C//MinX,
Y::MinY:MaxY.
/*
:- mult(X,Y,156),[X,Y]::2:156,X le Y.
X = X_g307
Y = Y_g331
Constraints:
(1) mult(X_g307, Y_g331, 156)
(7) Y_g331 :: 2 : 78
(8) X_g307 :: 2 : 78
(10) X_g307 le Y_g331
yes.
:- mult(X,Y,156),[X,Y]::2:156,X le Y,labeling.
X = 12
Y = 13 More? (;)
X = 6
Y = 26 More? (;)
X = 4
Y = 39 More? (;)
X = 2
Y = 78 More? (;)
X = 3
Y = 52 More? (;)
no (more) solution.
*/
% CHIP ELEMENT/3 ============================================================
% translated to "pair domains", a very powerful extension of usual domains
% this version does not work with arithmetic expressions!
element(I,VL,V):- length(VL,N),interval(1,N,IL),gen_pair(IL,VL,BL), I-V::BL.
gen_pair([],[],[]).
gen_pair([A|L1],[B|L2],[A-B|L3]):-
gen_pair(L1,L2,L3).
% special cases
I-I::L <=> setof(X,member(X-X,L),L1), I::L1.
I-V::L <=> ground(I) | setof(X,member(I-X,L),L1), V::L1.
I-V::L <=> ground(V) | setof(X,member(X-V,L),L1), I::L1.
% intersections
X::[A|L1], X-Y::L2 <=> intersect(I::[A|L1],I-V::L2,I-V::L3),
length(L2,N2),length(L3,N3),N2>N3 | X-Y::L3.
Y::[A|L1], X-Y::L2 <=> intersect(V::[A|L1],I-V::L2,I-V::L3),
length(L2,N2),length(L3,N3),N2>N3 | X-Y::L3.
X-Y::L1, Y-X::L2 <=> intersect(I-V::L1,V-I::L2,I-V::L3) | X-Y::L3.
X-Y::L1, X-Y::L2 <=> intersect(I-V::L1,I-V::L2,I-V::L3) | X-Y::L3 pragma already_in_heads.
intersect(A::L1,B::L2,C::L3):- setof(C,A^B^(member(A,L1),member(B,L2)),L3).
% inequalties with two common variables
Y lt X, X-Y::L <=> A=R-S,setof(A,(member(A,L),R@< S),L1) | X-Y::L1.
X lt Y, X-Y::L <=> A=R-S,setof(A,(member(A,L),S@< R),L1) | X-Y::L1.
Y le X, X-Y::L <=> A=R-S,setof(A,(member(A,L),R@=<S),L1) | X-Y::L1.
X le Y, X-Y::L <=> A=R-S,setof(A,(member(A,L),S@=<R),L1) | X-Y::L1.
Y ne X, X-Y::L <=> A=R-S,setof(A,(member(A,L),R\==S),L1) | X-Y::L1.
X ne Y, X-Y::L <=> A=R-S,setof(A,(member(A,L),S\==R),L1) | X-Y::L1.
% propagation between paired domains (path-consistency)
% X-Y::L1, Y-Z::L2 ==> intersect(A-B::L1,B-C::L2,A-C::L), X-Z::L.
% X-Y::L1, Z-Y::L2 ==> intersect(A-B::L1,C-B::L2,A-C::L), X-Z::L.
% X-Y::L1, X-Z::L2 ==> intersect(I-V::L1,I-W::L2,V-W::L), Y-Z::L.
% propagation to usual unary domains
X-Y::L ==> A=R-S,setof(R,A^member(A,L),L1), X::L1,
setof(S,A^member(A,L),L2), Y::L2.
% ATMOST/3 ===================================================================
atmost(N,List,V):-length(List,K),atmost(N,List,V,K).
constraints atmost/4.
atmost(N,List,V,K) <=> K=<N | true.
atmost(0,List,V,K) <=> (ground(V);ground(List)) | outof(V,List).
atmost(N,List,V,K) <=> K>N,ground(V),delete_ground(X,List,L1) |
(X==V -> N1 is N-1 ; N1=N),K1 is K-1, atmost(N1,L1,V,K1).
delete_ground(X,List,L1):- delete(X,List,L1),ground(X),!.
delete( X, [X|Xs], Xs).
delete( Y, [X|Xs], [X|Xt]) :-
delete( Y, Xs, Xt).
% ALLDISTINCT/1 ===============================================================
% uses ne/2 constraint
constraints alldistinct/1.
alldistinct([]) <=> true.
alldistinct([X]) <=> true.
alldistinct([X,Y]) <=> X ne Y.
alldistinct([A|L]) <=> delete_ground(X,[A|L],L1) | outof(X,L1),alldistinct(L1).
alldistinct([]).
alldistinct([X|L]):-
outof(X,L),
alldistinct(L).
outof(X,[]).
outof(X,[Y|L]):-
X ne Y,
outof(X,L).
constraints alldistinct1/2.
alldistinct1(R,[]) <=> true.
alldistinct1(R,[X]), X::[A|L] <=> ground(R) |
remove_list(R,[A|L],T), X::T.
alldistinct1(R,[X]) <=> (ground(R);ground(X)) | outof(X,R).
alldistinct1(R,[A|L]) <=> ground(R),delete_ground(X,[A|L],L1) |
(member(X,R) -> fail ; alldistinct1([X|R],L1)).
% CIRCUIT/1 =================================================================
% constraints circuit1/1, circuit/1.
% uses list domains and ne/2
% lazy version
circuit1(L):-length(L,N),N>1,circuit1(N,L).
circuit1(2,[2,1]).
circuit1(N,L):- N>2,
interval(1,N,D),
T=..[f|L],
domains1(1,D,L),
alldistinct1([],L),
no_subtours(N,1,T,[]).
domains1(N,D,[]).
domains1(N,D,[X|L]):-
remove(N,D,DX),
X::DX,
N1 is N+1,
domains1(N1,D,L).
no_subtours(0,N,L,R):- !.
no_subtours(K,N,L,R):-
outof(N,R),
(var(N) -> freeze(N,no_subtours1(K,N,L,R)) ; no_subtours1(K,N,L,R)).
% no_subtours(K,N,T,R) \ no_subtours(K1,N,T,_) <=> K<K1 | true.
no_subtours1(K,N,L,R):-
K>0,K1 is K-1,arg(N,L,A),no_subtours(K1,A,L,[N|R]).
% eager version
circuit(L):- length(L,N),N>1,circuit(N,L).
circuit(2,[2,1]).
%circuit(3,[2,3,1]).
%circuit(3,[3,1,2]).
circuit(N,L):- N>2,
interval(1,N,D),
T=..[f|L],
N1 is N-1,
domains(1,D,L,T,N1),
alldistinct(L).
domains(N,D,[],T,K).
domains(N,D,[X|L],T,K):-
remove(N,D,DX),
X::DX,
N1 is N+1,
no_subtours(K,N,T,[]), % unfolded
%no_subtours1(K,X,T,[N]),
domains(N1,D,L,T,K).
% remove*/3 auxiliary predicates =============================================
remove(A,B,C):-
delete(A,B,C) -> true ; B=C.
remove_list(_,[],T):- !, T=[].
remove_list([],S,T):- S=T.
remove_list([X|R],[Y|S],T):- remove(X,[Y|S],S1),remove_list(R,S1,T).
remove_lower(_,[],L1):- !, L1=[].
remove_lower(Min,[X|L],L1):-
X@<Min,
!,
remove_lower(Min,L,L1).
remove_lower(Min,[X|L],[X|L1]):-
remove_lower(Min,L,L1).
remove_higher(_,[],L1):- !, L1=[].
remove_higher(Max,[X|L],L1):-
X@>Max,
!,
remove_higher(Max,L,L1).
remove_higher(Max,[X|L],[X|L1]):-
remove_higher(Max,L,L1).
% end of handler domain.chr =================================================
% ===========================================================================

235
CHR/chr/examples/examples-adder.bool
View File

@ -1,235 +0,0 @@
% Simple examples for boolean handler
/*
[eclipse 6]: and(X,Y,Z),(X=1;X=0;X=Y).
Z = Var_m333
X = 1
Y = Var_m333
Constraints:
(3) boolean(Var_m333)
More? (;)
Z = 0
X = 0
Y = Var_m333
Constraints:
(3) boolean(Var_m333)
More? (;)
Z = _m309
X = _m309
Y = _m309
Constraints:
(3) boolean(_m309)
yes.
*/
% alternative formulations
nand1(X1,Y1,Z):- and(X,Y,Z),neg(X1,X),neg(Y1,Y).
nand2(X1,Y1,Z):- or(X1,Y1,Z1),neg(Z1,Z).
test_nand(X,Y,Z1,Z2):- nand1(X,Y,Z1),nand2(X,Y,Z2),neg(Z1,Z2).
or1(X,Y,Z):- nand1(X,Y,Z1),neg(Z1,Z).
or2(X,Y,Z):- nand2(X,Y,Z1),neg(Z1,Z).
or3(A,B,C):- xor(A,B,D),and(A,B,E),xor(D,E,C).
test_or(A,B,C,D):- (or1(A,B,C);or2(A,B,C);or3(A,B,C)),or(A,B,D),neg(C,D).
xor1(A,B,C):- or(A,B,C1), and(A,B,C2), neg(C2,C3), and(C1,C3,C).
test_xor(A,B,C,D):- xor1(A,B,C),xor(A,B,D),neg(C,D).
and1(A,B,C):- neg(A,AN),neg(B,BN),or(AN,BN,CN),neg(CN,C).
test_and(A,B,C,D):- and1(A,B,C),and(A,B,D),neg(C,D).
test(X,Y,Z):- and(X,Y,Z),or(X,Y,Z),neg(X,Z).
% full-adder circuit boolean algebra example sept 1991, nov 1993
add(I1,I2,I3,O1,O2):-
xor(I1,I2,X1),
and(I1,I2,A1),
xor(I3,X1,O1),
and(I3,X1,A2),
or(A1,A2,O2).
/*
add(L1,L2,L3):- add(L1,L2,L3,0).
add([],[],[C],C).
add([X|L1],[Y|L2],[Z|L3],C):-
add(X,Y,C,Z,C1),
add(L1,L2,L3,C1).
*/
add(L1,L2,[C|L3]):- add(L1,L2,L3,C).
add([],[],[],0).
add([X|L1],[Y|L2],[Z|L3],C):-
add(L1,L2,L3,C1),
add(X,Y,C1,Z,C).
/*
[eclipse 56]: add(L,L,R).
L = []
R = [0] More? (;)
L = [_g71]
R = [_g71, 0] More? (;)
L = [_g71, _g79]
R = [_g71, _g79, 0] More? (;)
L = [_g71, _g79, _g87]
R = [_g71, _g79, _g87, 0] More? (;)
L = [_g71, _g79, _g87, _g95]
R = [_g71, _g79, _g87, _g95, 0] More? (;)
[eclipse 59]: add([X,X,X],[Y,Y,Y],R), (X=1;X=0;X=Y;neg(X,Y)).
R = [_m5677, Var_m4777, Var_m2407, Var_m419]
X = 1
Y = Var_m395
Constraints:
(39) boolean(_m5251)
(33) boolean(Var_m1499)
(19) and(Var_m395, Var_m1499, 0)
(31) xor(Var_m395, Var_m1499, Var_m4777)
(34) and(Var_m395, Var_m1499, _m5251)
(16) xor(Var_m395, Var_m1499, Var_m2407)
(43) neg(Var_m395, Var_m419)
(38) boolean(Var_m395)
(37) or(Var_m395, _m5251, _m5677)
More? (;)
R = [0, Var_m395, Var_m395, Var_m395]
X = 0
Y = Var_m395
Constraints:
(33) boolean(Var_m395)
More? (;)
R = [_m371, _m371, _m371, 0]
X = _m371
Y = _m371
Constraints:
(3) boolean(_m371)
More? (;)
R = [_m5251, Var_m4777, Var_m2407, Var_m419]
X = _m371
Y = Var_m395
Constraints:
(1) xor(_m371, Var_m395, Var_m419)
(2) boolean(_m371)
(3) boolean(Var_m395)
(4) and(_m371, Var_m395, _m877)
(10) xor(_m371, Var_m395, Var_m1499)
(13) and(_m371, Var_m395, _m1973)
(16) xor(_m877, Var_m1499, Var_m2407)
(17) boolean(_m877)
(18) boolean(Var_m1499)
(19) and(_m877, Var_m1499, _m2881)
(22) or(_m1973, _m2881, _m3307)
(23) boolean(_m1973)
(24) boolean(_m2881)
(25) xor(_m371, Var_m395, Var_m3773)
(31) xor(_m3307, Var_m3773, Var_m4777)
(32) boolean(_m3307)
(33) boolean(Var_m3773)
(39) boolean(_m5251)
(34) and(_m3307, Var_m3773, _m5251)
(28) and(_m371, Var_m395, 0)
yes.
[eclipse 60]: add([X,X,X],[Y,Y,Y],R), (X=1;X=0;X=Y;neg(X,Y)), labeling.
R = [0, 0, 0, 1]
X = 1
Y = 0 More? (;)
R = [1, 1, 1, 0]
X = 1
Y = 1 More? (;)
R = [0, 1, 1, 1]
X = 1
Y = 0 More? (;)
R = [0, 0, 0, 0]
X = 0
Y = 0 More? (;)
R = [0, 1, 1, 1]
X = 0
Y = 1 More? (;)
R = [0, 0, 0, 0]
X = 0
Y = 0 More? (;)
R = [1, 1, 1, 0]
X = 1
Y = 1 More? (;)
R = [0, 0, 0, 0]
X = 0
Y = 0 More? (;)
R = [0, 1, 1, 1]
X = 0
Y = 1 More? (;)
R = [0, 1, 1, 1]
X = 1
Y = 0
yes.
[eclipse 66]: add(L,R,[X|L]).
R = []
X = 0
L = [] More? (;)
R = [0]
X = 0
L = [_m295]
Constraints:
(2) boolean(_m295)
More? (;)
R = [0, 0]
X = 0
L = [_m1785, _m303]
Constraints:
(11) boolean(_m303)
(20) boolean(_m1785)
More? (;)
R = [0, 0, 0]
X = 0
L = [_m3275, _m1793, _m311]
Constraints:
(29) boolean(_m311)
(38) boolean(_m1793)
(47) boolean(_m3275)
More? (;)
yes.
*/

1439
CHR/chr/examples/examples-benchmark.math
View File

File diff suppressed because it is too large Load Diff

115
CHR/chr/examples/examples-deussen.bool
View File

@ -1,115 +0,0 @@
% The Deussen Problem -------------------------------------------------------
/*From mark@ecrc.de Tue Jul 14 11:05:16 1992
I thought a propositional satisfiability example would be good.
I therefore propose the Deussen problem Ulm027r1
(chosen pretty well at random).
Mark Wallace
*/
% the ulm027r1 problem has 16 solutions
% no labeling
deussen0(Vars) :-
ulm027r1(L,Vars),
solve_bools(L).
% built-in labeling
deussen1(Vars) :-
ulm027r1(L,Vars),
solve_bools(L),
labeling.
% user-defined labeling
deussen2(Vars) :-
ulm027r1(L,Vars),
solve_bools(L),
label_bool(Vars).
solve_bools([]).
solve_bools([X|L]) :-
solve_bool(X,1), % boolean expression X must be 1 (true)
solve_bools(L).
% Deussen Problem Ulm027/1
ulm027r1(
[
U12 + U3 + U2,
U12 + ~~U3 + ~~U2,
~~U12 + ~~U3 + U2,
~~U12 + U3 + ~~U2,
U13 + U4 + U12,
U13 + ~~U4 + ~~U12,
~~U13 + ~~U4 + U12,
~~U13 + U4 + ~~U12,
U14 + U5 + U13,
U14 + ~~U5 + ~~U13,
~~U14 + ~~U5 + U13,
~~U14 + U5 + ~~U13,
~~U14,
U15 + U6 + U4,
U15 + ~~U6 + ~~U4,
~~U15 + ~~U6 + U4,
~~U15 + U6 + ~~U4,
U16 + U2 + U15,
U16 + ~~U2 + ~~U15,
~~U16 + ~~U2 + U15,
~~U16 + U2 + ~~U15,
U17 + U2 + U16,
U17 + ~~U2 + ~~U16,
~~U17 + ~~U2 + U16,
~~U17 + U2 + ~~U16,
U18 + U6 + U17,
U18 + ~~U6 + ~~U17,
~~U18 + ~~U6 + U17,
~~U18 + U6 + ~~U17,
~~U18,
U19 + U10 + U3,
U19 + ~~U10 + ~~U3,
~~U19 + ~~U10 + U3,
~~U19 + U10 + ~~U3,
U20 + U11 + U19,
U20 + ~~U11 + ~~U19,
~~U20 + ~~U11 + U19,
~~U20 + U11 + ~~U19,
U21 + U6 + U20,
U21 + ~~U6 + ~~U20,
~~U21 + ~~U6 + U20,
~~U21 + U6 + ~~U20,
U22 + U7 + U21,
U22 + ~~U7 + ~~U21,
~~U22 + ~~U7 + U21,
~~U22 + U7 + ~~U21,
~~U22,
U23 + U5 + U7,
U23 + ~~U5 + ~~U7,
~~U23 + ~~U5 + U7,
~~U23 + U5 + ~~U7,
U24 + U6 + U23,
U24 + ~~U6 + ~~U23,
~~U24 + ~~U6 + U23,
~~U24 + U6 + ~~U23,
U25 + U10 + U24,
U25 + ~~U10 + ~~U24,
~~U25 + ~~U10 + U24,
~~U25 + U10 + ~~U24,
U26 + U11 + U25,
U26 + ~~U11 + ~~U25,
~~U26 + ~~U11 + U25,
~~U26 + U11 + ~~U25,
~~U26
],
[
%U1,
U2,U3,U4,U5,U6,U7, %U8,U9,
U10,U11,U12,U13,U14,U15,U16,U17,U18,U19,
U20,U21,U22,U23,U24,U25,U26
]).

444
CHR/chr/examples/examples-diaz.bool
View File

@ -1,444 +0,0 @@
% Boolean tests from Daniel Diaz
% 931127 adapted to Eclipse and CHRs by Thom Fruehwirth, ECRC
%From diaz@margaux.inria.fr Tue Nov 23 18:59:17 1993
%
%I send you 3 programs schur.pl, pigeon.pl and queens.pl and a file
%b_bips.pl containing the necessary built-ins and libraries.
%---schur.pl---
/*-------------------------------------------------------------------------*/
/* Benchmark (Boolean) INRIA Rocquencourt - ChLoE Project */
/* */
/* Name : bschur.pl */
/* Title : Schur's lemma */
/* Original Source: Giovanna Dore - Italy */
/* Adapted by : Daniel Diaz - INRIA France */
/* Date : January 1993 */
/* */
/* Color the integers 1,2...,N with 3 colors so that there is no monochrome*/
/* triplets (x,y,z) where x+y=z. Solution iff N<=13. */
/* The solution is a list [ [Int11,Int12,Int13],..., [IntN1,IntN2,IntN3] ] */
/* where Intij is 1 if the integer i is colored with the color j. */
/* */
/* Solution: */
/* N=4 [[0,0,1],[0,1,0],[0,0,1],[1,0,0]] */
/* [[0,0,1],[0,1,0],[0,1,0],[0,0,1]] */
/* ... */
/* N=13 [[0,0,1],[0,1,0],[0,1,0],[0,0,1],[1,0,0],[1,0,0],[0,0,1],[1,0,0], */
/* [1,0,0],[0,0,1],[0,1,0],[0,1,0],[0,0,1]] (first solution) */
/*-------------------------------------------------------------------------*/
bschur:- write('N ?'), read(N),
cputime( Starttime),
(schur(N,A),
% write(A), nl,
fail
;
write('No more solutions'), nl),
cputime( Cputime),
Y is Cputime-Starttime,
write('time : '), write(Y), nl.
cputime( Ts) :-
statistics( runtime, [Tm,_]),
Ts is Tm/1000.
schur(N,A):-
create_array(N,3,A),
for_each_line(A,only1),
pair_constraints(A,A),
!,
% labeling.
array_labeling(A).
pair_constraints([],_):-
!.
pair_constraints([_],_):-
!.
pair_constraints([_,[K1,K2,K3]|A2],[[I1,I2,I3]|A1]):-
and0(I1,K1),
and0(I2,K2),
and0(I3,K3),
triplet_constraints(A2,A1,[I1,I2,I3]),
pair_constraints(A2,A1).
triplet_constraints([],_,_).
triplet_constraints([[K1,K2,K3]|A2],[[J1,J2,J3]|A1],[I1,I2,I3]):-
and0(I1,J1,K1),
and0(I2,J2,K2),
and0(I3,J3,K3),
triplet_constraints(A2,A1,[I1,I2,I3]).
%--- pigeon.pl ---
/*-------------------------------------------------------------------------*/
/* Benchmark (Boolean) INRIA Rocquencourt - ChLoE Project */
/* */
/* Name : bpigeon.pl */
/* Title : pigeon-hole problem */
/* Originated from: */
/* Adapted by : Daniel Diaz - INRIA France */
/* Date : January 1993 */
/* */
/* Put N pigeons in M pigeon-holes. Solution iff N<=M. */
/* The solution is a list [ [Pig11,...,Pig1m], ... ,[Pign1,...,Pignm] ] */
/* where Pigij = 1 if the pigeon i is in the pigeon-hole j */
/* */
/* Solution: */
/* N=2 M=3 [[0,0,1],[0,1,0]] */
/* [[0,0,1],[1,0,0]] */
/* [[0,1,0],[0,0,1]] */
/* [[0,1,0],[1,0,0]] */
/* [[1,0,0],[0,0,1]] */
/* [[1,0,0],[0,1,0]] */
/*-------------------------------------------------------------------------*/
bpigeon:- write('N ?'), read(N), write('M ?'), read(M),
cputime( Starttime),
(bpigeon(N,M,A),
% write(A), nl,
fail
;
write('No more solutions'), nl),
cputime( Cputime),
Y is Cputime-Starttime,
write('time : '), write(Y), nl.
bpigeon(N,M,A):-
create_array(N,M,A),
for_each_line(A,only1),
for_each_column(A,atmost1),
!,
array_labeling(A).
%--- queens.pl ---
/*-------------------------------------------------------------------------*/
/* Benchmark (Boolean) INRIA Rocquencourt - ChLoE Project */
/* */
/* Name : bqueens.pl */
/* Title : N-queens problem */
/* Original Source: Daniel Diaz - INRIA France */
/* Adapted by : */
/* Date : January 1993 */
/* */
/* Put N queens on an NxN chessboard so that there is no couple of queens */
/* threatening each other. */
/* The solution is a list [ [Que11,...,Que1N], ... ,[QueN1,...,QueNN] ] */
/* where Queij is 1 if the the is a queen on the ith line an jth row. */
/* */
/* Solution: */
/* N=4 [[0,0,1,0], [[0,1,0,0], */
/* [1,0,0,0], [0,0,0,1], */
/* [0,0,0,1], and [1,0,0,0], */
/* [0,1,0,0]] [0,0,1,0]] */
/* */
/* N=8 [[0,0,0,0,0,0,0,1], (first solution) */
/* [0,0,0,1,0,0,0,0], */
/* [1,0,0,0,0,0,0,0], */
/* [0,0,1,0,0,0,0,0], */
/* [0,0,0,0,0,1,0,0], */
/* [0,1,0,0,0,0,0,0], */
/* [0,0,0,0,0,0,1,0], */
/* [0,0,0,0,1,0,0,0]] */
/*-------------------------------------------------------------------------*/
bqueens:- write('N ?'), read(N),
cputime( Starttime),
(bqueens(N,A),
% write(A), nl,
fail
;
write('No more solutions'), nl),
cputime( Cputime),
Y is Cputime-Starttime,
write('time : '), write(Y), nl.
bqueens(N,A):-
create_array(N,N,A),
for_each_line(A,only1),
for_each_column(A,only1),
for_each_diagonal(A,N,N,atmost1),
!,
array_labeling(A).
%--- b_bips.pl ---
%I also use the following shorthands:
and0(X,Y):-
and(X,Y,0).
% delay([X,Y],and(X,Y,0)).
or1(X,Y):-
or(X,Y,1).
and0(X,Y,Z):-
and(X,Y,XY),
and(XY,Z,0).
% delay([X,Y,Z],(
% and(X,Y,XY),
% and(XY,Z,0))).
or1(X,Y,Z):-
or(X,Y,XY),
or(XY,Z,1).
/*-------------------------------------------------------------------------*/
/* Prolog to Wam Compiler INRIA Rocquencourt - ChLoE Project */
/* Version 1.0 - C Run-time Daniel Diaz - 1991 */
/* Extended to FD Constraints (July 1992) */
/* */
/* Built-In: B predicates (booleans) */
/* */
/* b_bips.pl */
/*-------------------------------------------------------------------------*/
/* Symbolic constraints */
%:- public only_one/1, at_least_one/1, at_most_one/1.
%only_one(L):- card(1,1,L).
%at_most_one(L):- card(0,1,L).
only_one(L):-
at_least_one(L),
at_most_one(L).
at_least_one(L):-
at_least_one1(L,1).
at_least_one1([X],X).
at_least_one1([X|L],R):-
at_least_one1(L,R1),
or(X,R1,R).
at_most_one([]).
at_most_one([X|L]):-
not_two(L,X),
at_most_one(L).
not_two([],_).
not_two([X1|L],X):-
and0(X1,X),
not_two(L,X).
/* Array procedures */
%:- public create_array/3, for_each_line/2, for_each_column/2, for_each_diagonal/4, array_labeling/1.
/*---------------------------------------------------------*/
/* */
/* An array NL x NC elements is represented as follows : */
/* A = [L_1, ..., L_NL] with L_i = [X_i_1, ..., X_i_NC] */
/* Hence : */
/* A = [ [X_1_1,..., X_1_NC], ..., [X_NL_1,..., X_NL_NC] ] */
/*---------------------------------------------------------*/
% create_array(NL,NC,A)
% NL: nb of lines NC:nb of columns A:array
% creates an array (with unbound variables)
create_array(NL,NC,A):-
create_array1(0,NL,NC,A),
!.
create_array1(NL,NL,_,[]).
create_array1(I,NL,NC,[L|A]):-
create_one_line(0,NC,L),
I1 is I+1,
create_array1(I1,NL,NC,A).
create_one_line(NC,NC,[]).
create_one_line(J,NC,[_|L]):-
J1 is J+1,
create_one_line(J1,NC,L).
% for_each_line(A,P)
% A:array P: program atom
% calls: array_prog(P,L) for each line L (L is a list)
for_each_line([],_).
for_each_line([L|A],P):-
array_prog(P,L),
for_each_line(A,P).
% for_each_column(A,P)
% A:array P: program atom
% calls: array_prog(P,L) for each column L (L is a list)
for_each_column([[]|_],_):-
!.
for_each_column(A,P):-
create_column(A,C,A1),
array_prog(P,C),
for_each_column(A1,P).
create_column([],[],[]).
create_column([[X|L]|A],[X|C],[L|A1]):-
create_column(A,C,A1).
% for_each_diagonal(A,NL,NC,P)
% A:array NL: nb of lines
% NC:nb of columns P: program atom
% calls: array_prog(P,L) for each diagonal D (D is a list)
for_each_diagonal(A,NL,NC,P):-
NbDiag is 2*(NL+NC-1), % numbered from 0 to NbDiag-1
create_lst_diagonal(0,NbDiag,LD),
fill_lst_diagonal(A,0,NL,NC,LD,LD1),
!,
for_each_line(LD1,P).
create_lst_diagonal(NbDiag,NbDiag,[]).
create_lst_diagonal(I,NbDiag,[[]|LD]):-
I1 is I+1,
create_lst_diagonal(I1,NbDiag,LD).
fill_lst_diagonal([],_,_,_,LD,LD).
fill_lst_diagonal([L|A],I,NL,NC,LD,LD2):-
I1 is I+1,
fill_lst_diagonal(A,I1,NL,NC,LD,LD1),
one_list(L,I,NL,0,NC,LD1,LD2).
one_list([],_,_,_,_,LD,LD).
one_list([X|L],I,NL,J,NC,LD,LD3):-
J1 is J+1,
one_list(L,I,NL,J1,NC,LD,LD1),
NoDiag1 is I+J,
NoDiag2 is I+NC-J+NL+NC-2,
add_in_lst_diagonal(0,NoDiag1,X,LD1,LD2),
add_in_lst_diagonal(0,NoDiag2,X,LD2,LD3).
add_in_lst_diagonal(NoDiag,NoDiag,X,[D|LD],[[X|D]|LD]).
add_in_lst_diagonal(K,NoDiag,X,[D|LD],[D|LD1]):-
K1 is K+1,
add_in_lst_diagonal(K1,NoDiag,X,LD,LD1).
array_prog(only1,L):- !,
only_one(L).
array_prog(atmost1,L):- !,
at_most_one(L).
array_labeling([]).
array_labeling([L|A]):-
label_bool(L),
array_labeling(A).
%--- end ---

63
CHR/chr/examples/examples-fourier.math
View File

@ -1,63 +0,0 @@
% fourier.chr EXAMPLES ------------------------------------------------------
% adapted for CHRs by Thom Fruehwirth 1993
eg([X,Z,Y,SA,SB,SD,SC,SE,SF,SG,SH,SK,End]):-
{
Y=:=SA,
SB =:= SA + 7,
SD =:= SA + 7,
SC =:= SB + 3,
SC>=SB+3,
SE =:= SD + 8,
SG>=SC+1,
SG =:= SD + 8,
SF =:= SD + 8,
SF>=SC+1,
SH >= SF + 1,
SJ =:= SH + 3,
SK>=SG+1,
SK>=SE+2,
SK =:= SJ + 2,
End =:= SK + 1,
3*X+2*Y-4*(3+Z)=:=2*(X-3)+(Y+Z)*7,
2*(X+Y+Z)=:=3*(X-Y-Z),
5*(X+Y)-7*X-Z >= (2+1+X)*6,
2*(X-Y+Z)=:=Y+X-7,
SH-SC+X+Z=:=0
}.
%L = [-5, -1, 0, 0, 7, 7, 10, 15, 15, 15, 16, 21, 22]
/*
%I1=3,I2=2,I3=3,I4=0,I5=4,I6=2,I7=5,I8=0,I9=3,I10=5,I11=(-2),I12=3,I13=4,I14=3,
I8+I7+I6+I5+I4+I3+I2+6=:=22, I9+I8+I7+I6+I5+I4+I3+I2+6=:=25,
I1=:=3, I2>=2, I3>=3, I4+I3+I2+1>=4, I5+I4+1>=5,
I6+I5+1>=7, I6>=2, I7>=5, I10+I9+1>=2, I11+I10+1>=4,
I12+I11+2=<3, I12+1=<4, I12+I11+1>=2, I12>=3, I13>=4,
I14>=3, I14+I13+I12+I11+4=<22, I14+I13+I12+I11+3=<25,
I14+I13+I12+I11+I10+I9+7>=23, I14+I13+I12+I11+I10+6>=26. % should be 19
X>2,X>=3.
X>=2,X>2.
X>2,X>=2.
X+Y>=2,Y-X>=1,3>=Y.
X+2*Y=<3,-X-Y=<1.
*/

145
CHR/chr/examples/examples-holzbaur.math
View File

@ -1,145 +0,0 @@
% From Christian Holzbaur Tue, 14 Jul 1992 14:49:16 +0200
% adapted by Thom Fruehwirth for CHRs
/*
With the mortgage definition
*/
mg1(P,T,I,B,MP):-
T=:=1,
B + MP =:= P * (1 + I).
mg1(P,T,I,B,MP):-
T >= 2,
T1 =:= T-1,
mg1(P * (1 + I) - MP, T1, I, B, MP).
mg2(P,T,I,B,MP):-
T > 0,
T =< 1,
B + MP = P * (1 + I).
mg2(P,T,I,B,MP):-
T > 1,
mg2(P * (1 + I) - MP, T - 1, I, B, MP).
/*
and the queries
:- mg(P,120,0.01,B,MP).
:- mg(P, 5, Int, B, MP).
*/
example( [X0,X1,X2,X3,X4]) :-
+87*X0 +52*X1 +27*X2 -54*X3 +56*X4 =< -93,
+33*X0 -10*X1 +61*X2 -28*X3 -29*X4 =< 63,
-68*X0 +8*X1 +35*X2 +68*X3 +35*X4 =< -85,
+90*X0 +60*X1 -76*X2 -53*X3 +24*X4 =< -68,
-95*X0 -10*X1 +64*X2 +76*X3 -24*X4 =< 33,
+43*X0 -22*X1 +67*X2 -68*X3 -92*X4 =< -97,
+39*X0 +7*X1 +62*X2 +54*X3 -26*X4 =< -27,
+48*X0 -13*X1 +7*X2 -61*X3 -59*X4 =< -2,
+49*X0 -23*X1 -31*X2 -76*X3 +27*X4 =< 3,
-50*X0 +58*X1 -1*X2 +57*X3 +20*X4 =< 6,
-13*X0 -63*X1 +81*X2 -3*X3 +70*X4 =< 64,
+20*X0 +67*X1 -23*X2 -41*X3 -66*X4 =< 52,
-81*X0 -44*X1 +19*X2 -22*X3 -73*X4 =< -17,
-43*X0 -9*X1 +14*X2 +27*X3 +40*X4 =< 39,
+16*X0 +83*X1 +89*X2 +25*X3 +55*X4 =< 36,
+2*X0 +40*X1 +65*X2 +59*X3 -32*X4 =< 13,
-65*X0 -11*X1 +10*X2 -13*X3 +91*X4 =< 49,
+93*X0 -73*X1 +91*X2 -1*X3 +23*X4 =< -87.
top2 :- example( [X0,X1,X2,X3,X4]).
% X3=<-5/4-35/68*X2-2/17*X1+X0-35/68*X4,
% X3>=68/53-76/53*X2+60/53*X1+90/53*X0+24/53*X4,
% X3=<-1/2-31/27*X2-7/54*X1-13/18*X0+13/27*X4,
% X3>=17/22+19/22*X2-2*X1-81/22*X0-73/22*X4,
% X3=<33/76-16/19*X2+5/38*X1+5/4*X0+6/19*X4,
% X3>=87+91*X2-73*X1+93*X0+23*X4,
% X3>=-3/76-31/76*X2-23/76*X1+49/76*X0+27/76*X4,
% X3=<13/9-14/27*X2+1/3*X1+43/27*X0-40/27*X4,
% X3=<2/19+1/57*X2-58/57*X1+50/57*X0-20/57*X4
top3 :- example( [X0,_,_,_,X4]).
% X0>=477804/40409+6973307/969816*X4,
% X0>=7357764/4517605-5006476/13552815*X4,
% X0>=58416/36205-4659804/12418315*X4,
% X0>=3139326/1972045-745308/1972045*X4,
% X0>=67158/43105-16394/43105*X4,
% X0>=1327097/6210451-2619277/6210451*X4,
% X0=<-688135/1217232-2174029/811488*X4
% Detection of Implied Equalities
top4 :- A=<B,
B=<C,
C=<D,
A>=D.
% B =:= A,
% C =:= A,
% D =:= A
top5 :-
X11 + X12 + X13 + X14 + X15 =:= 1000,
X21 + X22 + X23 + X24 + X25 =:= 1000,
4*X11 + 5*X21 - Y21 - Z21 =< 0,
-4*X12 - 5*X22 + Y22 + Z22 =:= 0,
-4*X13 - 5*X23 + Y24 - Y25 + Z24 - Z25 =:= 0,
-4*X14 - 5*X24 + Y21 - Y22 - Y23 + Y25
+ Z21 - Z22 - Z23 + Z25 =:= 0,
-4*X15 - 5*X25 + Y23 - Y24 + Z23 - Z24 =:= 0,
7*X11 + 9*X21 >= 0,
7*X12 + 9*X22 =< 3000,
7*X13 + 9*X23 =< 200,
7*X14 + 9*X24 =< 10000,
7*X15 + 9*X25 =< 7000,
Z21 =< 5000,
Z22 =< 250,
Z23 =< 600,
Z24 =< 7000,
Z25 =< 4000,
X11 >= 0, X12 >= 0, X13 >= 0, X14 >= 0, X15 >= 0,
X21 >= 0, X22 >= 0, X23 >= 0, X24 >= 0, X25 >= 0,
Y21 >= 0, Y22 >= 0, Y23 >= 0, Y24 >= 0, Y25 >= 0,
Z21 >= 0, Z22 >= 0, Z23 >= 0, Z24 >= 0, Z25 >= 0,
% should be optimization here:
M =:= 99999,
- Min =:= 99999 * X11 + 99999 * X21 + 4 * Y21 + 7 * Y22 +
3 * Y23 + 8*Y24 + 5*Y25.
% M =:= 99999,
% Min =:= 23450,
% X11 =:= 0,
% X12 =:= 0,
% X13 =:= 0,
% X14 =:= 1000,
% X15 =:= 0,
% X21 =:= 0,
% X22 =:= 50,
% X23 =:= 1850/3-X25,
% X24 =:= 1000/3,
% Y21 =:= 4000,
% Y22 =:= 0,
% Y23 =:= 7450/3,
% Y24 =:= 0,
% Y25 =:= 0,
% Z21 =:= 5000,
% Z22 =:= 250,
% Z23 =:= 600,
% Z24 =:= 9250/3-5*X25,
% Z25 =:= 0,
% X25 >= 5350/9,
% X25 =< 1850/3
%=============================================================================

374
CHR/chr/examples/examples-lim1.math
View File

@ -1,374 +0,0 @@
% From lim@scorpio Thu Jun 17 14:09:28 1993
% adapted for CHRs by thom fruehwirth 930617
% replaced $= by =:= and then removed '$'
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Rational Constraint Solver Source Module
%
% sccsid("@(#)data 1.00 92/06/29").
% sccscr("@(#) Copyright 1992 ECRC GmbH ").
%
% IDENTIFICATION: examples
%
% AUTHOR: Pierre Lim
%
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% X + Y =:= 4
% X - Y =:= 0
% Answer:
%
% X =:= 2, Y =:= 2
%
X + Y =:= 4,
X - Y =:= 0.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%-8x + 5y + -1z =:= 18,
%x + -11z + -5y =:= 6,
%-1x + 5y + 5z =:= 0.
% Answer:
%
% x =:= -12/7, y =:= 23/35, z =:= -1
-8 * X + 5 * Y - Z =:= 18,
X - 11 * Z - 5 * Y =:= 6,
-X + 5 * Y + 5 * Z =:= 0.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%-11z + -5y + x =:= -6,
%5z + -1x + 5y =:= 0.
%
% Answer:
%
% z =:= 1, x =:= 5 * Y + 5, y =:= (unconstrained)
%
% Notes:
% CLP(R) compiler
%
% Y =:= 0.2*X - 1
% Z =:= 1
%
% CHIP compiler
% Z =:= (1)
% X =:= (5) + (5) * _r80
% Y =:= _r80
%
% My rational constraint solver produces
% Z =:= 1
% X =:= 5 * _m277 + 5
% Y =:= 1 * _m277
%
%
-11*Z - 5*Y + X =:= -6,
5*Z - X + 5*Y =:= 0.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% X + -5*Y + -11 * Z =:= -6,
% -X + 5* Z + 5* Y =:= 0,
% X + 2* Z + -3* Y =:= 7,
% 8*X + Z + -5*Y + P =:= 18.
%
% Answer: z =:= 1.0, x =:= 5.0, y =:= 0.0, p =:= -23
%
X - 5*Y - 11 * Z =:= -6,
-X + 5* Z + 5* Y =:= 0,
X + 2* Z - 3* Y =:= 7,
8*X + Z - 5*Y + P =:= 18.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%-8x + -1z + 5y =:= -18,
%x + -5y + -11z =:= -6,
%-x + 5z + y =:= 0,
%x + 2z + -3y =:= 7.
%
% Answer inconsistent
%
-8*X + -1*Z + 5*Y =:= -18,
X + -5*Y + -11*Z =:= -6,
-X + 5*Z + Y =:= 0,
X + 2*Z + -3*Y =:= 7.
%
% 0 =< X, X =< 10.
%
0 =< X, X =< 10, X =:= 11. % inconsistent
0 =< X, X =< 10, X =:= 1. % X =:= 1
X =:= (1/2)/(1/2). % X =:= 1
%
% Inequality example 1
/*
X1 + X2 >= 2,
-X1 + X2 >= 1,
X2 =< 3,
X1 >= 0,
X2 >= 0.
*/
%
%
% CHIP compiler
%
% X1 =:= (1/2) + (-1/2) * _rp105 + (1/2) * _rp78
% X2 =:= (3/2) + (1/2) * _rp105 + (1/2) * _rp78
%
%
X1 + X2 >= 2,
-X1 + X2 >= 1,
X2 =< 3,
X1 >= 0,
X2 >= 0.
% print_store.
%
%
% Answer: X =:= 5
%
X >= 5,
X =< 5.
%
% x1 + x2 =< 4,
% 2x1 + 3x2 >= 18,
% x1 >= 0,
% x2 >= 0.
%
% Answer: inconsistent
X1 + X2 =< 4,
2 * X1 + 3 * X2 >= 18,
X1 >= 0,
X2 >= 0.
%
%
/*
X1 =< 50,
X2 =< 200,
X1 + 0.2 * X2 =< 72,
150 * X1 + 25 * X2 =< 10000,
Z =:= 250 * X1 + 45 * X2.
*/
%
%
% Answer: CLP(R) compiler
%
% X1 =:= 0.004*Z - 0.18*X2
% Z =< 3.33333*X2 + 16666.7
% Z + 5*X2 =< 18000
% X2 =< 200
% Z =< 45*X2 + 12500
%
% Answer: CHIP compiler
%
% Z =:= (17000) + (-9/5) * _rp161 + (20) * _rp101
% X1 =:= (50) + (-1) * _rp101
% X2 =:= (100) + (-1/25) * _rp161 + (6) * _rp101
%
% First 3 constraints
% X1 =:= (50) + (-1) * _rp67
% X2 =:= (110) + (-5) * _rp105 + (5) * _rp67
%
X1 =< 50,
X2 =< 200,
X1 + 2/10 * X2 =< 72,
150 * X1 + 25 * X2 =< 10000,
Z =:= 250 * X1 + 45 * X2.
%,output.
/*
Eclipse input:
X1 =< 50,
X2 =< 200,
X1 + 2/10 * X2 =< 72,
150 * X1 + 25 * X2 =< 10000,
Z =:= 250 * X1 + 45 * X2.
*/
%
%
% X4 =< 1 + 3 * X3,
% X4 =< 4/13+18/13*X3,
% X4 >= -1/8+9/8*X3,
% X4 >= -2+6*X3,
% X4 >= -1/11+9/11*X3
/*
X4 - 3 * X3 =< 1,
X4 - 1.38462 * X3 =< 0.307692,
X4 - 1.125 * X3 >= -0.125,
X4 - 6 * X3 >= -2,
X4 - 0.818182 * X3 >= -0.0909091.
X4 - 3 * X3 =< 1,
X4 - 18/13 * X3 =< 4/13,
X4 - 9/8 * X3 >= -1/8,
X4 - 6 * X3 >= -2,
X4 - 9/11 * X3 >= -1/11.
*/
%
% CHIP Compiler
% X4 =:= (-2/7) + (-13/7) * _rp145 + (6/7) * _rp118
% X3 =:= (-3/7) + (-13/21) * _rp145 + (13/21) * _rp118
%
% CLP(R) Compiler
%
% 0.818182*X3 =< X4 + 0.0909091
% 6*X3 =< X4 + 2
% 1.125*X3 =< X4 + 0.125
% X4 =< 1.38462*X3 + 0.307692
% X4 =< 3*X3 + 1
%
%
X4 =< 1+3*X3,
X4 =< 4/13+18/13*X3,
X4 >= -1/8+9/8*X3,
X4 >= -2+6*X3,
X4 >= -1/11+9/11*X3.
%
%
%
% CHIP Compiler
%
% X3 =:= (1/9) * _rp256 + (5/6) * _rp229 + (-4/9) * _rp202 + (-1/2) * _rp159
% X4 =:= (2/3) * _rp229 + (-1/3) * _rp202
% X1 =:= (1/9) * _rp256 + (1/3) * _rp229 + (-1/9) * _rp202 + (-1/3) * _rp159
% X2 =:= (1) + (-1) * _rp256 + (-13/6) * _rp229 + (1/3) * _rp202 +
% (3/2) * _rp159
%
%
%example([X1,X2,X3,X4]) :-
12*X1 + X2 - 3*X3 + X4 =< 1,
-36*X1 - 2*X2 + 18*X3 - 11*X4 =< -2,
-18*X1 - X2 + 9*X3 - 7*X4 =< -1,
45*X1 + 4*X2 - 18*X3 + 13*X4 =< 4,
X1 >= 0,
X2 >= 0.
%
%
% Small Scheduling Problem
% CHIP Compiler
%
% SA =:= (-7) + (1) * _r218 + (-1) * _rp211
% SB =:= _r218
% SD =:= (1) * _r218 + (1) * _rp238 + (-1) * _rp211
% SC =:= (3) + (1) * _r218 + (1) * _rp264
% SF =:= (8) + (1) * _r218 + (1) * _rp407 + (1) * _rp238 + (-1) * _rp211
% SH =:= (9) + (1) * _r218 + (1) * _rp471 + (1) * _rp407 + (1) * _rp238 +
% (-1) * _rp211
% SG =:= (8) + (1) * _r218 + (1) * _rp374 + (1) * _rp238 + (-1) * _rp211
% SE =:= (8) + (1) * _r218 + (1) * _rp314 + (1) * _rp238 + (-1) * _rp211
% SJ =:= (12) + (1) * _r218 + (1) * _rp506 + (1) * _rp471 + (1) * _rp407 +
% (1) * _rp238 + (-1) * _rp211
% Send =:= (15) + (1) * _r218 + (1) * _rp674 + (1) * _rp607 + (1) * _rp506 +
% (1) * _rp471 + (1) * _rp407 + (1) * _rp238 + (-1) * _rp211
% SK =:= (14) + (1) * _r218 + (1) * _rp607 + (1) * _rp506 + (1) * _rp471 +
% (1) * _rp407 + (1) * _rp238 + (-1) * _rp211
%
%
SB >= SA + 7,
SD >= SA + 7,
SC >= SB + 3,
SE >= SC + 1,
SE >= SD + 8,
SG >= SC + 1,
SG >= SD + 8,
SF >= SD + 8,
SF >= SC + 1,
SH >= SF + 1,
SJ >= SH + 3,
SK >= SG + 1,
SK >= SE + 2,
SK >= SJ + 2,
Send >= SK + 1.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Example from paper by De Backer and Beringer
% ``A CLP language handling disjunctions of linear constraints''
%
% ConstrainedMin[ x, {3x -2y =< 4, 3x+2y =< 28, 5 =< y},{x,y}]
% {0, {x -> 0, y -> 5}}
% ConstrainedMax[ x, {3x -2y =< 4, 3x+2y =< 28, 5 =< y},{x,y}]
% 16 16
% {--, {x -> --, y -> 6}}
% 3 3
% ConstrainedMin[y, {3x -2y =< 4, 3x+2y =< 28, 5 =< y},{x,y}]
% 14
% {5, {x -> --, y -> 5}}
% 3
% ConstrainedMax[ y, {3x -2y =< 4, 3x+2y =< 28, 5 =< y},{x,y}]
% {14, {x -> 0, y -> 14}}
3*X - 2*Y =< -4, 3*X + 2*Y =< 28, 5 =< Y. %, rmax(X).
%3*X - 2*Y >= -4, 3*X + 2*Y =< 28, 5 =< Y.%, rmin(X).
%3*X - 2*Y =< -4, 3*X + 2*Y =< 28, 5 =< Y.%, rmax(Y).
%3*X - 2*Y =< -4, 3*X + 2*Y =< 28, 5 =< Y.%, rmin(Y).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X11 + X12 + X13 + X14 + X15 =:= 1000,
X21 + X22 + X23 + X24 + X25 =:= 1000,
4*X11 + 5*X21 - Y21 - Z21 =< 0,
-4*X12 - 5*X22 + Y22 + Z22 =:= 0,
-4*X13 - 5*X23 + Y24 - Y25 + Z24 - Z25 =:= 0,
Y21 + Z21 =:= 0.
X1>=0,%positive(X1),
X2>=0,%positive(X2),
Y1>=0,%positive(Y1),
Y2>=0,%positive(Y2),
Y1 =:= X1 - X2,
Y2 =:= X2 - X1.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
U1-Z+W =:= 0,
U2 +Z-V =:= 0,
U3 -W + V =:= 0,
U1 >=0,
U2 >= 0,
U3 >= 0,
Z >= 0,
V >= 0,
W >= 0.
U1-Z+2*W =:= 0,
U2 +2*Z-V =:= 0,
U3-W+2*V =:= 0,
U1 >= 0,
U2 >= 0,
U3 >= 0,
Z >= 0,
V >= 0,
W >= 0.
X + 2*Z >=0,
-Z +Y >= 1,
-Y >= 2.

448
CHR/chr/examples/examples-lim2.math
View File

@ -1,448 +0,0 @@
% From lim@scorpio Thu Jun 17 14:09:36 1993
% adapted for CHRs by thom fruehwirth 930617
% fourier very slow, maybe loops with beale/1, opt1/1 loops, opt2/1 works
rmin(E):- M=:=E. % thom: no optimisation
rmax(E):- (-M)=:=E. % thom: no optimisation
%
beale([X1,X2,X3,X4,X5,X6,X7]) :-
X1 + 1/4 * X4 - 8 * X5 - X6 + 9 * X7 =:= 0,
X2 + 1/2 * X4 - 12 * X5 - 1/2 * X6 + 3 * X7 =:= 0,
X3 + X6 =:= 1,
X1 >= 0,
X2 >= 0,
X3 >= 0,
X4 >= 0,
X5 >= 0,
X6 >= 0,
X7 >= 0,
rmin( - 3/4 * X4 + 20 * X5 - 1/2 * X6 + 6* X7).
% topb(L,n)
topb(L,N) :-
topb1([],L,0,N).
topb1(Li,Li,I,I) :- !.
topb1(Li,Lo,I,N) :-
insertb(P,Li,Lt),
J is I+1,
putcons(Lt,1,J),
topb1(Lt,Lo,J,N).
insertb(P,[],[P]).
insertb(P,[A|B],[P,A|B]).
insertb(P,[A|B],[A|C]) :-
insertb(P,B,C).
putcons(_,M,N) :-
M > N,
!.
putcons([P|R],M,N) :-
M0 is M - 1,
% bwriteln(P > M0/N),
% bwriteln(P < M/N),
P > M0/N,
P < M/N,
M1 is M + 1,
putcons(R,M1,N).
bwriteln(X) :-
writeln(X).
bwriteln(X) :-
writeln(delete(X)).
% may loop
fib(0,1).
fib(1,1).
fib(N,Z) :-
Z =:= X1 + X2,
N1 =:= N-1,
N2 =:= N-2,
fib(N1,X1),
fib(N2,X2).
laplace([_, _]) :- !.
laplace([H1, H2, H3|T]):-
laplace_vec(H1, H2, H3),
laplace([H2, H3|T]).
laplace_vec([_, _], [_, _], [_, _]) :- !.
laplace_vec([_TL, T, TR|T1], [ML, M, MR|T2], [_BL, B, BR|T3]):-
B + T + ML + MR - 4 * M =:= 0,
laplace_vec([T, TR|T1], [M, MR|T2], [B, BR|T3]).
%
laplace5(M) :-
M = [
[0,0,0,0,0],
[100,R,S,T,100],
[100,U,V,W,100],
[100,X,Y,Z,100],
[100,100,100,100,100]
],
laplace(M).
% [chipc]: laplace7(X).
%
% X = [[0, 0, 0, 0, 0, 0, 0], [100, (5260/99), (63625/1716), (42545/1287), (63625/1716), (5260/99), 100], [100, (388405/5148), (2050/33), (149485/2574), (2050/33), (388405/5148), 100], [100, (1125/13), (2025/26), (75), (2025/26), (1125/13), 100], [100, (477845/5148), (2900/33), (221765/2574), (2900/33), (477845/5148), 100], [100, (9590/99), (162425/1716), (120805/1287), (162425/1716), (9590/99), 100], [100, 100, 100, 100, 100, 100, 100]]
%
laplace7(M) :-
M = [
[0,0,0,0,0,0,0],
[100,R11,R12,R13,R14,R15,100],
[100,R21,R22,R23,R24,R25,100],
[100,R31,R32,R33,R34,R35,100],
[100,R41,R42,R43,R44,R45,100],
[100,R51,R52,R53,R54,R55,100],
[100,100,100,100,100,100,100]
],
laplace(M).
% [chipc]: chipOpt(X,Y,Z).
%
% X = (8/5)
% Y = (6/5)
% Z = (14/5)
%
chipOpt(X1,X2,X3) :-
X1 + 2 * X2 =< 4,
3 * X1 + X2 =< 6,
X3 =:= X1 + X2,
rmax(X3).
% chipfact(n,1,N)
chipfact(X,Y,M) :-
X =:= 0,
!,
Y =:= M.
chipfact(X,Y,M) :-
X1 =:= X - 1,
M1 =:= X * Y,
chipfact(X1,M1,M).
% order of magnitude slower than chipfact/3
fact(0,1).
fact(1,1).
fact(N,R) :- 1 < N, N =< R, M =:= N-1, fact(M,T), R =:= N * T.
%
mg(P,T,I,B,MP):-
T > 0,
T =< 1,
B + MP =:= P * (1 + I/100).
mg(P,T,I,B,MP):-
T > 1,
I1 =:= I / 100,
T1 =:= T -1,
P2 =:= P * (1 + I1) - MP,
mg(P2, T1, I, B, MP).
mg1(X,Y,Z) :-
2 =:= T,
1 =:= I,
T > 1,
I1 =:= I / 100,
T1 =:= T -1,
P2 =:= P * (1 + I1) - MP,
T1 > 0,
T1 =< 1,
B + MP =:= P2 * (1 + I/100).
% [chipc]: top0(X,Y,Z).
%
% X = _r94
% Y = (-9462212541120451001/1000000000000000000) * _r94 + (10462212541120451001/1000000000000000000) * _r90
% Z = (101/100) * _r94 + (-1) * _r90 More? (;)
%
% ---------------------------------------------------------
% [chipc]: top1(X,Y,Z).
%
% X = _r94
% Y = (-101/100) * _r94 + (201/100) * _r90
% Z = (101/100) * _r94 + (-1) * _r90 More? (;)
% ---------------------------------------------------------
% [chipc]: top(X,Y,Z).
%
% X = _r94
% Y = (-2101900399479668244827490915525641902001/100000000000000000000000000000000000000) * _r94 + (2201900399479668244827490915525641902001/100000000000000000000000000000000000000) * _r90
% Z = (101/100) * _r94 + (-1) * _r90 More? (;)
%
%
top0(P, B, MP) :- mg(P,10,1,B,MP).
top1(P, B, MP) :- mg(P,2,1,B,MP).
top(P, B, MP) :- mg(P,20,1,B,MP).
% Detection of Implied Equalities -------------------------------------------
%
top4([A,B,C,D]) :-
A=<B,
B=<C,
C=<D,
A>=D.
% B = A,
% C = A,
% D = A
/*
L = [A_m108, B_m128, C_m336, D_m660]
Constraints:
eq0([B_m128 * 1, D_m660 * -1], 0)
eq0([C_m336 * 1, D_m660 * -1], 0)
eq0([A_m108 * -1, D_m660 * 1], 0)
*/
%
% X = [(1/3), (0), (13/3)]
%
%
opt1([X1,X2,X3]) :-
X1 + X2 + 2 * X3 =< 9,
X1 + X2 - X3 =< 2,
-X1 + X2 + X3 =< 4,
X1 >= 0,
X2 >= 0,
X3 >= 0,
rmin(X1 + X2 - 4 * X3).
%
% X = [(0), (0)]
%
%
opt2([X1,X2]) :-
X1 + 2 * X2 =< 4,
X2 =< 1,
X1 >= 0,
X2 >= 0,
rmin(X1 + X2).
available_res(10).
available_res(14).
available_res(27).
available_res(60).
available_res(100).
available_cell(10).
available_cell(20).
ohm(V,I,R) :-
% bwriteln(V =:= I * R),
V =:= I * R.
sum([],Z) :-
% bwriteln(Z =:= 0),
Z =:= 0.
sum([H|T],N) :-
% bwriteln(N =:= H + M),
N =:= H + M,
sum(T,M).
kirchoff(L) :-
sum(L,0).
% X = [(200/37), (540/37)] More? (;)
%
% X = [(140/37), (600/37)] More? (;)
%
% X = [(540/127), (2000/127)] More? (;)
%
ohm_example([V1,V2]) :-
29/2 < V2, V2 < 65/4,
available_res(R1),
available_res(R2),
available_cell(V),
ohm(V1,I1,R1), ohm(V2,I2,R2),
kirchoff([I1,-I2]), kirchoff([-V,V1,V2]).
% X = [10, 27, 20] More? (;)
%
% X = [14, 60, 20] More? (;)
%
% X = [27, 100, 20] More? (;)
%
ohm_example1([R1,R2,V]) :-
29/2 < V2, V2 < 65/4,
available_res(R1),
available_res(R2),
available_cell(V),
ohm(V1,I1,R1), ohm(V2,I2,R2),
kirchoff([I1,-I2]), kirchoff([-V,V1,V2]).
%
% X = [(14), (60), (20)]
%
%
ohm1([A,B,C]) :-
A =:= 14,
B =:= 60,
C =:= 20,
29/2 < V2, V2 < 65/4,
V1/A - V2/B =:= 0,
V1 + V2 =:= C.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
example( [X0,X1,X2,X3,X4]) :-
87*X0 +52*X1 +27*X2 -54*X3 +56*X4 =< -93,
33*X0 -10*X1 +61*X2 -28*X3 -29*X4 =< 63,
-68*X0 +8*X1 +35*X2 +68*X3 +35*X4 =< -85,
90*X0 +60*X1 -76*X2 -53*X3 +24*X4 =< -68,
-95*X0 -10*X1 +64*X2 +76*X3 -24*X4 =< 33,
43*X0 -22*X1 +67*X2 -68*X3 -92*X4 =< -97,
39*X0 +7*X1 +62*X2 +54*X3 -26*X4 =< -27,
48*X0 -13*X1 +7*X2 -61*X3 -59*X4 =< -2,
49*X0 -23*X1 -31*X2 -76*X3 +27*X4 =< 3,
-50*X0 +58*X1 -1*X2 +57*X3 +20*X4 =< 6,
-13*X0 -63*X1 +81*X2 -3*X3 +70*X4 =< 64,
20*X0 +67*X1 -23*X2 -41*X3 -66*X4 =< 52,
-81*X0 -44*X1 +19*X2 -22*X3 -73*X4 =< -17,
-43*X0 -9*X1 +14*X2 +27*X3 +40*X4 =< 39,
16*X0 +83*X1 +89*X2 +25*X3 +55*X4 =< 36,
+2*X0 +40*X1 +65*X2 +59*X3 -32*X4 =< 13,
-65*X0 -11*X1 +10*X2 -13*X3 +91*X4 =< 49,
93*X0 -73*X1 +91*X2 -1*X3 +23*X4 =< -87.
top2 :- example( [X0,X1,X2,X3,X4]).
% X3<=-5/4-35/68*X2-2/17*X1+X0-35/68*X4,
% X3<=68/53-76/53*X2+60/53*X1+90/53*X0+24/53*X4,
% X3<=-1/2-31/27*X2-7/54*X1-13/18*X0+13/27*X4,
% X3<=17/22+19/22*X2-2*X1-81/22*X0-73/22*X4,
% X3<=33/76-16/19*X2+5/38*X1+5/4*X0+6/19*X4,
% X3>=87+91*X2-73*X1+93*X0+23*X4,
% X3>=-3/76-31/76*X2-23/76*X1+49/76*X0+27/76*X4,
% X3<=13/9-14/27*X2+1/3*X1+43/27*X0-40/27*X4,
% X3<=2/19+1/57*X2-58/57*X1+50/57*X0-20/57*X4
top3 :- example( [X0,_,_,_,X4]).
% X0>=477804/40409+6973307/969816*X4,
% X0>=7357764/4517605-5006476/13552815*X4,
% X0>=58416/36205-4659804/12418315*X4,
% X0>=3139326/1972045-745308/1972045*X4,
% X0>=67158/43105-16394/43105*X4,
% X0>=1327097/6210451-2619277/6210451*X4,
% X0<=-688135/1217232-2174029/811488*X4
% [chipc]: top5(X).
%
% X = [(0), (0), (0), (1000), (0), (0), (50), (200/9) + (-1/9) * _rp522 , (1000/3), (5350/9) + (1/9) * _rp522 , (4000), (0), (7450/3), (0), (0), (5000), (250), (600), (1000/9) + (-5/9) * _rp522 , (0)]
% yes.
top5([X11,X12,X13,X14,X15,X21,X22,X23,X24,X25,Y21,Y22,Y23,Y24,Y25,Z21,Z22,Z23,Z24,Z25]) :-
X11 + X12 + X13 + X14 + X15 =:= 1000,
X21 + X22 + X23 + X24 + X25 =:= 1000,
4*X11 + 5*X21 - Y21 - Z21 =< 0,
-4*X12 - 5*X22 + Y22 + Z22 =:= 0,
-4*X13 - 5*X23 + Y24 - Y25 + Z24 - Z25 =:= 0,
-4*X14 - 5*X24 + Y21 - Y22 - Y23 + Y25
+ Z21 - Z22 - Z23 + Z25 =:= 0,
-4*X15 - 5*X25 + Y23 - Y24 + Z23 - Z24 =:= 0,
7*X11 + 9*X21 >= 0,
7*X12 + 9*X22 =< 3000,
7*X13 + 9*X23 =< 200,
7*X14 + 9*X24 =< 10000,
7*X15 + 9*X25 =< 7000,
Z21 =< 5000,
Z22 =< 250,
Z23 =< 600,
Z24 =< 7000,
Z25 =< 4000,
X11 >= 0,
X12 >= 0,
X13 >= 0,
X14 >= 0,
X15 >= 0,
X21 >= 0, X22 >= 0, X23 >= 0, X24 >= 0, X25 >= 0,
Y21 >= 0, Y22 >= 0, Y23 >= 0, Y24 >= 0, Y25 >= 0,
Z21 >= 0, Z22 >= 0, Z23 >= 0, Z24 >= 0, Z25 >= 0,
M =:= 99999,
- Min =:= 99999 * X11 + 99999 * X21 + 4 * Y21 + 7 * Y22 +
3 * Y23 + 8*Y24 + 5*Y25,
rmax(Min).
%
top5a(List) :-
List = [X11,X12,X13,X14,X15,X21,X22,X23,X24,X25,Y21,Y22,Y23,Y24,Y25,Z21,Z22,Z23,Z24,Z25],
X11 + X12 + X13 + X14 + X15 =:= 1000,
X21 + X22 + X23 + X24 + X25 =:= 1000,
4*X11 + 5*X21 - Y21 - Z21 =< 0,
-4*X12 - 5*X22 + Y22 + Z22 =:= 0,
-4*X13 - 5*X23 + Y24 - Y25 + Z24 - Z25 =:= 0,
-4*X14 - 5*X24 + Y21 - Y22 - Y23 + Y25
+ Z21 - Z22 - Z23 + Z25 =:= 0,
-4*X15 - 5*X25 + Y23 - Y24 + Z23 - Z24 =:= 0,
7*X11 + 9*X21 >= 0,
7*X12 + 9*X22 =< 3000,
7*X13 + 9*X23 =< 200,
7*X14 + 9*X24 =< 10000,
7*X15 + 9*X25 =< 7000,
Z21 =< 5000,
Z22 =< 250,
Z23 =< 600,
Z24 =< 7000,
Z25 =< 4000,
X11 >= 0,
X12 >= 0,
X13 >= 0,
X14 >= 0,
X15 >= 0,
X21 >= 0, X22 >= 0, X23 >= 0, X24 >= 0, X25 >= 0,
Y21 >= 0, Y22 >= 0, Y23 >= 0, Y24 >= 0, Y25 >= 0,
Z21 >= 0, Z22 >= 0, Z23 >= 0, Z24 >= 0, Z25 >= 0,
M =:= 99999,
Min = 23450,
- Min =:= 99999 * X11 + 99999 * X21 + 4 * Y21 + 7 * Y22 +
3 * Y23 + 8*Y24 + 5*Y25.
% M = 99999,
% Min = 23450,
% X11 = 0,
% X12 = 0,
% X13 = 0,
% X14 = 1000,
% X15 = 0,
% X21 = 0,
% X22 = 50,
% X23 = 1850/3-X25,
% X24 = 1000/3,
% Y21 = 4000,
% Y22 = 0,
% Y23 = 7450/3,
% Y24 = 0,
% Y25 = 0,
% Z21 = 5000,
% Z22 = 250,
% Z23 = 600,
% Z24 = 9250/3-5*X25,
% Z25 = 0,
% X25>=5350/9,
% X25<=1850/3
% ===========================================================================

80
CHR/chr/examples/examples-lim3.math
View File

@ -1,80 +0,0 @@
%From lim@scorpio Tue Mar 8 10:11:36 1994
% adapted by Thom Fruehwirth for CHRs 930308
% *************************************
% CLP(R) Version 1.1 - Example Programs
% *************************************
%
% Algebraic combinations of options transactions
% heaviside function
h(X, Y, Z) :- Y < X, Z =:= 0.
h(X, Y, Z) :- Y >= X, Z =:= 1.
% ramp function
r(X, Y, Z) :- Y < X , Z =:= 0.
r(X, Y, Z) :- Y >= X, Z =:= Y - X.
% option valuation
value(Type,Buy_or_Sell,S,C,P,I,X,B,Value) :-
check_param(S,C,P,I,X,B),
get_sign(Buy_or_Sell,Sign),
lookup_option(Type,S,C,P,I,X,B,
B1,B2,H1,H2,R1,R2),
h(B1,S,T1),h(B2,S,T2),r(B1,S,T3),r(B2,S,T4),
Value =:= Sign*(H1*T1 + H2*T2 + R1*T3 + R2*T4).
% safety check
check_param(S,C,P,I,X,B) :-
S >= 0, C >= 0, P >= 0,
I >= 0, X >= 0, B >= 0 .
% Buy or sell are just opposite
get_sign(buy,S) :- S =:= -1.
get_sign(sell,S) :- S =:= 1.
% lookup option vector
lookup_option(Type,S,C,P,I,X,B,B1,B2,H1,H2,R1,R2) :-
table(Type,S,C,P,I,X,B,B1,B2,H1,H2,R1,R2).
% Table of values for B1,B2,H1,H2,R1,R2
% generic format - lookup_table(Type,Pos_neg,S,C,P,I,X,B,B1,B2,H1,H2,R1,R2).
% where K to R21 are obtained from the table
% M is a multiplier which is -1 or 1 depending on whether one
% is buying or selling the option
table( stock, S, C, P, I, X, B, 0, 0, S*(1+I), 0, -1, 0).
table( call, S, C, P, I, X, B, 0, X, C*(1+I), 0, 0, -1).
table( put, S, C, P, I, X, B, 0, X, P*(1+I)-X, 0, 1, -1).
table( bond, S, C, P, I, X, B, 0, 0, B*(1+I), 0, 0, 0).
solve1(Wealth, Stockprice) :-
Wealth =:= Wealth1 + Wealth2,
X =:= 99,
P =:= 10, C =:= 10,
I =:= 0,
value(put, buy, Stockprice, _, P, I, X, _, Wealth1),
value(call, buy, Stockprice, C, _, I, X, _, Wealth2).
% dump([Stockprice, Wealth]).
solve2(Wealth, Stockprice) :-
I =:= 0.1, P1 =:= 10, X1 =:= 20,
value(put, sell, Stockprice, _, P1, I, X1, _, Wealth1),
P2 =:= 18, X2 =:= 40,
value(put, buy, Stockprice, _, P2, I, X2, _, Wealth2),
C3 =:= 15, X3 =:= 60,
value(call, buy, Stockprice, C3, _, I, X3, _, Wealth3),
C4 =:= 10, X4 =:= 80,
value(call, sell, Stockprice, C4, _, I, X4, _, Wealth4),
Wealth =:= Wealth1 + Wealth2 + Wealth3 + Wealth4.
% dump([Stockprice, Wealth]).
go1 :- solve1(Wealth, Stockprice), fail.
go1.
go2 :- solve2(Wealth, Stockprice), fail.
go2.
?- printf("\n>>> Sample goals: go1/0, go2/0\n", []).
%=============================================================================

150
CHR/chr/examples/examples-puzzle.bool
View File

@ -1,150 +0,0 @@
/*
Article: 5653 of comp.lang.prolog
Newsgroups: comp.lang.prolog
Path: ecrc!Germany.EU.net!mcsun!ub4b!news.cs.kuleuven.ac.be!bimbart
From: bimbart@cs.kuleuven.ac.be (Bart Demoen)
Subject: boolean constraint solvers
Message-ID: <1992Oct19.093131.11399@cs.kuleuven.ac.be>
Sender: news@cs.kuleuven.ac.be
Nntp-Posting-Host: hera.cs.kuleuven.ac.be
Organization: Dept. Computerwetenschappen K.U.Leuven
Date: Mon, 19 Oct 1992 09:31:31 GMT
Lines: 120
?- calc_constr(N,C,L) . % with N instantiated to a positive integer
generates in the variable C a datastructure that can be interpreted as a
boolean expression (and in fact is so by SICStus Prolog's bool:sat) and in L
the list of variables involved in this boolean expression; so
?- calc_constr(N,C,L) , bool:sat(C) , bool:labeling(L) .
% with N instantiated to a positive integer
shows the instantiations of L for which the boolean expression is true
e.g.
| ?- calc_constr(3,C,L) , bool:sat(C) , bool:labeling(L) .
% C = omitted
L = [1,0,1,0,1,0,1,0,1] ? ;
no
it is related to a puzzle which I can describe if people are interested
SICStus Prolog can solve this puzzle up to N = 9 on my machine; it then
fails because of lack of memory (my machine has relatively little: for N=9
SICStus needs 14 Mb - and about 50 secs runtime + 20 secs for gc on Sparc 1)
I am interested in hearing about boolean constraint solvers that can deal with
the expression generated by the program below, for large N and in reasonable
time and space; say N in the range 10 to 20: the number of solutions for
different N varies wildly; there is exactly one solution for N = 10,12,13,15,20
but for N=18 or 19 there are several thousand, so perhaps it is best to
restrict attention to N with only one solution - unless that is unfair to your
solver
in case you have to adapt the expression for your own boolean solver, in
the expression generated, ~ means negation, + means disjunction,
* means conjunction and somewhere in the program, 1 means true
Thanks
Bart Demoen
*/
% test(N,L) :- calc_constr(N,C,L) , bool:sat(C) , bool:labeling(L) .
test(N,L) :- calc_constr(N,C,L) , solve_bool(C,1).
testbl(N,L) :- calc_constr(N,C,L) , solve_bool(C,1), labeling.
testul(N,L) :- calc_constr(N,C,L) , solve_bool(C,1), label_bool(L).
calc_constr(N,C,L) :-
M is N * N ,
functor(B,b,M) ,
B =.. [_|L] ,
cc(N,N,N,B,C,1) .
cc(0,M,N,B,C,T) :- ! ,
NewM is M - 1 ,
cc(N,NewM,N,B,C,T) .
cc(_,0,_,B,C,C) :- ! .
cc(I,J,N,B,C,T) :-
neighbours(I,J,N,B,C,S) ,
NewI is I - 1 ,
cc(NewI,J,N,B,S,T) .
neighbours(I,J,N,B,C,S) :-
add(I,J,N,B,L,R1) ,
add(I-1,J,N,B,R1,R2) ,
add(I+1,J,N,B,R2,R3) ,
add(I,J-1,N,B,R3,R4) ,
add(I,J+1,N,B,R4,[]) , % L is the list of neighbours of (I,J)
% including (I,J)
odd(L,C,S) .
add(I,J,N,B,S,S) :- I =:= 0 , ! .
add(I,J,N,B,S,S) :- J =:= 0 , ! .
add(I,J,N,B,S,S) :- I > N , ! .
add(I,J,N,B,S,S) :- J > N , ! .
add(I,J,N,B,[X|S],S) :- A is (I-1) * N + J , arg(A,B,X) .
% odd/2 generates the constraint that an odd number of elements of its first
% argument must be 1, the rest must be 0
odd(L,C*S,S):- exors(L,C).
exors([X],X).
exors([X|L],X#R):- L=[_|_],
exors(L,R).
/*
% did this by enumeration, because there are only 4 possibilities
odd([A], A * S,S) :- ! .
odd([A,B,C], ((A * ~~(B) * ~~(C)) +
(A * B * C) +
( ~~(A) * B * ~~(C)) +
( ~~(A) * ~~(B) * C)) * S,S)
:- ! .
odd([A,B,C,D], ((A * ~~(B) * ~~(C) * ~~(D)) +
(A * B * C * ~~(D)) +
(A * B * ~~(C) * D) +
(A * ~~(B) * C * D) +
( ~~(A) * B * ~~(C) * ~~(D)) +
( ~~(A) * B * C * D) +
( ~~(A) * ~~(B) * C * ~~(D)) +
( ~~(A) * ~~(B) * ~~(C) * D)) * S,S )
:- ! .
odd([A,B,C,D,E],((A * ~~(B) * ~~(C) * ~~(D) * ~~(E)) +
(A * B * C * ~~(D) * ~~(E)) +
(A * B * ~~(C) * D * ~~(E)) +
(A * ~~(B) * C * D * ~~(E)) +
(A * B * ~~(C) * ~~(D) * E) +
(A * ~~(B) * C * ~~(D) * E) +
(A * ~~(B) * ~~(C) * D * E) +
(A * B * C * D * E) +
( ~~(A) * B * ~~(C) * ~~(D) * ~~(E)) +
( ~~(A) * B * ~~(C) * D * E) +
( ~~(A) * B * C * ~~(D) * E) +
( ~~(A) * B * C * D * ~~(E)) +
( ~~(A) * ~~(B) * C * ~~(D) * ~~(E)) +
( ~~(A) * ~~(B) * C * D * E) +
( ~~(A) * ~~(B) * ~~(C) * D * ~~(E)) +
( ~~(A) * ~~(B) * ~~(C) * ~~(D) * E)) * S,S ) :- ! .
*/

101
CHR/chr/examples/examples-queens.bool
View File

@ -1,101 +0,0 @@
% 4-queens problem
queens4([[S11, S12, S13, S14],
[S21, S22, S23, S24],
[S31, S32, S33, S34],
[S41, S42, S43, S44]
]) :-
%% rows
card(1,1,[S11, S12, S13, S14]),
card(1,1,[S21, S22, S23, S24]),
card(1,1,[S31, S32, S33, S34]),
card(1,1,[S41, S42, S43, S44]),
%% columns
card(1,1,[S11, S21, S31, S41]),
card(1,1,[S12, S22, S32, S42]),
card(1,1,[S13, S23, S33, S43]),
card(1,1,[S14, S24, S34, S44]),
%% diag left-right
card(0,1,[S14]),
card(0,1,[S13, S24]),
card(0,1,[S12, S23, S34]),
card(0,1,[S11, S22, S33, S44]),
card(0,1,[S21, S32, S43]),
card(0,1,[S31, S42]),
card(0,1,[S41]),
%% diag right-left
card(0,1,[S11]),
card(0,1,[S12, S21]),
card(0,1,[S13, S22, S31]),
card(0,1,[S14, S23, S32, S41]),
card(0,1,[S24, S33, S42]),
card(0,1,[S34, S43]),
card(0,1,[S44]).
/*
Article 4689 of comp.lang.prolog:
From: leonardo@dcs.qmw.ac.uk (Mike Hopkins)
Subject: Re: Solving 4 queens using boolean constraint
Message-ID: <1992Apr6.140627.10533@dcs.qmw.ac.uk>
Date: 6 Apr 92 14:06:27 GMT
References: <1992Apr6.105730.13467@corax.udac.uu.se>
The problem insists that each row and column contains exactly one
queens: therefore the program should be:
fourQueens(q(r(S11, S12, S13, S14),
r(S21, S22, S23, S24),
r(S31, S32, S33, S34),
r(S41, S42, S43, S44))) :-
%% rows
bool:sat(card([1],[S11, S12, S13, S14])),
bool:sat(card([1],[S21, S22, S23, S24])),
bool:sat(card([1],[S31, S32, S33, S34])),
bool:sat(card([1],[S41, S42, S43, S44])),
%% columns
bool:sat(card([1],[S11, S21, S31, S41])),
bool:sat(card([1],[S12, S22, S32, S42])),
bool:sat(card([1],[S13, S23, S33, S43])),
bool:sat(card([1],[S14, S24, S34, S44])),
%% diag left-right
bool:sat(card([0-1],[S14])),
bool:sat(card([0-1],[S13, S24])),
bool:sat(card([0-1],[S12, S23, S34])),
bool:sat(card([0-1],[S11, S22, S33, S44])),
bool:sat(card([0-1],[S21, S32, S43])),
bool:sat(card([0-1],[S31, S42])),
bool:sat(card([0-1],[S41])),
%% diag right-left
bool:sat(card([0-1],[S11])),
bool:sat(card([0-1],[S12, S21])),
bool:sat(card([0-1],[S13, S22, S31])),
bool:sat(card([0-1],[S14, S23, S32, S41])),
bool:sat(card([0-1],[S24, S33, S42])),
bool:sat(card([0-1],[S34, S43])),
bool:sat(card([0-1],[S44])).
This then gives the following result:
| ?- fourQueens(A).
A = q(r(0,_C,_B,0),r(_B,0,0,_A),r(_A,0,0,_B),r(0,_B,_A,0)),
bool:sat(_C=\=_B),
bool:sat(_A=\=_B) ? ;
no
| ?-
This therefore represents the desired two solutions!
===================================================
Mike Hopkins
Dept. of Computer Science, Queen Mary and Westfield College,
Mile End Road, London E1 4NS, UK
Tel: 071-975-5241
ARPA: leonardo%cs.qmw.ac.uk@nsfnet-relay.ac.uk
BITNET: leonardo%uk.ac.qmw.cs@UKACRL.BITNET
===================================================
*/

16
CHR/chr/examples/examples-queens.domain
View File

@ -1,16 +0,0 @@
% n-queens with finite domains
:- setval(domain,number).
queen(N,L):-
length(L,N),
L::1..N,
queen(L).
queen([]).
queen([X|Xs]):- safe(X,Xs,1),queen(Xs).
safe(X,[],N).
safe(X,[H|T],N):- no_attack(X,H,N), M is N+1, safe(X,T,M).
no_attack(X,Y,N):- X ne Y, X ne Y-N, X ne Y+N, Y ne X-N, Y ne X+N.

52
CHR/chr/examples/examples-stuckey.math
View File

@ -1,52 +0,0 @@
% Examples for *math* handlers
% From Peter Stuckey Wed Jun 16 17:51:08 1993
% Results are in old format
:- U1-Z+W=:=0,
U2+Z-V=:=0,
U3-W+V=:=0,
U1>=0,U2>=0,U3>=0,Z>=0,V>=0,W>=0.
/*
U1 = 0
U2 = 0
U3 = 0
Z = Z_m270
V = V_m460
W = W_m290
Constraints:
eq0([Z_m270 * 1, V_m460 * -1], 0, =:=)
eq0([W_m290 * -1, V_m460 * 1], 0, =:=)
eq0([V_m460 * 1], 0, >=)
*/
:- U1-Z+2*W=:=0,
U2+ 2*Z-V=:=0,
U3-W+ 2*V=:=0,
U1>=0,U2>=0,U3>=0,Z>=0,V>=0,W>=0.
/*
U1 = 0
U2 = 0
U3 = 0
Z = 0
V = 0
W = 0
*/
:- X+2*Z>=0,
-Z+Y>=1,
-Y>=2.
/*
X = X_m156
Z = Z_m176
Y = Y_m714
Constraints:
eq0([X_m156 * 1, Z_m176 * 2], 0, >=)
eq0([Z_m176 * -1, Y_m714 * 1], -1, >=)
eq0([X_m156 * 1, Y_m714 * 2], -2, >=)
eq0([Y_m714 * -1], -2, >=)
eq0([Z_m176 * -1], -3, >=)
eq0([X_m156 * 1], -6, >=)
*/

619
CHR/chr/examples/examples-thom.math
View File

@ -1,619 +0,0 @@
% examples-thom1.math --------------------------------------------------------
% thom fruehwirth 1991-93
% examples for *math* constraint handlers compiled from various sources
% results shown are from old obsolete versions
:- op(1200,fx,'example').
:- dynamic (example)/1.
% Equation Examples
example X1+X2=<4, 2*X1+3*X2>=18, X1>=0,X2>=0.
%NO
example Y1>=0,Y2>=0,X1>=0,X2>=0,Y1=:=X1-X2,Y2=:=X2-X1.
%YES Y1 = 0 , Y2 = 0,
% X2 =:= slack(_2),
% X1 =:= slack(_2),
% slack(_1) =:= slack(_2)
example 3*X+2*Y-4*(3+Z)=:=2*(X-3)+(Y+Z)*7,
2*(X+Y+Z)=:=3*(X-Y-Z),
5*(X+Y)-7*X-Z=:=(2+1+X)*6.
%YES Y = 0.657143 , Z = -1 , X = -1.71429
example 3*X+2*Y-4*(3+Z)=:=2*(X-3)+(Y+Z)*7,
2*(X+Y+Z)=:=3*(X-Y-Z).
%YES Z = -1,
% X =:= 5 * -1 + 5 * Y
example 3*X+2*Y-4*(3+Z)=:=2*(X-3)+(Y+Z)*7,
2*(X+Y+Z)=:=3*(X-Y-Z),
5*(X+Y)-7*X-Z=:=(2+1+X)*6 ,
2*(X-Y+Z)=:=Y+X-7.
%Failure, test = 0.0799999
%NO
example 3*X+2*Y-4*(3+Z)=:=2*(X-3)+(Y+Z)*7,
2*(X+Y+Z)=:=3*(X-Y-Z),
5*(X+Y)-7*X-Z >= (2+1+X)*6 ,
2*(X-Y+Z)=:=Y+X-7.
%Success, test = 0.0666666
%YES Z = -1 , Y = 0 , X = -5
example X>=Y,Y>=X.
%Success, test = 0.0216667
%YES ,
% X =:= slack(0) + Y
example X>=Y+1,Y>=X+1.
%Failure, test = 0.0133333
%NO
example X>=Y+1,Y>=X-1.
example X>=Y+1,Y>=X-2.
%Success, test = 0.0199999
%YES ,
% X =:= slack(0) + Y + 1
example X*Y=:=6,X+Y=:=5,X-Y=:=1.
%Success, test = 0.0200001
%YES X = 3.0 , Y = 2.0
example X*Y=:=6,X+Y=:=5,X>=Y.
%Success, test = 0.04
%YES ,
% 6 =:= X * Y,
% X =:= 0.5 * slack(_1) + 2.5,
% Y =:= -0.5 * slack(_1) + 2.5
example X>=Y+Z,Z>=X+1,Y>=Z.
%Success, test = 0.0883333
%YES ,
% Z =:= -(slack(_1)) - slack(_3) - slack(_2) - 1,
% X =:= -(slack(_1)) - 2 * slack(_3) - slack(_2) - 2,
% Y =:= -(slack(_3)) - slack(_2) - 1
% men_and_horses
mh(Men,Horses,Heads,Legs):-
Men >= 0, Horses >= 0,
Heads =:= Men + Horses,
Legs =:= 2*Men + 4*Horses.
% fibonacci
% loops for first argument var !
% works if multi-headed rules are evaluated eagerly as soon as a var is bound
fib(N, X):-
N =:= 0, X =:= 1.
fib(N, X):-
N =:= 1, X =:= 1.
fib(N, X):-
N >= 2, X >= N,
X =:= X1 + X2,
%N1 =:= N - 1,
%N2 =:= N - 2,
fib(N-1, X1),
fib(N-2, X2).
% prove of paralellogram in arbitrary polygon with 4 corners
:- op(31,xfx,#).
mid(AX#AY,BX#BY,CX#CY):-
AX+CX =:= 2*BX,
AY+CY =:= 2*BY.
para(AX#AY,BX#BY,CX#CY,DX#DY):- % nonlinear part
(AX-BX)*(CY-DY) =:= (AY-BY)*(CX-DX).
pp(P0,P1,P2,P3,[P4,P5,P6,P7]):-
mid(P0,P4,P1),
mid(P1,P5,P2),
mid(P2,P6,P3),
mid(P3,P7,P0),
para(P4,P5,P7,P6),
para(P4,P7,P5,P6).
% for solution, 4 points must be given
example pp(1#5,2#3,3#1,5#2,L).
%Success, test = 0.025
%YES L = [1.5 # 4.0, 2.5 # 2.0, 4.0 # 1.5, 3.0 # 3.5]
example pp(A,B,C,D,[1.5 # 4.0, 2.5 # 2.0, 4.0 # 1.5, 3.0 # 3.5]).
/*
YES A = _2 # _4 , B = _1 # _3 , C = _5 # _7 , D = _6 # _8,
_1 =:= _6 - 3.0,
_2 =:= -(_6) + 6.0,
_3 =:= _8 + 1.0,
_4 =:= -(_8) + 7.0,
_5 =:= -(_6) + 8.0,
_7 =:= -(_8) + 3.0
*/
example L = [1.5 # 4.0, 2.5 # 2.0, 4.0 # 1.5, 3.0 # 3.5],pp(A,B,1#1,D,L).
%Success, test = 0.0333328
%YES A = -1 # 5.0 , B = 4.0 # 3.0 , D = 7.0 # 2.0 , L = [1.5 # 4.0, 2.5 # 2.0, 4.0 # 1.5, 3.0 # 3.5]
% CLP(R) Version 1.0 - Example Programs
% Standard mortgage relationship between:
% P: Principal
% T: Life of loan in months
% I: Fixed (but compounded) monthly interest rate
% B: Outstanding balance at the end
% M: Monthly payment
% doesn't run in CHIP because of nonlinear constraints ?
mg(P, T, I, B, MP) :-
T =:= 1,
B =:= P + P*I - MP.
mg(P, T, I, B, MP) :-
T > 1,
T1 =:= T - 1,
P1 =:= P + P*I - MP,
mg(P1, T1, I, B, MP).
mg1(P, T, I, B, MP) :-
T =:= 1,
B =:= P + P*I - MP.
mg1(P, T, I, B, MP) :-
T > 1,
mg1(P + P*I - MP, T-1, I, B, MP).
% code in CLP9R) language and system ACM TPLS paper 1992
mg2(P, T, I, B, MP) :-
T>0,T=<1,
Int =:= T*(P*I/1200),
B =:= P + Int - (T*MP).
mg2(P, T, I, B, MP) :-
T > 1,
Int =:= P*I/1200,
mg2(P+Int-MP, T-1, I, B, MP).
mg1(M):- mg(999999, 6, 0.01, 0, M). % 6 was 360
mg2(P,B,M):- mg(P, 6, 0.01, B, M). % 6 was 720
example mg(999999, 6, 0.01, 0, M).
%YES M = 172548.2
example mg(P, 6, 0.01, B, M).
/*
YES ,
_1 =:= -0.990099 * B + 1.9901 * _5,
M =:= -(B) + 1.01 * _5,
P =:= -4.85343 * B + 5.85343 * _5,
_2 =:= -2.94098 * B + 3.94098 * _5,
_3 =:= -3.90197 * B + 4.90196 * _5,
_4 =:= -1.97039 * B + 2.97039 * _5
*/
example B=0, P=999999,
_1 =:= -0.990099 * B + 1.9901 * _5,
M =:= -(B) + 1.01 * _5,
P =:= -4.85343 * B + 5.85343 * _5,
_2 =:= -2.94098 * B + 3.94098 * _5,
_3 =:= -3.90197 * B + 4.90196 * _5,
_4 =:= -1.97039 * B + 2.97039 * _5.
%Success, test = 0.0199997
%YES _1 = 339988.4 , M = 172548.2 , P = 999999 , _2 = 673276.4 , _3 = 837450.1 , _4 = 507461.0 , B = 0 , _5 = 170839.8
example B=0, P=999999,
M =:= -(B) + 1.01 * _5,
P =:= -4.85343 * B + 5.85343 * _5.
%Success, test = 0.0116669
%YES M = 172548.2 , P = 999999 , B = 0 , _5 = 170839.8
example mg(P, 6,I,B,M).
/*
YES ,
_1 =:= P * I,
M =:= _11 - B + _9,
P =:= -(_3) + _4 + 2 * M - _1,
_10 =:= _6 * I,
_11 =:= _9 * I,
_2 =:= 2 * _8 - 2 * _6 - _5 + 3 * _7 - _3,
_3 =:= _2 * I,
_4 =:= 2 * _10 - 2 * _9 - _8 + 3 * _6 - _5,
_5 =:= _4 * I,
_6 =:= _11 - B - _10 + 2 * _9,
_7 =:= 2 * _11 - 2 * B - _10 + 3 * _9 - _8,
_8 =:= _7 * I
*/
% CLP(R) Version 1.0 - Example Programs
% (Slow implementation of) The classic cryptarithmetic puzzle:
%
% S E N D
% + M O R E
% ---------
% M O N E Y
% works, but very slow
example sendmory([9, 5, 6, 7, 1, 0, 8, 2]).
%Success, test = 0.00999908
%YES (was no before because floats don't unify bit/1)
sendmory([S, E, N, D, M, O, R, Y]) :-
constraints([S, E, N, D, M, O, R, Y]),
gen_diff_digits([S, E, N, D, M, O, R, Y]).
constraints([S, E, N, D, M, O, R, Y]) :-
% S >= 0, E >= 0, N >= 0, D >= 0, M >= 0, O >= 0, R >= 0, Y >= 0,
% S =< 9, E =< 9, N =< 9, D =< 9, M =< 9, O =< 9, R =< 9, Y =< 9,
% S >= 1,
M >= 1,
% C1 >= 0, C2 >= 0, C3 >= 0, C4 >= 0,
% C1 =< 1, C2 =< 1, C3 =< 1, C4 =< 1,
M = C1,
S + M + C2 =:= O + 10 * C1,
E + O + C3 =:= N + 10 * C2,
N + R + C4 =:= E + 10 * C3,
D + E =:= Y + 10 * C4,
bit(C1), bit(C2), bit(C3), bit(C4).
bit(0).
bit(1).
gen_diff_digits(L) :-
gen_diff_digits(L, [0, 1, 2, 3, 4, 5, 6, 7, 8, 9]).
gen_diff_digits([], _).
gen_diff_digits([H | T], L) :-
delete(H, L, L2), gen_diff_digits(T, L2).
% CLP(R) Version 1.0 - Example Programs
% Algebraic combinations of options transactions
% very slow if Stockprice not given, because of
% backtracking caused by h/3, r/3
% heaviside function
h(X, Y, Z) :- Y < X, Z =:= 0.
h(X, Y, Z) :- Y >= X, Z =:= 1.
% ramp function
r(X, Y, Z) :- Y < X , Z =:= 0.
r(X, Y, Z) :- Y >= X, Z =:= Y - X.
% option valuation
% changed order of subgoals
value(Type,Buy_or_Sell,S,C,P,I,X,B,Value) :-
lookup_option(Type,S,C,P,I,X,B,B1,B2,H1,H2,R1,R2),
check_param(S,C,P,I,X,B),
get_sign(Buy_or_Sell,Sign),
h(B1,S,T1),h(B2,S,T2),r(B1,S,T3),r(B2,S,T4),
Value =:= Sign*(H1*T1 + H2*T2 + R1*T3 + R2*T4).
% safety check
check_param(S,C,P,I,X,B) :-
S >= 0, C >= 0, P >= 0,
I >= 0, X >= 0, B >= 0 .
% Buy or sell are just opposite
get_sign(buy,(-1)).
get_sign(sell,1).
% lookup option vector
lookup_option(Type,S,C,P,I,X,B,B1,B2,H1,H2,R1,R2) :-
table(Type,S,C,P,I,X,B,B1,B2,H1,H2,R1,R2).
% table(Type,S,C,P,I,X,B,B11,B21,H11,H21,R11,R21),
% B1 =:= B11, B2 =:= B21, H1 =:= H11, H2 =:= H21, R1 =:= R11, R2 =:= R21.
% Table of values for B1,B2,H1,H2,R1,R2
% generic format - lookup_table(Type,Pos_neg,S,C,P,I,X,B,B1,B2,H1,H2,R1,R2).
% where K to R2 are obtained from the table
% M is a multiplier which is -1 or 1 depending on whether one
% is buying or selling the option
table( stock, S, C, P, I, X, B, 0, 0, S*(1+I), 0, -1, 0).
table( call, S, C, P, I, X, B, 0, X, C*(1+I), 0, 0, -1).
table( put, S, C, P, I, X, B, 0, X, P*(1+I)-X, 0, 1, -1).
table( bond, S, C, P, I, X, B, 0, 0, B*(1+I), 0, 0, 0).
stocks1(Wealth, Stockprice) :-
Wealth =:= Wealth1 + Wealth2,
X = 99,
P = 10, C = 10,
I = 0,
value(put, buy, Stockprice, _, P, I, X, _, Wealth1),
value(call, buy, Stockprice, C, _, I, X, _, Wealth2).
stocks2(Wealth, Stockprice) :-
I = 0.1, P1 = 10, X1 = 20,
value(put, sell, Stockprice, _, P1, I, X1, _, Wealth1),
P2 = 18, X2 = 40,
value(put, buy, Stockprice, _, P2, I, X2, _, Wealth2),
C3 = 15, X3 = 60,
value(call, buy, Stockprice, C3, _, I, X3, _, Wealth3),
C4 = 10, X4 = 80,
value(call, sell, Stockprice, C4, _, I, X4, _, Wealth4),
Wealth =:= Wealth1 + Wealth2 + Wealth3 + Wealth4.
example stocks1(W,10).
/*
Success, test = 0.075
YES W = 69,
_1 =:= slack(_2),
_3 =:= slack(_4),
_5 =:= slack(_6),
_7 =:= slack(_8)
*/
example stocks2(W,10).
/*
YES W = 5.7,
_1 =:= slack(_2),
_11 =:= slack(_12),
_13 =:= slack(_14),
_15 =:= slack(_16),
_3 =:= slack(_4),
_5 =:= slack(_6),
_7 =:= slack(_8),
_9 =:= slack(_10)
*/
% Hoon Hong EXAMPLES
% electric circuit (from clp(r))
resistor(V,I,R):-
V =:= I*R, R>0.
par_circuit(V,I,R1,R2):-
I=:=I1+I2,
resistor(V,I1,R1),
resistor(V,I2,R2).
example par_circuit(A,B,2,2).
%Success, test = 0.0566666
%YES ,
% _1 =:= 0.5 * A,
% B =:= A,
% _2 =:= 0.5 * A
example par_circuit(2,A,2,B).
%Success, test = 0.0300003
%YES ,
% nonzero(B - 0),
% 2 =:= _1 * B,
% A =:= _1 + 1,
% B =:= slack(_2)
% complex number arithmetic ((from clp(r))
zmul(R1#I1,R2#I2,R3#I3):-
R3 =:= R1*R2-I1*I2,
I3 =:= R1*I2+R2*I1.
example zmul(1#2,3#4,C).
%Success, test = 0.00333405
%YES C = -5 # 10
example zmul(A,B,(-5)#10).
/*
Success, test = 0.0483337
YES A = _1 # _4 , B = _3 # _2,
_5 =:= _1 * _3,
_5 =:= _6 - 5,
_6 =:= _4 * _2,
_7 =:= _1 * _2,
_7 =:= -(_8) + 10,
_8 =:= _3 * _4
*/
example zmul(1#2,B,(-5)#10).
%Success, test = 0.0183334
%YES B = 3.0 # 4.0
% pythagorean numbers
% loops, see fib for explaination
% changed order of subgoals
nat(X):- X=:=1.
nat(X):- X>1,nat(Y),X=:=Y+1.
% loops immediately
pyth(X,Y,Z):-
X*X+Y*Y=:=Z*Z,nat(X),nat(Y),nat(Z).
/*
%From lim@scorpio Fri Jan 31 17:09:44 1992
minimize x1 - 2x2
subject to
x1 + x2 >= 2,
-x1 + x2 >= 1,
x2 <= 3.
chr: X+Y>=2,Y-X>=1,Y=<3,X-2*Y=:=M,minimize(M),X=< -1.
Y = 3
M = -7
X = -1
% does not work
chr: X+Y>=2,Y-X>=1,Y=<3,X-2*Y=:=M,minimize(M).
X = X_m176
Y = Y_m196
M = M_m2048
yes if
eq0([slack(X_g7001_m242) * 1, slack(X_g7001_m470) * 1, slack(X_g7602_m1106) * 2], -3)
eq0([X_m176 * 1, Y_m196 * -2, M_m2048 * -1], 0)
eq0([Y_m196 * 1, M_m2048 * 1, slack(X_g7001_m470) * 1], 1)
eq0([M_m2048 * -1, slack(X_g7001_m470) * -1, slack(X_g7602_m1106) * 1], -4)
minimize(M_m2048)
Delayed goals:
X_g7001_m242 >= 0
X_g7001_m470 >= 0
X_g7602_m1106 >= 0
minimize -3x1 + 4x2
subject to
x1 + x2 <= 4,
2x1 + 3x2 >= 18.
chr: X+Y =<4,2*X+3*Y>=18,M=:=4*Y-3*X,minimize(M).
Y = 10
X = -6
M = 58
chr: X+Y =<4,2*X+3*Y>=18,M=:=4*Y-3*X,M<58.
no (more) solution.
minimize -x1 + 2x2 -3x3
subject to
x1 + x2 + x3 = 6,
-x1 + x2 + 2x3 = 4,
2x2 + 3x3 = 10,
x3 <= 2.
chr: X+Y+Z=:=6,Y+2*Z-X=:=4,2*Y+3*Z=:=10,Z=<2,M=:=2*Y-3*Z-X,minimize(M).
Y = 2
Z = 2
X = 2
M = -4
yes.
chr: X+Y+Z=:=6,Y+2*Z-X=:=4,2*Y+3*Z=:=10,Z=<2,M=:=2*Y-3*Z-X,M< -4.
no (more) solution.
*/
% from CACM May 91 34(5) p. 59
% given solution is wrong because last inequation is wrong - replace 26 by 19
%I1=3,I2=2,I3=3,I4=0,I5=4,I6=2,I7=5,I8=0,I9=3,I10=5,I11=(-2),I12=3,I13=4,I14=3,
example I8+I7+I6+I5+I4+I3+I2+6=:=22, I9+I8+I7+I6+I5+I4+I3+I2+6=:=25,
I1=:=3, I2>=2, I3>=3, I4+I3+I2+1>=4, I5+I4+1>=5,
I6+I5+1>=7, I6>=2, I7>=5, I10+I9+1>=2, I11+I10+1>=4,
I12+I11+2=<3, I12+1=<4, I12+I11+1>=2, I12>=3, I13>=4,
I14>=3, I14+I13+I12+I11+4=<22, I14+I13+I12+I11+3=<25,
I14+I13+I12+I11+I10+I9+7>=23, I14+I13+I12+I11+I10+6>=26.
/*
YES I1 = 3 , I9 = 3 , I12 = 3 , I11 = -2,
I7 =:= slack(_1) + 5,
I10 =:= slack(_14) + slack(_13) - 9,
I13 =:= -(slack(_10)) - slack(_9) + 14,
I14 =:= slack(_9) + 3,
I2 =:= -(slack(_7)) + slack(_6) - slack(_5) + slack(_4) - slack(_3),
I3 =:= slack(_3) + 3,
I4 =:= slack(_7) - slack(_6) + slack(_5),
I5 =:= -(slack(_7)) + slack(_6) + 4,
I6 =:= slack(_7) + 2,
I8 =:= -(slack(_1)) - slack(_6) - slack(_4) + 2,
slack(_10) =:= slack(_13) - 4,
slack(_11) =:= slack(_14) + slack(_13) - 7,
slack(_12) =:= slack(_14) + slack(_13) - 14,
slack(_14) =:= slack(_15) + 7,
slack(_2) =:= -(slack(_7)) + slack(_6) - slack(_5) + slack(_4) - slack(_3) - 2,
slack(_8) =:= -(slack(_10)) - slack(_9) + 10
*/
/*
% Examples that take longer --------------------------------------------------
example sendmory(L). % too slow maybe
%YES L = [9, 5, 6, 7, 1, 0, 8, 2]
example stocks1(69,S). % takes long!
/*
YES S = 10,
_1 =:= slack(_2),
_3 =:= slack(_4),
_5 =:= slack(_6),
_7 =:= slack(_8)
;
YES S = 188,
_A =:= slack(_B),
_C =:= slack(_D),
_E =:= slack(_F),
_G =:= slack(_H)
*/
%------------------------------------------------------------------------------
chr: X+Y>=2,Y-X>=1,3>=Y.
X = X_m208
Y = Y_m228
yes if
eq0([X_m208 * 1, Y_m228 * -1, slack(X_g7001_m4754) * 1], 1)
eq0([Y_m228 * 1, slack(X_g7001_m13874) * 1], -3)
eq0([slack(X_g7001_m802) * 1, slack(X_g7001_m4754) * 1, slack(X_g7001_m13874) * 2], -3)
Delayed goals:
X_g7001_m802 >= 0
X_g7001_m4754 >= 0
X_g7001_m13874 >= 0
yes.
chr: X+2*Y=<3,-X-Y=<1.
X = X_m206
Y = Y_m226
yes if
eq0([X_m206 * -1, Y_m226 * -1, slack(X_g7602_m5512) * 1], -1)
eq0([Y_m226 * 1, slack(X_g7602_m808) * 1, slack(X_g7602_m5512) * 1], -4)
Delayed goals:
X_g7602_m808 >= 0
X_g7602_m5512 >= 0
yes.
chr: X+Y-Z=:=0,-Y+3*Z=:=0.
X = X_m222
Y = Y_m242
Z = Z_m262
yes if
eq0([X_m222 * 1, Y_m242 * 1, Z_m262 * -1], 0)
eq0([Y_m242 * -1, Z_m262 * 3], 0)
yes.
chr: 2*X-3*Y+4*Z=:=5,X+2*Y-Z=:=6,-3*X+Y+3*Z=:=1.
X = 2.5714285714285712
Y = 2.714285714285714
Z = 2
*/
% end of file examples-thom1.math ============================================

22
CHR/chr/examples/gcd.pl
View File

@ -1,22 +0,0 @@
% 980202, 980311 Thom Fruehwirth, LMU
% computes greatest common divisor of positive numbers written each as gcd(N)
:- use_module( library(chr)).
handler gcd.
constraints gcd/1.
gcd(0) <=> true.
gcd(N) \ gcd(M) <=> N=<M | L is M-N, gcd(L).
%gcd(N) \ gcd(M) <=> N=<M | L is M mod N, gcd(L). % faster variant
/*
% Sample queries
gcd(2),gcd(3).
gcd(1.5),gcd(2.5).
gcd(37*11*11*7*3),gcd(11*7*5*3),gcd(37*11*5).
*/

242
CHR/chr/examples/interval.pl
View File

@ -1,242 +0,0 @@
% Thom Fruehwirth, LMU, 980129ff, 980312, 980611, 980711
:- use_module( library(chr)).
handler interval.
option(debug_compile,off).
option(already_in_store, off).
option(check_guard_bindings, off).
option(already_in_heads, off).
% for domain constraints
operator( 700,xfx,'::').
%operator( 600,xfx,':'). % operator already defined in Sicstus Prolog
% for inequality constraints
%operator( 700,xfx,lt). % not implemented
operator( 700,xfx,le).
operator( 700,xfx,ne).
operator( 700,xfx,eq).
constraints (::)/2, le/2, eq/2, ne/2, add/3, mult/3.
% X::Min:Max - X is between the numbers Min and Max, inclusively
% X must always be a unbound variable (!), and Min and Max evaluable
% (i.e. ground) arithmetic expressions (or numbers)
constraints int/1.
% int(X) says that X is an integer (default is a real)
constraints bool/1.
% bool(X) says that X is a boolean (default is a real)
constraints browse/1.
% watch how domain of X evolves
browse(X), X::A:B ==> write((X::A:B)),nl.
% define the smallest intervals you want to get:
% the smaller, the more precise, the longer the computation
small(A:B):- A+2.0e-05>=B.
% Intersection -------------------------------
redundant @ X::A:B \ X::C:D <=> %var(X),
(C=<A, B=<D ; A<B,small(A:B), C<D,small(C:D))
|
true.
intersect @ X::A:B , X::C:D <=> %var(X) |
X::max(A,C):min(B,D).
% Special Cases -------------------------------
failure @ X::A:B <=> A>B | fail.
compute @ X::A:B <=> \+ (number(A),number(B)) | C is A, D is B, X::C:D.
integer @ int(X), X::A:B ==> \+ (integer(A),integer(B)) |
C is integer(ceiling(float(A))), D is integer(floor(float(B))), X::C:D.
bool @ bool(X), X::A:B ==> B<1 | X::0:0.
bool @ bool(X), X::A:B ==> A>0 | X::1:1.
bool @ bool(X) ==> X::0:1.
% Inequality -------------------------------
(le) @ X le Y, X::A:B, Y::C:D ==> Y::A:D, X::A:D.
(eq) @ X eq Y, X::A:B, Y::C:D ==> Y::A:B, X::C:D.
(ne) @ X ne Y, X::A:A, Y::A:A <=> fail.
(ne_int) @ int(X) \ X ne Y, X::A:B <=> A=Y | X::A+1:B.
(ne_int) @ int(X) \ X ne Y, X::A:B <=> B=Y | X::A:B-1.
(ne_int) @ int(X) \ Y ne X, X::A:B <=> A=Y | X::A+1:B.
(ne_int) @ int(X) \ Y ne X, X::A:B <=> B=Y | X::A:B-1.
% Addition X+Y=Z -------------------------------
add @ add(X,Y,Z), X::A:B, Y::C:D, Z::E:F ==>
X::E-D:F-C, Y::E-B:F-A, Z::A+C:B+D.
% Multiplication X*Y=Z -------------------------------
mitnull(A:B) :- A=<0, 0=<B.
mult_z @ mult(X,Y,Z), X::A:B, Y::C:D ==>
M1 is A*C, M2 is A*D, M3 is B*C, M4 is B*D,
Z::min(min(M1,M2),min(M3,M4)):max(max(M1,M2),max(M3,M4)).
mult_y @ mult(X,Y,Z), X::A:B, Z::E:F ==>
\+ mitnull(A:B) |
M1 is E/A, M2 is E/B, M3 is F/A, M4 is F/B,
Y::min(min(M1,M2),min(M3,M4)):max(max(M1,M2),max(M3,M4)).
mult_x @ mult(Y,X,Z), X::A:B, Z::E:F ==>
\+ mitnull(A:B) |
M1 is E/A, M2 is E/B, M3 is F/A, M4 is F/B,
Y::min(min(M1,M2),min(M3,M4)):max(max(M1,M2),max(M3,M4)).
mult_xyz @ mult(X,Y,Z), X::A:B, Y::C:D, Z::E:F ==>
mitnull(A:B), mitnull(C:D), \+ mitnull(E:F) |
(A*C<E -> D>0, X::E/D:B ; true),
(B*D<E -> C<0, X::A:E/C ; true),
(F<A*D -> C<0, X::F/C:B ; true),
(F<B*C -> D>0, X::A:F/D ; true).
% Labeling --------------------------------------------------------
constraints split0/1.
constraints split/1.
% repeated split/1:
constraints label/1.
label @ split0(X), X::A:B <=> \+ small(A:B), A<0,0<B |
(X::A:0 ; X::0:B).
label @ split(X), X::A:B <=> \+ small(A:B) |
Half is (A+B)/2,
(X::A:Half ; X::Half:B).
label @ label(X), X::A:B <=> \+ small(A:B) |
Half is (A+B)/2,
(X::A:Half ; X::Half:B),
label(X).
% EXAMPLES ================================================================
/*
?- X::3:5,X::2:4.
X::3:4 ?
?- X::3:5, Y::2:4, X=Y.
Y = X,
X::3:4 ?
?- X::3:3.
X::3:3 ?
?- X le Y, X::3:5,X::2:4.
X le Y,
X::3:4 ?
?- X le Y, X::3:5, Y::3:5.
X le Y,
X::3:5,
Y::3:5 ?
?- X le Y, X::3:5, Y::2:4.
X le Y,
Y::3:4,
X::3:4 ?
?- add(X,Y,Z), X::2:5, Y::3:4, Z::1:7.
Y::3:4,
Z::5:7,
X::2:4,
add(X,Y,Z)?
?- mult(X,Y,Z), X:: -2:3, Y:: -3:4, Z::7:12.
Z::7:12,
X::1.75:3,
Y::2.3333333333333335:4.0,
mult(X,Y,Z) ? ;
?- mult(X,Y,Z), X:: -2:3, Y:: -3:4, Z:: -12: -9.
?- A::(-3):3, B::(-3):3, C::4:4, mult(A,B,C), A eq B.
?- A::(-3):3, B::(-3):3, C::4:4, mult(A,B,C), A eq B, split(A).
?- int(A), A::(-3):3, B::(-3):3, C::4:4, mult(A,B,C), A eq B, split(A).
?- A::(-3):3, B::(-3):3, C::4:4, mult(A,B,C), A eq B,
split(A),split(A),split(A),split(A).
?- A::(-3):3, B::(-3):3, C::4:4, mult(A,B,C), A eq B, label(A).
?- int(A),int(B),int(C), mult(A,B,C), A::0:0.3, B::0:0.3, C::0:0.3,
A le C, B le C, C le A, C le B, A le B, B le A.
?- int(A),int(B),int(C), mult(A,B,C), A::0:0.3, B::0:0.3, C::0:0.3,
A eq B, B eq C.
?- mult(A,B,C), A::0:0.3, B::0:0.3, C::0:0.3, A eq B, B eq C.
A eq B,
B eq C,
C::0.0:4.304672099999998e-9,
B::0.0:4.304672099999998e-9,
A::0.0:4.304672099999998e-9,
mult(A,B,C) ? ;
?- mult(A,B,C), A::0:0.3, B::0:0.3, C::0:0.3, A le C.
B::0:0.3,
A le C,
C::0.0:1.9682999999999995e-5,
A::0:1.9682999999999995e-5,
mult(A,B,C) ? ;
?- mult(A,B,C), A::(-0.3):0.3, B::(-0.3):0.3, C::(-0.3):0.3, A eq C.
B:: -0.3:0.3,
A eq C,
C:: -5.9048999999999996e-6:5.9048999999999996e-6,
A:: -5.9048999999999996e-6:5.9048999999999996e-6,
mult(A,B,C) ? ;
?- mult(A,B,C), A::(-3):3, B::(-3):3, C::(-3):3, A eq C.
% solutions A=C=0 or B=1, impossible to enumerate
A:: -3:3,
B:: -3:3,
C:: -3:3,
A eq C,
mult(A,B,C) ? ;
?- mult(A,B,AB), A eq B, add(AB,C,F), F::5:5,
mult(C,D,CD), C eq D, add(CD,A,G), G::3:3,
A:: -10:10, B:: -10:10, C:: -10:10, D:: -10:10,
split0(A),split0(C).
?- int(A),
mult(A,B,AB), A eq B, add(AB,C,F), F::5:5,
mult(C,D,CD), C eq D, add(CD,A,G), G::3:3,
A:: -10:10, B:: -10:10, C:: -10:10, D:: -10:10,
label(A).
?- mult(A,B,AB), A eq B, add(AB,C,F), F::5:5,
mult(C,D,CD), C eq D, add(CD,A,G), G::3:3,
A:: -10:10, B:: -10:10, C:: -10:10, D:: -10:10,
label(A).
*/
% end of handler interval ===================================================

274
CHR/chr/examples/kl-one.pl
View File

@ -1,274 +0,0 @@
% Terminological Reasoning (similar to KL-ONE or feature trees)
% Ph. Hanschke, DFKI Kaiserslautern, and Th. Fruehwirth
% 920120-920217-920413-920608ff-931210, LMU 980312
:- use_module( library(chr)).
handler klone.
% SYNTAX
% Basic operators
operator(1200,xfx,isa). % concept definition
operator(950,xfx,'::'). % A-Box membership and role-filler assertion
operator(940,xfy,or). % disjunction
operator(930,xfy,and). % conjunction
operator(700,xfx,is). % used in restricitions
operator(690,fy, nota). % complement
operator(650,fx, some). % exists-in restriction
operator(650,fx, every). % value restriction
% Operators for extensions
operator(100,fx, feature). % functional role / attribute
operator(100,fx, distinct). % concept distinct from any other concept
operator(100,fx, at_most_one). % local functional role
operator(100,yfx,of). % role chain (note associativity)
:- dynamic (feature)/1, (distinct)/1, (isa)/2. % to allow scattered clauses
% TYPES
role_assertion((I,J)::R):- individual(I),individual(J), role(R).
membership_assertion(I::T):- individual(I), concept_term(T).
concept_definition((C isa T)):- concept(C), concept_term(T).
concept_term(S):- concept(S).
concept_term(S or T):- concept_term(S), concept_term(T).
concept_term(S and T):- concept_term(S), concept_term(T).
concept_term(nota S):- concept_term(S).
concept_term(some R is S):- role(R), concept_term(S).
concept_term(every R is S):- role(R), concept_term(S).
concept_term(at_most_one R):- role(R). % extension
individual(I):- var(I) ; atomic(I).
role(R):- atom(R).
role(R1 of R2):- role(R1), role(R2). % extension
concept(C):- atom(C).
% CONSISTENCY CHECK
% A-box as constraint goals, T-box asserted (concept definitions by isa-rules)
constraints (::)/2, labeling/0.
% disjunction (is delayed as choice)
labeling, (I::S or T) # Ph <=>
(I::S ; I::T),
labeling
pragma passive(Ph).
% primitive clash
I::nota Q, I::Q <=> fail.
% duplicates
I::C \ I::C <=> true.
% top
I::top <=> true.
% complement nota/1
% nota-top
I::nota top <=> fail.
% nota-or
I::nota (S or T) <=> I::(nota S and nota T).
% nota-and
I::nota (S and T) <=> I::(nota S or nota T).
% nota-nota
I::nota nota S <=> I::S.
% nota-every
I::nota every R is S <=> I::some R is nota S.
% nota-some
I::nota some R is S <=> I::every R is nota S.
% conjunction
I::S and T <=> I::S, I::T.
% exists-in restriction
I::some R is S <=> role(R) | (I,J)::R, J::S. % generate witness
% value restriction
I::every R is S, (I,J)::R ==> J::S.
% Extensions ------------------------------------------------------------------
% value restriction merge and consistency test
I::every R is S1, I::every R is S2 <=> I::every R is S1 and S2, J::S1 and S2.
% distinct/disjoint concept
I::C1 \ I::C2 <=> concept(C1),concept(C2),distinct C1 | C1=C2.
% features/attributes/functional role
(I,J1)::F \ (I,J2)::F <=> feature F | J1=J2.
% role chains
(I,J)::C1 of C2 <=> (I,K)::C2, (K,J)::C1. % also covers "some" case
I::every R1 of R is S, (I,J)::R ==> J::every R1 is S.
I::at_most_one R1 of R, (I,J)::R ==> J::at_most_one R1.
% simple number restriction / local functional role using role chains
constraints at_most_one/3.
I::at_most_one R, (I,J)::R ==> at_most_one(I,J,R).
at_most_one(I,J,R) \ at_most_one(I,J1,R) <=> J1=J.
I::nota at_most_one R <=> (I,J1)::R, (I,J2)::R, (J1,J2)::different.
% concrete domain predicates
(X,X)::different <=> fail.
(X,Y)::identical <=> X=Y.
X::greater(Y) <=> ground(X) | X>Y.
(X,Y)::greater <=> ground(X), ground(Y) | X>Y.
X::smaller(Y) <=> ground(X) | X<Y.
(X,Y)::smaller <=> ground(X), ground(Y) | X<Y.
% binary concrete domain predicates using role chains
I::some (R1 and R2) is S <=> (I,J1)::R1, (I,J2)::R2, (J1,J2)::S.
constraints (every)/3.
I::every (R1 and R2) is S <=> every((I,I),(R1,R2),S).
every((I1,I2),(identical,identical),S) <=> (I1,I2)::S.
every((I1,I2),(identical,R),S), (I2,J2)::R ==>
(I1,J2)::S.
every((I1,I2),(identical,R2 of R),S), (I2,J2)::R ==>
every((I1,J2),(identical,R2),S).
every((I1,I2),(R,R2),S), (I1,J1)::R ==>
every((J1,I2),(identical,R2),S).
every((I1,I2),(R1 of R,R2),S), (I1,J1)::R ==>
every((J1,I2),(R1,R2),S).
% unfolding using concept definition
% if you use recursion in concepts, replace rules below by propagation rules
I::C <=> (C isa T) | I::T.
I::nota C <=> (C isa T) | I::nota T.
% EXAMPLES ===================================================================
% Family ---------------------------------------------------------------------
female isa nota male.
woman isa human and female.
man isa human and male.
parent isa human and some child is human.
father isa parent and man.
mother isa parent and woman.
grandfather isa father and some child is parent.
grandmother isa mother and some child is parent.
fatherofsons isa father and every child is male.
feature age.
person isa (man or woman) and every age is number.
distinct number.
X::number <=> nonvar(X) | number(X).
feature partner.
married_person isa person and every partner is married_person. % recursion !
% Configuration ---------------------------------------------------------------
distinct interface.
distinct configuration.
simple_device isa device and
some connector is interface.
feature component_1.
feature component_2.
simple_config isa configuration and
some component_1 is simple_device and
some component_2 is simple_device.
very_simple_device isa simple_device and
at_most_one connector.
feature price.
feature voltage.
feature frequency.
electrical_device isa very_simple_device and
some voltage is greater(0) and some price is greater(1).
low_cost_device isa electrical_device and
every price is smaller(200).
high_voltage_device isa electrical_device and
every voltage is greater(15).
electrical_config isa simple_configuration and
every component_1 is electrical_device and
every component_2 is electrical_device and
every (voltage of component_1 and voltage of component_2)
is greater.
bus_device isa simple_device and bus and
some frequency is greater(0).
cpu_device isa simple_device and cpu and
some frequency is greater(0).
bus_config isa configuration and
some main_device is bus_device and
every component is cpu_device and
every (frequency of main_device and frequency of sub_device)
is greater.
catalog(dev1) :- dev1::electrical_device,
(dev1,10)::voltage, (dev1,100)::price.
catalog(dev2) :- dev2::electrical_device,
(dev2,20)::voltage, (dev2,1000)::price.
possible_config(C) :-
catalog(D1), (C,D1)::component_1,
catalog(D2), (C,D2)::component_2.
/*
% Example Queries
:- possible_config(C).
:- possible_config(C), C::electrical_config.
:- possible_config(C), C::electrical_config,
(C,D1)::component_1, D1::low_cost_device,
(C,D2)::component_2, D2::high_voltage_device.
*/
% Prolog terms ---------------------------------------------------------
% see also handler term.chr
feature functor.
feature arity.
feature arg(N).
term isa top and some arity is number and some arity is greater(-1)
and some functor is top.
(X,_)::arg(N) ==> N>=1.
%(X,A)::arity ==> A>=0.
(X,A)::arity,(X,_)::arg(N) ==> A>=N,A>=1.
% (X,0)::arity <-> (X,X)::functor
(X,0)::arity ==> (X,X)::functor.
(X,X)::functor ==> (X,0)::arity.
% end of kl-one.pl ========================================================

48
CHR/chr/examples/leq.pl
View File

@ -1,48 +0,0 @@
% simple constraint solver for inequalities between variables
% thom fruehwirth ECRC 950519, LMU 980207, 980311
:- use_module( library(chr)).
handler leq.
constraints leq/2.
% X leq Y means variable X is less-or-equal to variable Y
:- op(500, xfx, leq).
reflexivity @ X leq X <=> true.
antisymmetry @ X leq Y , Y leq X <=> X=Y.
idempotence @ X leq Y \ X leq Y <=> true.
transitivity @ X leq Y , Y leq Z ==> X leq Z.
/*
% more efficient, less propagating version using pragma passive
reflexivity @ X leq X <=> true.
antisymmetry @ X leq Y , Y leq X # Id <=> X=Y pragma passive(Id).
idempotence @ X leq Y # Id \ X leq Y <=> true pragma passive(Id).
transitivity @ X leq Y # Id , Y leq Z ==> X leq Z pragma passive(Id).
*/
% this generates a circular leq-relation chain with N variables
time(N):-
cputime(X),
length(L,N),
genleq(L,Last),
L=[First|_],
Last leq First,
cputime( Now),
Time is Now-X,
write(N-Time), nl.
genleq([Last],Last).
genleq([X,Y|Xs],Last):-
X leq Y,
genleq([Y|Xs],Last).
cputime( Ts) :-
statistics( runtime, [Tm,_]),
Ts is Tm/1000.
% eof handler leq -----------------------------------------------

362
CHR/chr/examples/list.pl
View File

@ -1,362 +0,0 @@
% 931129 ECRC, 980312 LMU thom fruehwirth
% 961106 Christian Holzbaur, SICStus mods
:- use_module( library(chr)).
handler list.
constraints eqlist/2, lenlist/2.
operator(700,xfx,eqlist).
operator(700,xfx,lenlist).
% Rs eqlist L: Rs is a list of lists, whose concatentation is the single list L
[] eqlist L <=> L=[].
[R] eqlist L <=> R=L.
[R|Rs] eqlist [] <=> R=[], Rs eqlist [].
[[X|R]|Rs] eqlist L <=> L=[X|L1], [R|Rs] eqlist L1.
Rs eqlist L <=> delete(R,Rs,Rs1),R==[] | Rs1 eqlist L.
Rs eqlist L <=> delete(R,Rs,Rs1),R==L | Rs1 eqlist [].
constraints labeling/0.
labeling, ([R|Rs] eqlist L)#Ph <=> true |
(var(L) -> length(L,_) ; true),
(
R=[], Rs eqlist L
;
L=[X|L1], R=[X|R1], [R1|Rs] eqlist L1
),
labeling
pragma passive(Ph).
% L lenlist N: The length of the list L is N
% N can be an arithmetic expression
[] lenlist N <=> true | (var(N) -> N=0 ; N=:=0).
[_|L] lenlist N <=> positive(N), plus(M,1,N), L lenlist M.
L lenlist N <=> ground(N) | length(L,N).
% auxiliary predicates ---------------------------------------------------
delete( X, [X|L], L).
delete( Y, [X|Xs], [X|Xt]) :-
delete( Y, Xs, Xt).
length([],0).
length([_|L],N1):- length(L,N), N1 is N+1.
:- block plus(-,-,?), plus(-,?,-), plus(?,-,-).
%
plus( A, B, C) :- var(C), !, C is A+B.
plus( A, B, C) :- var(B), !, B is C-A.
plus( A, B, C) :- var(A), !, A is C-B.
plus( A, B, C) :- C is A+B.
:- block positive(-).
%
positive( X) :- X>0.
% EXAMPLES ================================================================
% Inspired by LISTLOG, Z. Farkas, TAPSOFT 87, Pisa, Italy
% these predicates have better (more fair) enumeration properties
chr_member(X,L):- [_,[X],_] eqlist L.
chr_append(L1,L2,L3):- [L1,L2] eqlist L3.
chr_last(L,X):- [_,[X]] eqlist L.
/*
[6]: chr_member(1,L),chr_member(2,L),labeling.
L = [1, 2] More? (;)
L = [2, 1] More? (;)
L = [1, 2, _g1240] More? (;)
L = [1, _g1062, 2] More? (;)
L = [2, 1, _g1240] More? (;)
L = [2, _g1062, 1] More? (;)
[7]: member(1,L),member(2,L). % compare with usual member/2
L = [1, 2|_g282] More? (;)
L = [1, _g280, 2|_g288] More? (;)
L = [1, _g280, _g286, 2|_g294] More? (;)
*/
palindrome([]).
palindrome([X]).
palindrome(L):-
X lenlist 1,
[X,L1,X] eqlist L,
palindrome(L1).
reverse([],[]).
reverse(R,L):-
R lenlist N,
L lenlist N,
X lenlist 1,
[X,R1] eqlist R,
[L1,X] eqlist L,
reverse(R1,L1).
/*
[19]: reverse(X,[a,b]).
X = [b, a] % does not loop like usual reverse/2
[10]: reverse([a,b|L],R).
L = []
R = [b, a] More? (;)
L = [_m1718]
R = [_m1718, b, a] More? (;)
L = [_m1718, _m2218]
R = [_m2218, _m1718, b, a] More? (;)
[11]: reverse(R,[a,b|L]).
R = [b, a]
L = [] More? (;)
R = [_m754, b, a]
L = [_m754] More? (;)
R = [_m754, _m1274, b, a]
L = [_m1274, _m754] More? (;)
*/
% Done myself (thom)
permute([],[]).
permute(R,L):-
R lenlist N,
L lenlist N,
X lenlist 1,
[X,R1] eqlist R,
[A,X,B] eqlist L,
[A,B] eqlist L1,
permute(R1,L1).
/*
[10]: permute(A,B).
A = []
B = [] More? (;)
A = [_m970]
B = [_m970] More? (;)
A = [_m970, _m1994]
B = [_m2392, _m2416]
Constraints:
[_m946, [_m970], _m994] eqlist [_m2392, _m2416]
[_m946, _m994] eqlist [_m1994]
More? (;)
A = [_m970, _m1994, _m3194]
B = [_m3948, _m3972, _m3996]
Constraints:
[_m1970, [_m1994], _m2018] eqlist [_m3592, _m3616]
[_m946, _m994] eqlist [_m3592, _m3616]
[_m946, [_m970], _m994] eqlist [_m3948, _m3972, _m3996]
[_m1970, _m2018] eqlist [_m3194]
More? (;)
[11]: permute(A,B),labeling.
A = []
B = [] More? (;)
A = [_m976]
B = [_m976] More? (;)
A = [_m976, _m2000]
B = [_m976, _m2000] More? (;)
A = [_m976, _m2000]
B = [_m2000, _m976] More? (;)
A = [_m976, _m2000, _m3200]
B = [_m976, _m2000, _m3200] More? (;)
A = [_m976, _m2000, _m3200]
B = [_m2000, _m976, _m3200] More? (;)
A = [_m976, _m2000, _m3200]
B = [_m2000, _m3200, _m976] More? (;)
A = [_m976, _m2000, _m3200]
B = [_m976, _m3200, _m2000] More? (;)
A = [_m976, _m2000, _m3200]
B = [_m3200, _m976, _m2000] More? (;)
A = [_m976, _m2000, _m3200]
B = [_m3200, _m2000, _m976] More? (;)
*/
% From Cohen, Koiran, Perrin "Meta-Level Interpretation of CLP(Lists)"
% in "CLP: Selected Research", eds Benhamou, Colmerauer, MIT Press 1993.
% tree(Preorder,Postorder,Tree).
tree([A],[A],A):- freeze(A,atomic(A)).
tree(Pre,Post,t(A,L,R)):-
% Pre lenlist N,
% Post lenlist N,
[[A],X,Y] eqlist Pre,
[Z,W,[A]] eqlist Post,
tree(X,Z,L),
tree(Y,W,R).
/*
[50]: tree([a, b, b, a, a], [b, a, a, b, a], T).
T = t(a, b, t(b, a, a))
*/
% Inspired by talk by A. Colmerauer, WCLP Marseille, March 1993
transpose([],L):- [L,[[]]] eqlist [[]|L]. % list of []'s
transpose([X|R],L):- first_column(L,X,L1), transpose(R,L1).
first_column([],[],[]).
first_column([[X|L]|R],[X|S],[L|T]):- first_column(R,S,T).
/*
[36]: transpose([[], [], [], []], L_g85).
L = []
[37]: transpose(L_g69, [[], [], [], []]).
L = []
*/
/*
[18]: [X,Y,Z,Z,Y,X] eqlist [a,b,b,c,c,c,c,c,c,b,b,a], labeling.
Z = [c, c, c]
Y = [b, b]
X = [a]
[21]: [[a],X,[b],Y] eqlist L,
[Y,[b],X,[a]] eqlist L .
Y = Y_m654
X = X_m630
L = [a|_m678]
Constraints:
(3) [X_m630, [b], Y_m654] eqlist _m678
(4) [Y_m654, [b], X_m630, [a]] eqlist [a|_m678]
[4]: [[a],X,[b],Y] eqlist L,
[Y,[b],X,[a]] eqlist L, labeling.
Y = [a]
X = []
L = [a, b, a] More? (;)
Y = [a]
X = [b]
L = [a, b, b, a] More? (;)
Y = [a, b, a]
X = []
L = [a, b, a, b, a] More? (;)
Y = [a, a]
X = [a]
L = [a, a, b, a, a] More? (;)
Y = [a]
X = [b, b]
L = [a, b, b, b, a] More? (;)
Y = [a]
X = [b, b, b]
L = [a, b, b, b, b, a] More? (;)
*/
/*
% Unsolvable equation
{2]: [[2],X] eqlist L,
[X,[1]] eqlist L,
labeling.
% if there is no more solution for longer lists L, labeling does not terminate
% Unsolvable equation from dissertation of J.-P. Pecuchet, 1981
[5]: [[2],X,Y,[1]] eqlist L,
[X,[1],[2],X] eqlist L,
labeling.
% if there is no more solution for longer lists L, labeling does not terminate
% Solvable equation from paper by K. Schulz, 1988
[11]: [[1],X,[2],Z,X] eqlist L,
[Z,[3],Z,Y,Y,Y] eqlist L,
labeling.
X = [3, 1, 2, 1, 3, 1]
Z = [1]
Y = [2, 1, 3, 1]
L = [1, 3, 1, 2, 1, 3, 1, 2, 1, 3, 1, 2, 1, 3, 1] More? (;)
X = [A, 3, 1, A, 2, 1, A, A, 3, 1, A]
Z = [1, A]
Y = [2, 1, A, A, 3, 1, A]
L = [1, A, 3, 1, A, 2, 1, A, A, 3, 1, A, 2, 1, A, A, 3, 1, A, 2, 1, A, A, 3, 1, A] More? (;)
L = [1,_A,_B,3,1,_A,_B,2,1,_A|...],
X = [_A,_B,3,1,_A,_B,2,1,_A,_B|...],
Y = [2,1,_A,_B,_A,_B,3,1,_A,_B],
Z = [1,_A,_B],
etc.
% Solvable equation from talk by A. Colmerauer, WCLP Marseille, March 1993
[13]: X=[1,2,3,2,1],
[X,[1]] eqlist L1, [[U],Y,[U,U]] eqlist L1,
[Y,[2]] eqlist L2, [[V],Z,[V,V]] eqlist L2,
labeling.
X = [1, 2, 3, 2, 1]
U = 1
L1 = [1, 2, 3, 2, 1, 1]
Y = [2, 3, 2]
Z = [3]
V = 2
L2 = [2, 3, 2, 2]
*/
% end of handler list

123
CHR/chr/examples/listdom.pl
View File

@ -1,123 +0,0 @@
% Slim Abdennadher, Thom Fruehwirth, LMU, July 1998
% Finite (enumeration, list) domain solver over integers
:- use_module( library(chr)).
:- use_module( library(lists),
[member/2,memberchk/2,select/3,
last/2,is_list/1,min_list/2, max_list/2,
remove_duplicates/2]).
handler listdom.
option(debug_compile,on).
option(already_in_heads, on).
option(check_guard_bindings, off).
% for domain constraints
operator( 700,xfx,'::').
operator( 600,xfx,'..').
% for inequality constraints
operator( 700,xfx,lt).
operator( 700,xfx,le).
operator( 700,xfx,ne).
constraints (::)/2, le/2, lt/2, ne/2, add/3, mult/3.
% X::Dom - X must be element of the finite list domain Dom
% special cases
X::[] <=> fail.
%X::[Y] <=> X=Y.
%X::[A|L] <=> ground(X) | (member(X,[A|L]) -> true).
% intersection of domains for the same variable
X::L1, X::L2 <=> is_list(L1), is_list(L2) |
intersection(L1,L2,L) , X::L.
X::L, X::Min..Max <=> is_list(L) |
remove_lower(Min,L,L1), remove_higher(Max,L1,L2),
X::L2.
% interaction with inequalities
X le Y, X::L1, Y::L2 ==> is_list(L1),is_list(L2),
min_list(L1,MinX), min_list(L2,MinY), MinX > MinY |
max_list(L2,MaxY), Y::MinX..MaxY.
X le Y, X::L1, Y::L2 ==> is_list(L1),is_list(L2),
max_list(L1,MaxX), max_list(L2,MaxY), MaxX > MaxY |
min_list(L1,MinX), X::MinX..MaxY.
X lt Y, X::L1, Y::L2 ==> is_list(L1), is_list(L2),
max_list(L1,MaxX), max_list(L2,MaxY),
MaxY1 is MaxY - 1, MaxY1 < MaxX |
min_list(L1,MinX), X::MinX..MaxY1.
X lt Y, X::L1, Y::L2 ==> is_list(L1), is_list(L2),
min_list(L1,MinX), min_list(L2,MinY),
MinX1 is MinX + 1, MinX1 > MinY |
max_list(L2,MaxY), Y :: MinX1..MaxY.
X ne Y \ Y::D <=> ground(X), is_list(D), member(X,D) | select(X,D,D1), Y::D1.
Y ne X \ Y::D <=> ground(X), is_list(D), member(X,D) | select(X,D,D1), Y::D1.
Y::D \ X ne Y <=> ground(X), is_list(D), \+ member(X,D) | true.
Y::D \ Y ne X <=> ground(X), is_list(D), \+ member(X,D) | true.
% interaction with addition
% no backpropagation yet!
add(X,Y,Z), X::L1, Y::L2 ==> is_list(L1), is_list(L2) |
all_addition(L1,L2,L3), Z::L3.
% interaction with multiplication
% no backpropagation yet!
mult(X,Y,Z), X::L1, Y::L2 ==> is_list(L1), is_list(L2) |
all_multiplication(L1,L2,L3), Z::L3.
% auxiliary predicates =============================================
remove_lower(_,[],L1):- !, L1=[].
remove_lower(Min,[X|L],L1):-
X@<Min,
!,
remove_lower(Min,L,L1).
remove_lower(Min,[X|L],[X|L1]):-
remove_lower(Min,L,L1).
remove_higher(_,[],L1):- !, L1=[].
remove_higher(Max,[X|L],L1):-
X@>Max,
!,
remove_higher(Max,L,L1).
remove_higher(Max,[X|L],[X|L1]):-
remove_higher(Max,L,L1).
intersection([], _, []).
intersection([Head|L1tail], L2, L3) :-
memberchk(Head, L2),
!,
L3 = [Head|L3tail],
intersection(L1tail, L2, L3tail).
intersection([_|L1tail], L2, L3) :-
intersection(L1tail, L2, L3).
all_addition(L1,L2,L3) :-
setof(Z, X^Y^(member(X,L1), member(Y,L2), Z is X + Y), L3).
all_multiplication(L1,L2,L3) :-
setof(Z, X^Y^(member(X,L1), member(Y,L2), Z is X * Y), L3).
% EXAMPLE ==========================================================
/*
?- X::[1,2,3,4,5,6,7], Y::[2,4,6,7,8,0], Y lt X, X::4..9, X ne Y,
add(X,Y,Z), mult(X,Y,Z).
*/
% end of handler listdom.pl =================================================
% ===========================================================================

136
CHR/chr/examples/math-elim.pl
View File

@ -1,136 +0,0 @@
% math-elim.pl================================================================
% constraint handling rules for linear polynomial (in)equalitions
% thom fruehwirth 910610,911213,920124,930518,931223,940308,950410-11,980312
% 961107 Christian Holzbaur, SICStus mods.
% CHOOSE one of the following elim-* named CHRs for variable elimination
% and comment out the others!
:- use_module( library(chr)).
:- ensure_loaded( 'math-utilities').
handler elim.
% auxiliary constraint to delay a goal G until it is ground
constraints check/1.
check(G) <=> ground(G) | G.
% handle inequalities (introduces slack variables)
constraints {}/1.
{ C,Cs } <=> { C }, { Cs }.
{A =< B} <=> ground(A),ground(B) | A=<B.
{A >= B} <=> ground(A),ground(B) | A>=B.
{A < B} <=> ground(A),ground(B) | A<B.
{A > B} <=> ground(A),ground(B) | A>B.
{A =\= B} <=> ground(A),ground(B) | A=\=B.
% transform inequations into equations by introducing slack variables
{A =< B} <=> {A+slack(X) =:= B}, check(X>=0).
{A >= B} <=> {B+slack(X) =:= A}, check(X>=0).
{A < B} <=> {A+slack(X) =:= B}, check(X>0).
{A > B} <=> {B+slack(X) =:= A}, check(X>0).
{A =\= B} <=> {A+ X =:= B}, check(X=\=0).
% some quick cases and the general case
{A =:= B} <=> ground(A),ground(B) | X is A-B, zero(X). % handle imprecision
{A =:= B} <=> var(A), ground(B) | A is B.
{B =:= A} <=> var(A), ground(B) | A is B.
{A =:= B} <=> unconstrained(A),var(B) | A=B.
{B =:= A} <=> unconstrained(A),var(B) | A=B.
{A =:= B} <=> normalize(A,B,P,C), equals(P,C).
operator(100,xfx,equals).
constraints (equals)/2.
% Poly equals Const, where Poly is list of monomials Variable*Coefficient
% simplify single equation --------------------------------------------------
empty @ [] equals C1 <=> zero(C1).
unify @ [X*C2] equals C1 <=> nonground(X) | is_div(C1,C2,X). % nonzero(X)
simplify @ P0 equals C1 <=> delete(X*C2,P0,P), ground(X) |
is_mul(X,C2,XC2),
C is XC2+C1,
P equals C.
/*
% use only if you unify variables of equations with each other
% if rule is not used: may loop if variables of the equations are unified
unified @ P0 equals C1 <=>
append(P1,[X*C2|P2],P0),var(X),delete(Y*C3,P2,P3),X==Y
|
C23 is C1+C2,
append(P1,[X*C23|P3],P4),
sort1(P4,P5), % needed ?
P5 equals C1.
*/
% CHOOSE one of the following elim-* CHRs for variable elimination
% and comment out the others
% eliminate a variable ------------------------------------------------------
% lazy rule to replace a variable or slack (as used in math-lazy.chr)
elim_lazy @ [X*C2X|PX] equals C1X \ [X*C2|P] equals C1 <=> var(X) |
is_div(C2,C2X,CX),
mult_const(eq0(C1X,PX),CX,P2),
add_eq0(eq0(C1,P),P2,eq0(C3,P3)),
sort1(P3,P4),
P4 equals C3.
/*
% not so lazy rule to replace a variable or slack
% should make all variable bindings explicit
% maybe even less efficient then eager rule?
elim_medium @ [X*C2X|PX] equals C1X \ P0 equals C1 <=>
(P0=[Y*C2|P] ; P0=[VC,Y*C2|P1],P=[VC|P1]),
X==Y
|
is_div(C2,C2X,CX),
mult_const(eq0(C1X,PX),CX,P2),
add_eq0(eq0(C1,P),P2,eq0(C3,P3)),
sort1(P3,P4),
P4 equals C3.
% eager rule to replace a variable or slack (as used in math-eager.chr)
elim_eager @ [X*C2X|PX] equals C1X \ P0 equals C1 <=> %var(X) |
delete(Y*C2,P0,P),X==Y
|
is_div(C2,C2X,CX),
mult_const(eq0(C1X,PX),CX,P2),
add_eq0(eq0(C1,P),P2,eq0(C3,P3)),
P3 equals C3.
*/
/*
% handle slack variables, not complete ---------------------------------------
all_slacks @ P equals C <=> all_slacks(P,PS),sign(C,CS),(CS=0;CS=PS) |
CS=0,all_zeroes(P).
*/
% handle slack variables, complete? ------------------------------------------
zero_slacks @ P equals C <=> zero(C),all_slacks(P,_PS) | all_zeroes(P).
first_slack @ [S1*C1|P] equals C <=> nonvar(S1),sign(C,SC),sign(C1,SC1),SC=SC1 |
(delete(S2*C2,P,P1),sign(C2,SC2),SC2 is -SC ->
[S2*C2,S1*C1|P1] equals C).
elim_slack @ [X*C2X|PX] equals C1X \ P0 equals C1 <=> % P0 all_slacks, no?
nonvar(X), % slack variable
sign(C1X,SC1X),sign(C2X,SC2X),SC2X\==SC1X, % different sign
delete(Y*C2,P0,P),X==Y
|
is_div(C2,C2X,CX),
mult_const(eq0(C1X,PX),CX,P2),
add_eq0(eq0(C1,P),P2,eq0(C3,P3)),
P3 equals C3. % put P0 first slack first, yes?
% handle nonlinear equations -------------------------------------------------
operator(450,xfx,eqnonlin).
constraints (eqnonlin)/2.
linearize @ X eqnonlin A <=> ground(A) | A1 is A, {X=:=A1}.
linearize @ X eqnonlin A*B <=> ground(A) | A1 is A, {X=:=A1*B}.
linearize @ X eqnonlin B*A <=> ground(A) | A1 is A, {X=:=A1*B}.
% pretty-print math-portray for equals/2 is defined in math-utilities.pl -----
/* end of file math-elim.pl -----------------------------------------------*/

209
CHR/chr/examples/math-fougau.pl
View File

@ -1,209 +0,0 @@
% fougau.pl =================================================================
% constraint handling rules for linear arithmetic
% fouriers algorithm for inequalities and gaussian elemination for equalities
% thom fruehwirth 950405-06, 980312
% 961107 Christian Holzbaur, SICStus mods
% CHOOSE one of the propagation rules below and comment out the others!
% completeness and termination depends on propagation rule used
:- use_module( library(chr)).
:- use_module( library(lists), [append/3]).
:- ensure_loaded('math-utilities').
handler fougau.
% auxiliary constraint to delay a goal G until it is ground
constraints check/1.
check(G) <=> ground(G) | G.
constraints {}/1.
{ C,Cs } <=> { C }, { Cs }.
{A =< B} <=> ground(A),ground(B) | A=<B.
{A >= B} <=> ground(A),ground(B) | A>=B.
{A < B} <=> ground(A),ground(B) | A<B.
{A > B} <=> ground(A),ground(B) | A>B.
{A =\= B} <=> ground(A),ground(B) | A=\=B.
{A =< B} <=> normalize(B,A,P,C), eq(P,C,'>'('=')).
{A >= B} <=> normalize(A,B,P,C), eq(P,C,'>'('=')).
{A < B} <=> normalize(B,A,P,C), eq(P,C,'>'('>')).
{A > B} <=> normalize(A,B,P,C), eq(P,C,'>'('>')).
%{A < B} <=> normalize(B,A+1,P,C), eq(P,C,(>=)). % adopt to integer
%{A > B} <=> normalize(A,B+1,P,C), eq(P,C,(>=)). % adopt to integer
{A =\= B} <=> normalize(A+X,B,P,C), eq(P,C,(=:=)), check(X=\=0).
{A =:= B} <=> ground(A),ground(B) | X is A-B, zero(X). % handle imprecision of reals
{A =:= B} <=> var(A), ground(B) | A is B.
{B =:= A} <=> var(A), ground(B) | A is B.
{A =:= B} <=> unconstrained(A),var(B) | A=B.
{B =:= A} <=> unconstrained(A),var(B) | A=B.
{A =:= B} <=> normalize(A,B,P,C), eq(P,C,(=:=)).
constraints eq/3.
% eq(P,C,R)
% P is a polynomial (list of monomials variable*coefficient),
% C is a numeric constant and R is the relation between P and C
% simplify single equation
zero @ eq([],C1,(=:=)) <=> zero(C1).
zero @ eq([],C1,'>'('=')) <=> C1>=0.
zero @ eq([],C1,'>'('>')) <=> C1>0.
unify @ eq([X*C2],C1,(=:=)) <=> nonground(X),nonzero(C2) | is_div(C1,C2,X).
%, integer(X) % if integers only
simplify @ eq(P0,C1,R) <=> delete(X*C2,P0,P),ground(X) | % R any relation
%, integer(X), % if integers only
is_mul(X,C2,XC2),
C is XC2+C1,
eq(P,C,R).
/*
% must use if you unify variables of equations with each other
unified @ eq(P0,C1,R1) <=>
append(P1,[X*C2|P2],P0),var(X),delete(Y*C3,P2,P3),X==Y
|
C23 is C2+C3,
append(P1,[X*C23|P3],P4),
sort1(P4,P5),
eq(P5,C1,R1).
*/
%(1) remove redundant inequation
% -1 (change in number of constraints)
red_poly @ eq([X*C1X|P1],C1,'>'(R1)) \ eq([X*C2X|P2],C2,'>'(R2)) <=>
C is C2X/C1X, % explicit because of call_explicit bug
C>0, % same sign
C1C is C1*C,
C1C=<C2, % remove right one
stronger(C1X,C1C,R1,C2X,C2,R2), % remove right one if C1C=:= C2
same_poly(P1,P2,C)
|
true.
%(2) equate opposite inequations
% -1
opp_poly @ eq([X*C1X|P1],C1,'>'(R1)), eq([X*C2X|P2],C2,'>'(R2)) <=>
C is C2X/C1X,
C<0, % different sign
C1C is C1*C,
C1C>=C2, % applicable?
same_poly(P1,P2,C)
|
Z is C1C-C2, zero(Z), % must have identical constants
(R1)=('='), (R2)=('='), % fail if one of R's is ('>')
eq([X*C1X|P1],C1,(=:=)).
%(3) usual equation replacement (like math-gauss.chr)
% 0
/*
elimin_eager @ eq([X*C2X|PX],C1X,(=:=)) \ eq(P0,C1,R) <=> % R any relation
extract(X*C2,P0,P)
|
is_div(C2,C2X,CX),
mult_const(eq0(C1X,PX),CX,P2),
add_eq0(eq0(C1,P),P2,eq0(C3,P3)),
sort1(P3,P4),
eq(P4,C3,R).
*/
elimin_lazy @ eq([X*C2X|PX],C1X,(=:=)) \ eq([X*C2|P],C1,R) <=>
is_div(C2,C2X,CX),
mult_const(eq0(C1X,PX),CX,P2),
add_eq0(eq0(C1,P),P2,eq0(C3,P3)),
sort1(P3,P4),
eq(P4,C3,R).
% choose one of the propagation rules below and comment out the others!
% completeness and termination depends on propagation rule used
%(4) propagate, transitive closure of inequations, various versions
% +1
/*
% complete, but too costly, propagate_lazy is as good, can loop
propagate_eager @ eq([X*C2X|PX],C1X,'>'(R1)), eq(P0,C1,'>'(R2)) ==>
extract(X*C2,P0,P),
is_div(C2,C2X,CX),
CX>0 % different sign?
|
combine_ineqs(R1,R2,R3),
mult_const(eq0(C1X,PX),CX,P2),
add_eq0(eq0(C1,P),P2,eq0(C3,P3)),
sort1(P3,P4),
eq(P4,C3,'>'(R3)).
% complete, may loop
propagate_lazy @ eq([X*C2X|PX],C1X,'>'(R1)), eq([X*C2|P],C1,'>'(R2)) ==>
is_div(C2,C2X,CX),
CX>0 % different sign?
|
combine_ineqs(R1,R2,R3),
mult_const(eq0(C1X,PX),CX,P2),
add_eq0(eq0(C1,P),P2,eq0(C3,P3)),
sort1(P3,P4),
eq(P4,C3,'>'(R3)).
*/
/*
% incomplete, number of variables does not increase, may loop
propagate_pair @ eq([X*C2X|PX],C1X,'>'(R1)), eq(P0,C1,'>'(R2)) ==>
not(PX=[_,_,_|_]), % single variable or pair of variables only
extract(X*C2,P0,P),
is_div(C2,C2X,CX),
CX>0 % different sign?
|
combine_ineqs(R1,R2,R3),
mult_const(eq0(C1X,PX),CX,P2),
add_eq0(eq0(C1,P),P2,eq0(C3,P3)),
sort1(P3,P4),
eq(P4,C3,'>'(R3)).
*/
% incomplete, is interval reasoning, number of variables decreases, loop free
propagate_single @ eq([X*C2X],C1X,'>'(R1)), eq(P0,C1,'>'(R2)) ==> % single variable only
(P0=[V*C2|P],V==X ; P0=[VC,V*C2|PP],V==X,P=[VC|PP]), % only first or second variable
is_div(C2,C2X,CX),
CX>0 % different sign?
|
combine_ineqs(R1,R2,R3),
is_mul(C1X,CX,C1XCX),
C3 is C1+C1XCX,
eq(P,C3,'>'(R3)).
/*
% incomplete, ignore inequations until they are sufficiently simplified
%propagate_never @ eq([X*C2X|PX],C1X,'>'(R1)), eq([X*C2|P],C1,'>'(R2)) ==>
% fail | true.
*/
% handle nonlinear equations ------------------------------------------------
operator(450,xfx,eqnonlin).
constraints (eqnonlin)/2.
non_linear @ X eqnonlin A <=> ground(A) | A1 is A, {X=:=A1}.
non_linear @ X eqnonlin A*B <=> ground(A) | A1 is A, {X=:=A1*B}.
non_linear @ X eqnonlin B*A <=> ground(A) | A1 is A, {X=:=A1*B}.
% labeling, useful really only for integers ---------------------------------
%label_with eq([XC],C1,'>'('=')) if true.
%eq([XC],C1,'>'('=')) :- eq([XC],C1,(=:=)) ; eq([XC],C1,'>'('>')).
% auxiliary predicates --------------------------------------------------------
% combine two inequalities
combine_ineqs(('='),('='),('=')):- !.
combine_ineqs(_,_,('>')).
same_poly([],[],C).
same_poly([X*C1|P1],[X*C2|P2],C) ?-
%X==Y,
C4 is C*C1-C2, zero(C4),
same_poly(P1,P2,C).
stronger(C1X,C1C,R1,C2X,C2,R2):-
C1C=:=C2 ->
\+ (R1=('='),R2=('>')),
C1A is abs(C1X)+1/abs(C1X), C2A is abs(C2X)+1/abs(C2X),
C1A=<C2A
;
true.
/* end of file math-fougau.chr ----------------------------------------------*/

64
CHR/chr/examples/math-fourier.pl
View File

@ -1,64 +0,0 @@
% Slim Abdennadher, Thom fruehwirth, LMU, July 1998
% Straightforward Fourier Solver for linear inequations
% may loop because of producing more and mor eredundant equations
% compare to gauss.pl and fougau.pl
:- use_module(library(chr)).
:- ['math-utilities.pl']. % load auxiliary file
:- use_module( library(lists), [member/2, memberchk/2,select/3]).
handler gauss.
option(check_guard_bindings, on). % for delete(X...)
option(already_in_store, off).
option(already_in_heads, off).
operator(100,xfx,leq).
constraints (leq)/2.
redundant @
[X*Coeff1|P1] leq C1 \ P leq C2 <=>
delete(X*Coeff2,P,P2),
is_div(Coeff2,Coeff1,C),
C < 0,
mult_const(eq0(C1,P1),C,eq0(C1C,P1C)),
add_eq0(eq0(C2,P2),eq0(C1C,P1C),eq0(C3,P3)),
P3=[], 0 >= C3
|
true.
propagate(X) @
[X*Coeff1|P1] leq C1, P leq C2 ==>
delete(X*Coeff2,P,P2),
is_div(Coeff2,Coeff1,C),
C > 0
|
mult_const(eq0(C1,P1),C,eq0(C1C,P1C)),
add_eq0(eq0(C2,P2),eq0(C1C,P1C),eq0(C3,P3)),
P3 leq C3.
zero @ [] leq C1 <=> 0 =< C1.
constraints {}/1.
% curly brackets as wrapper to avoid name clash with built-in =:= etc.
split @ { C, Cs } <=> { C }, { Cs }.
normalize @ {A >= B} <=> {B =< A}.
normalize @ {A =:= B} <=> {A >= B}, {B =< A}.
normalize @ {A =< B} <=>
normalize(A,B,Poly,Const),
Poly leq Const.
/*
3 * X + 2 * Y - 4 * (3 + Z) =:= 2 * (X - 3) + (Y + Z) * 7 ,
2 * (X + Y + Z) =:= 3 * (X - Y - Z) ,
5 * (X + Y) - 7 * X - Z =:= (2 + 1 + X) * 6.
*/

55
CHR/chr/examples/math-gauss.pl
View File

@ -1,55 +0,0 @@
% solving linear polynomial equations by variable elimination a la Gauss
% thom fruehwirth 910610,911213,920124,930602,931223, 980311
% 961107 christian holzbaur for SICStus CHR
% complete for equalities, leaves equalities implicit, slow
% may loop if variables of the equations are unified
:- use_module(library(chr)).
:- ensure_loaded('math-utilities'). % load auxiliary file
handler gauss.
option(check_guard_bindings, on). % for delete(X...) in rule eliminate
operator(100,xfx,equals).
constraints (equals)/2.
% Poly equals Const, where Poly is list of monomials Variable*Coefficient
eliminate(X) @
[X*Coeff1|P1] equals C1 \ P equals C2 <=> delete(X*Coeff2,P,P2) |
is_div(Coeff2,Coeff1,C),
mult_const(eq0(C1,P1),C,eq0(C1C,P1C)),
add_eq0(eq0(C2,P2),eq0(C1C,P1C),eq0(C3,P3)),
P3 equals C3.
constraints {}/1.
% curly brackets as wrapper to avoid name clash with built-in =:=
split @ { C, Cs } <=> { C }, { Cs }.
normalize @ {A =:= B} <=>
normalize(A,B,Poly,Const),
Poly equals Const.
/*
% uses math_portray pretty print defined in math-utilities.pl
?- {3 * X + 2 * Y - 4 * (3 + Z) =:= 2 * (X - 3) + (Y + Z) * 7 ,
2 * (X + Y + Z) =:= 3 * (X - Y - Z) ,
5 * (X + Y) - 7 * X - Z =:= (2 + 1 + X) * 6}.
-(6*Z)=:=6,
-(35*Y)=:= -23,
X=:= -1.7142857142857144 ?
?- {3 * X + 2 * Y - 4 * (3 + Z) =:= 2 * (X - 3) + (Y + Z) * 7 ,
2 * (X + Y + Z) =:= 3 * (X - Y - Z)}.
-(6*Z)=:=6,
-(5*Y)+X=:= -5 ?
*/
/* end of file gauss.chr ------------------------------------------------*/

300
CHR/chr/examples/math-utilities.pl
View File

@ -1,300 +0,0 @@
% math-utilities.pl ===========================================================
% auxiliary predicates for math*.pl constraint solvers
% thom fruehwirth 1991-92, revised 930518,931223,940304
% 961030 christian holzbaur, SICStus adaption
:- use_module( library('chr/getval')).
:- use_module( library('chr/matching')).
:- use_module( library('chr/ordering'), [globalize/1,var_compare/3]).
% SETTINGS --------------------------------------------------------------------
% for use in is/2: precision, slack variables, simulated infimum, etc.
% Code works with flag prefer_rationals on or off
% and with float_precision single or double
% adapt precision for zero/1 test
:- ( current_module(eclipse) ->
get_flag(float_precision,G)
;
G = double
),
(G==single -> setval(precision,1.0e-06),setval(mprecision,-1.0e-06)
;
G==double -> setval(precision,1.0e-12),setval(mprecision,-1.0e-12)
).
slack(X,X). % :- X>=0.
inf( 3.40282e38).
minf( -3.40282e38).
sup( 1.0e-45).
msup( -1.0e-45).
:- multifile portray/1.
portray( X) :- math_portray( X, Xp), print( Xp).
% PRETTY PRINT ---------------------------------------------------------------
% for math-gauss.pl and math-elim.pl
math_portray(equals(P,C),P1=:=0):- zero(C),!,
make_poly(P,P1).
math_portray(equals(P,C),P1=:=C1):-!,
MC is (-C),
avoid_float(MC,C1),
make_poly(P,P1).
% for math-fougau.pl
math_portray(eq(P,C,(=:=)),P1=:=C1):-!,
MC is (-C),
avoid_float(MC,C1),
make_poly(P,P1).
math_portray(eq(P,C,'>'('=')),P1>=C1):-!,
MC is (-C),
avoid_float(MC,C1),
make_poly(P,P1).
math_portray(eq(P,C,'>'('>')),P1>C1):-!,
MC is (-C),
avoid_float(MC,C1),
make_poly(P,P1).
% for all three math*pl solvers
math_portray(eqnonlin(X,(E)),X=:=E):-!.
make_poly([],0).
make_poly([X*C],-CX):- C<0,!,
C1 is (-C),
avoid_float(C1,C2),
make_mono(C2,X,CX).
make_poly([X*C],CX):-!,
avoid_float(C,C1),
make_mono(C1,X,CX).
make_poly([X*C|P],P1-CX):- C<0,!,
C1 is (-C),
avoid_float(C1,C2),
make_mono(C2,X,CX),
make_poly(P,P1).
make_poly([X*C|P],P1+CX):-
avoid_float(C,C1),
make_mono(C1,X,CX),
make_poly(P,P1).
make_mono(C,X,CX):- nonvar(X),X=slack(Y),!,make_mono(C,Y,CX).
make_mono(C,X,CX1):- nonvar(X),number(X),!,CX is C*X,avoid_float(CX,CX1).
make_mono(1,X,X):-!.
% make_mono(1_1,X,X):-!.
make_mono(C,X,C*X).
% AUXILIARY PREDICATES -------------------------------------------------------
nonground( X) :- ground( X), !, fail.
nonground( _).
%
% sort X*K,slack(_)*K with globalized Xs
%
sort1(A,B):-
msort(A,C),
((C=[X*_|_],nonvar(X),X=slack(_))->A=B;B=C). % slacks unordered why?
msort( L, S) :-
length( L, Len),
msort( Len, L, [], S).
msort( 0, L, L, []) :- !.
msort( 1, [X|L], L, [X]) :- !.
msort( N, L0, L2, S) :-
P is N>>1,
Q is N-P,
msort( P, L0, L1, Sp),
msort( Q, L1, L2, Sq),
merge( Sp, Sq, S).
merge( [], B, B) :- !.
merge( A, [], A) :- !.
merge( [A|As], [B|Bs], Res) :-
cmp( R, A, B),
merge( R, A, As, B, Bs, Res).
merge( =, A, As, _, Bs, [A|Rest]) :- merge( As, Bs, Rest).
merge( <, A, As, B, Bs, [A|Rest]) :- merge( As, [B|Bs], Rest).
merge( >, A, As, B, Bs, [B|Rest]) :- merge( [A|As], Bs, Rest).
cmp( R, X, Y) :- var(X), var(Y), !, var_compare( R, X, Y).
cmp( R, X, _) :- var(X), !, R = (<).
cmp( R, _, Y) :- var(Y), !, R = (>).
cmp( R, X, Y) :-
functor( X, Fx, Ax),
functor( Y, Fy, Ay),
compare( Rr, Ax/Fx, Ay/Fy),
( Rr = (=),
Ax > 0 ->
cmp_args( 1,Ax, X, Y, R)
;
R = Rr
).
cmp_args( N,M, _, _, R) :- N>M, !, R = (=).
cmp_args( N,M, X, Y, R) :-
arg( N, X, Ax),
arg( N, Y, Ay),
cmp( Rr, Ax, Ay),
( Rr = (=) ->
N1 is N+1,
cmp_args( N1,M, X, Y, R)
;
R = Rr
).
rev([],L,L).
rev([X|L1],L2,L3):- rev(L1,[X|L2],L3).
extract(X*C2,P0,P) ?- delete(Y*C2,P0,P),X==Y,!.
delete( X, [X|L], L).
delete( Y, [X|Xs], [X|Xt]) :-
delete( Y, Xs, Xt).
zero( slack(S)) ?- !, zero( S).
zero(C):-
float(C) ->
getval(precision,P),
getval(mprecision,MP),
MP < C, % cope with imprecision
C < P
;
C=:=0.
nonzero(C):- zero(C), !, fail.
nonzero(_).
unwrap( slack(S), X) ?- !, X=S.
unwrap( X, X).
is_div( C1, C2, C3) :-
unwrap( C1, C11),
unwrap( C2, C21),
unwrap( C3, C31),
is_divu( C11, C21, C31).
is_divu(C1,C2,C3):- zero(C1),!,C3=0.
is_divu(C1,C2,C3):- X is -(C1/C2), % minus here to get sign needed in handlers
avoid_float(X,C3).
is_mul( C1, C2, C3) :-
unwrap( C1, C11),
unwrap( C2, C21),
unwrap( C3, C31),
is_mulu( C11, C21, C31).
is_mulu(C1,C2,C3):- zero(C1),!,C3=0.
is_mulu(C1,C2,C3):- zero(C2),!,C3=0.
is_mulu(C1,C2,C3):- X is C1*C2,
avoid_float(X,C3).
avoid_float(X,C3):-
float(X) -> Y is round(X),Z is X-Y,(zero(Z)-> C3 is integer(Y);C3=X) ; C3=X.
simplifyable(X*C,P,P1):- delete(X*C,P,P1),ground(X),!.
% HANDLING SLACK VARIABLES ----------------------------------------------------
all_slacks([]).
all_slacks([slack(Sl)*C|P]) ?- % check_slack(Sl),
all_slacks(P).
all_slacks([],_).
all_slacks([slack(Sl)*C|P],S) ?- % check_slack(Sl),
sign(C,S),
all_slacks(P,S).
check_slack( S) :- find_constraint( S, basic(_)#_), !.
check_slack( _) :- raise_exception( slack).
sign(C,0):- zero(C),!.
sign(C,S):- C>0 -> S=1 ; S=(-1).
all_zeroes([]).
all_zeroes([slack(0)*C|P]) :-
all_zeroes(P).
% COMPUTING WITH POLYNOMIALS -------------------------------------------------
% gets rounded constant C from is_div/3
mult_const(eq0(C1,P1),C,eq0(0 ,[])):- C=:=0,!.
mult_const(eq0(C1,P1),C,eq0(C1,P1)):- C=:=1,!.
mult_const(eq0(C1,P1),C2,eq0(C,P)):-
(zero(C1) -> C=0 ; C is C1*C2),
mult_const1(P1,C2,P).
mult_const1([],C,[]).
mult_const1([Xi*Ci|Poly],C,PolyR):-
(zero(Ci) -> PolyR=NPoly ; NCi is Ci*C,PolyR=[Xi*NCi|NPoly]),
mult_const1(Poly,C,NPoly).
% gets input from const_mult/3
add_eq0(eq0(C1,P1),eq0(C2,P2),eq0(C,P0)):-
Ci is C1+C2,
(zero(Ci) -> C=0 ; C=Ci),
add_eq1(P1,P2,P0).
% sort(P,P0).
add_eq1([],Poly,Poly):-!.
add_eq1(Poly,[],Poly):-!.
add_eq1([Xi1*Ci1|Poly1],Poly21,Poly):-
delete(Xi2*Ci2,Poly21,Poly2),Xi2==Xi1,
!,
Ci is Ci1+Ci2,
(zero(Ci) -> Poly=Poly3 ; Poly=[Xi1*Ci|Poly3]),
add_eq1(Poly1,Poly2,Poly3).
add_eq1([Xi1*Ci1|Poly1],Poly2,[Xi1*Ci1|Poly3]):-
add_eq1(Poly1,Poly2,Poly3).
normalize(A,B,P2,C1):-
normalize1(A-B,P),
P=eq0(C1,P1),rev(P1,[],P1R),globalize(P1R),
sort1(P1,P2).
normalize1(V,P) ?- var(V),!,
P=eq0(0,[V*1]).
normalize1(C,P) ?- ground(C),!,
C1 is C,P=eq0(C1,[]).
normalize1(slack(V),P) ?- !,
P=eq0(0,[slack(V)*1]).
normalize1((+E),P) ?-!,
normalize1(E,P).
normalize1((-E),P) ?-!,
normalize1(E,P1),
mult_const(P1,(-1),P).
normalize1(A*B,C) ?- ground(A),!,
normalize1(B,BN),
mult_const(BN,A,C).
normalize1(B*A,C) ?- ground(A),!,
normalize1(B,BN),
mult_const(BN,A,C).
normalize1(B/A,C) ?- ground(A),!,
normalize1(B,BN),
A1 is 1/A,
mult_const(BN,A1,C).
normalize1(A-B,C) ?- !,
normalize1(A,AN),
normalize1((-B),BN),
add_eq0(AN,BN,C).
normalize1(A+B,C) ?- !,
normalize1(A,AN),
normalize1(B,BN),
add_eq0(AN,BN,C).
normalize1(E,C) ?-
C=eq0(0,[CX*1]),
eqnonlin(CX,E). % add a nonlinear equation constraint
% end of file math-utilities.pl -----------------------------------------------

127
CHR/chr/examples/minmax.pl
View File

@ -1,127 +0,0 @@
% INEQUALITIES with MINIMIUM and MAXIMUM on terms
% 920303, 950411 ECRC Thom Rruehwirth
% 961105 Christian Holzbaur, SICStus mods
:- use_module( library(chr)).
handler minmax.
option(check_guard_bindings, on). % for ~=/2 with deep guards
operator(700, xfx, lss). % less than
operator(700, xfx, grt). % greater than
operator(700, xfx, neq). % not equal to
operator(700, xfx, geq). % greater or equal to
operator(700, xfx, leq). % less or equal to
operator(700, xfx, ~=). % not identical
constraints (~=)/2.
X ~= X <=> fail.
X ~= Y <=> ground(X),ground(Y) | X\==Y.
constraints (leq)/2, (lss)/2, (neq)/2, minimum/3, maximum/3.
X geq Y :- Y leq X.
X grt Y :- Y lss X.
/* leq */
built_in @ X leq Y <=> ground(X),ground(Y) | X @=< Y.
reflexivity @ X leq X <=> true.
antisymmetry @ X leq Y, Y leq X <=> X = Y.
transitivity @ X leq Y, Y leq Z ==> X \== Y, Y \== Z, X \== Z | X leq Z.
subsumption @ X leq N \ X leq M <=> N@<M | true.
subsumption @ M leq X \ N leq X <=> N@<M | true.
/* lss */
built_in @ X lss Y <=> ground(X),ground(Y) | X @< Y.
irreflexivity@ X lss X <=> fail.
transitivity @ X lss Y, Y lss Z ==> X \== Y, Y \== Z | X lss Z.
transitivity @ X leq Y, Y lss Z ==> X \== Y, Y \== Z | X lss Z.
transitivity @ X lss Y, Y leq Z ==> X \== Y, Y \== Z | X lss Z.
subsumption @ X lss Y \ X leq Y <=> true.
subsumption @ X lss N \ X lss M <=> N@<M | true.
subsumption @ M lss X \ N lss X <=> N@<M | true.
subsumption @ X leq N \ X lss M <=> N@<M | true.
subsumption @ M leq X \ N lss X <=> N@<M | true.
subsumption @ X lss N \ X leq M <=> N@<M | true.
subsumption @ M lss X \ N leq X <=> N@<M | true.
/* neq */
built_in @ X neq Y <=> X ~= Y | true.
irreflexivity@ X neq X <=> fail.
subsumption @ X neq Y \ Y neq X <=> true.
subsumption @ X lss Y \ X neq Y <=> true.
subsumption @ X lss Y \ Y neq X <=> true.
simplification @ X neq Y, X leq Y <=> X lss Y.
simplification @ Y neq X, X leq Y <=> X lss Y.
/* MINIMUM */
constraints labeling/0.
labeling, minimum(X, Y, Z)#Pc <=>
(X leq Y, Z = X ; Y lss X, Z = Y),
labeling
pragma passive(Pc).
built_in @ minimum(X, Y, Z) <=> ground(X),ground(Y) | (X@=<Y -> Z=X ; Z=Y).
built_in @ minimum(X, Y, Z) <=> Z~=X | Z = Y, Y lss X.
built_in @ minimum(Y, X, Z) <=> Z~=X | Z = Y, Y lss X.
min_eq @ minimum(X, X, Y) <=> X = Y.
min_leq @ Y leq X \ minimum(X, Y, Z) <=> Y=Z.
min_leq @ X leq Y \ minimum(X, Y, Z) <=> X=Z.
min_lss @ Z lss X \ minimum(X, Y, Z) <=> Y=Z.
min_lss @ Z lss Y \ minimum(X, Y, Z) <=> X=Z.
functional @ minimum(X, Y, Z) \ minimum(X, Y, Z1) <=> Z1=Z.
functional @ minimum(X, Y, Z) \ minimum(Y, X, Z1) <=> Z1=Z.
propagation @ minimum(X, Y, Z) ==> X\==Y | Z leq X, Z leq Y.
/* MAXIMUM */
labeling, maximum(X, Y, Z)#Pc <=>
(X leq Y, Z = Y ; Y lss X, Z = X),
labeling
pragma passive(Pc).
built_in @ maximum(X, Y, Z) <=> ground(X),ground(Y) | (Y@=<X -> Z=X ; Z=Y).
built_in @ maximum(X, Y, Z) <=> Z~=X | Z = Y, X lss Y.
built_in @ maximum(Y, X, Z) <=> Z~=X | Z = Y, X lss Y.
max_eq @ maximum(X, X, Y) <=> X = Y.
max_leq @ Y leq X \ maximum(X, Y, Z) <=> X=Z.
max_leq @ X leq Y \ maximum(X, Y, Z) <=> Y=Z.
max_lss @ X lss Z \ maximum(X, Y, Z) <=> Y=Z.
max_lss @ Y lss Z \ maximum(X, Y, Z) <=> X=Z.
functional @ maximum(X, Y, Z) \ maximum(X, Y, Z1) <=> Z1=Z.
functional @ maximum(X, Y, Z) \ maximum(Y, X, Z1) <=> Z1=Z.
propagation @ maximum(X, Y, Z) ==> X\==Y | X leq Z, Y leq Z.
% end of handler minmax

36
CHR/chr/examples/modelgenerator.pl
View File

@ -1,36 +0,0 @@
:- use_module(library(chr)).
handler modelgenerator.
constraints attends/3, requires/2, less/2, leq/2.
operator(700,xfx,less).
operator(700,xfx,leq).
X less Y <=> nonvar(X), nonvar(Y) | X < Y.
X less Y \ X less Z <=> Y =< Z | true.
X less Y, X leq Y <=> false.
X leq X <=> true.
attends(S, Y, TY), requires(Y, X) ==> attends(S, X, TX), TX less TY.
attends(john,C,T) ==> true | (T leq 1996 ; T less 1994).
example :-
attends(john,constraintprogrammierung,1996),
requires(constraintprogrammierung,logik).
/*
?- example.
requires(constraintprogrammierung,logik),
_A less 1994,
attends(john,constraintprogrammierung,1996),
attends(john,logik,_A) ?
*/

340
CHR/chr/examples/monkey.pl
View File

@ -1,340 +0,0 @@
%
% Monkey and Bananas:
%
% Forward chaining rules via CHR.
% rules inspired from ftp://ftp.cs.unibo.it:/pub/gaspari/fw_rules/
% Quite fast because no dynamic predicates are used to
% represent the facts.
% The amount of code generated is substantial however.
% Not optimized
%
% 970213 Christian Holzbaur
:- use_module(library(chr)).
handler monkey.
constraints phys_object/7, monkey/3, goal/5, found/0.
% explaination of constraints is missing here
:- op(900,fy,not).
% There is no such fact ('not exists' in SQL)
not Fact :- find_constraint( Fact, _), !, fail.
not _.
testcase(1) :-
phys_object(bananas,9-9,light,ceiling,_,_,ok),
phys_object(couch,7-7,heavy,floor,_,low,_),
phys_object(ladder,4-3,light,floor,_,high,_),
phys_object(blanket,7-7,light,_,_,_,_),
phys_object(garbage_can,3-5,light,floor,_,low,_),
monkey(7-7,couch,blanket),
goal(active,holds,bananas,_,_).
rule(1) @
goal(active,on,floor,A,B),
monkey(D,E,F) <=>
E\==floor
|
write('Jump onto the floor'),
nl,
monkey(D,floor,F),
goal(satisfied,on,floor,A,B).
rule(2) @
monkey(A,floor,B) \
goal(active,on,floor,D,E) <=>
write('Monkey is already on floor'),
nl,
goal(satisfied,on,floor,D,E).
rule(3) @
phys_object(A,B,C,floor,D,E,F) \
goal(active,on,A,H,I),
monkey(B,K,nothing) <=>
K\==A
|
write('Climb onto '),
write(A),
nl,
monkey(B,A,nothing),
goal(satisfied,on,A,H,I).
rule(4) @
goal(active,on,A,B,C),
phys_object(A,E,F,G,H,I,J),
monkey(E,L,M) ==>
M\==nothing
|
write('Put '),
nl,
goal(active,holds,nothing,O,P).
rule(5) @
goal(active,on,A,B,C),
phys_object(A,E,F,floor,G,H,I),
monkey(K,L,M) ==>
K\==E
|
goal(active,at,nothing,O,E).
rule(6) @
phys_object(A,B,C,floor,D,E,F),
monkey(B,A,H) \
goal(active,on,A,J,K) <=>
write('Monkey is already on '),
write(A),
nl,
goal(satisfied,on,A,J,K).
rule(7) @
goal(active,holds,nothing,A,B),
monkey(D,E,F),
phys_object(F,H,I,J,K,L,M) <=>
F\==nothing
|
write('Drop '),
write(F),
nl,
goal(satisfied,holds,nothing,A,B),
monkey(D,E,nothing),
phys_object(F,H,I,floor,K,L,M).
rule(8) @
goal(active,holds,nothing,A,B),
monkey(D,E,nothing) ==>
write('Monkey is holding nothing'),
nl,
goal(satisfied,holds,nothing,A,B).
rule(9) @
phys_object(ladder,A,B,floor,C,D,E) \
goal(active,holds,G,H,I),
phys_object(G,A,light,ceiling,K,L,M),
monkey(O,ladder,nothing) <=>
not phys_object(Q,R,S,G,T,U,V)
|
write('Grab '),
write(G),
nl,
monkey(O,ladder,G),
phys_object(G,A,light,nothing,K,L,M),
goal(satisfied,holds,G,H,I).
rule(10) @
goal(active,holds,A,B,C),
phys_object(A,E,light,ceiling,F,G,H),
phys_object(ladder,E,J,floor,K,L,M),
monkey(O,P,Q) ==>
P\==ladder
|
goal(active,on,ladder,S,T).
rule(11) @
goal(active,holds,A,B,C),
phys_object(A,E,light,ceiling,F,G,H),
phys_object(ladder,J,K,L,M,N,O) ==>
J\==E,
not goal(active,at,ladder,Q,E)
|
goal(active,at,ladder,R,E).
rule(12) @
goal(active,holds,A,B,C),
phys_object(A,E,light,F,G,H,I),
monkey(E,floor,nothing) <=>
F\==ceiling,
not phys_object(L,M,N,A,O,P,Q)
|
write('Grab '),
write(A),
nl,
phys_object(A,E,light,nothing,G,H,I),
monkey(E,floor,A),
goal(satisfied,holds,A,B,C).
rule(13) @
goal(active,holds,A,B,C),
phys_object(A,E,light,F,G,H,I),
monkey(E,F,K) ==>
F\==ceiling,
F\==floor
|
goal(active,on,floor,M,N).
rule(14) @
goal(active,holds,A,B,C),
phys_object(A,E,light,F,G,H,I),
monkey(K,L,M) ==>
F\==ceiling,
K\==E,
not goal(active,at,nothing,O,P)
|
goal(active,at,nothing,Q,E).
rule(15) @
goal(active,holds,A,B,C),
phys_object(A,E,light,F,G,H,I),
monkey(E,K,L) ==>
L\==nothing,
L\==A,
not goal(active,holds,nothing,N,O)
|
goal(active,holds,nothing,P,Q).
rule(16) @
goal(active,at,A,B,C),
monkey(E,floor,A),
phys_object(A,G,H,I,J,K,L) <=>
E\==C
|
write('Move '),
write(A),
write(' to '),
write(C),
nl,
phys_object(A,C,H,I,J,K,L),
monkey(C,floor,A),
goal(satisfied,at,A,B,C).
rule(17) @
goal(active,at,A,B,C),
monkey(E,F,A),
phys_object(A,H,I,J,K,L,M) ==>
F\==floor,
H\==C,
not goal(active,on,floor,O,P)
|
goal(active,on,floor,Q,R).
rule(18) @
goal(active,at,A,B,C),
phys_object(A,E,light,F,G,H,I),
monkey(K,L,M) ==>
E\==C,
M\==A,
not goal(active,holds,A,O,P)
|
goal(active,holds,A,Q,R).
rule(19) @
phys_object(A,B,light,C,D,E,F) \
goal(active,at,A,H,B) <=>
write('The object '),
write(A),
write(' is already at '),
write(B),
nl,
goal(satisfied,at,A,H,B).
rule(20) @
goal(active,at,nothing,A,B),
monkey(B,floor,nothing) <=>
write('Walk to '),
write(B),
nl,
monkey(B,floor,nothing),
goal(satisfied,at,nothing,A,B).
rule(21) @
goal(active,at,nothing,A,B),
monkey(D,floor,E),
phys_object(E,G,H,I,J,K,L) <=>
D\==B
|
write('Walk to '),
write(B),
write(' carrying '),
write(E),
nl,
monkey(B,floor,E),
phys_object(E,B,H,I,J,K,L),
goal(satisfied,at,nothing,A,B).
rule(22) @
goal(active,at,nothing,A,B),
monkey(D,E,F) ==>
E\==floor,
D\==B
|
goal(active,on,floor,H,I).
rule(23) @
monkey(A,B,C) \
goal(active,at,nothing,E,A) <=>
write('Monkey is already at '),
write(A),
nl,
goal(satisfied,at,nothing,E,A).
rule(24) @
goal(satisfied,A,B,C,D) ==>
not goal(active,F,G,H,I),
not found
|
write('CONGRATULATIONS the goals are satisfied'),
nl,
found.
rule(25) @
goal(active,holds,A,B,C),
phys_object(A,E,light,nothing,F,G,H),
monkey(E,J,A) ==>
write('Object '),
write(A),
write(' is already being held'),
nl,
goal(satisfied,holds,A,B,C).
end_of_file.

124
CHR/chr/examples/osf.pl
View File

@ -1,124 +0,0 @@
% Order Sorted Feature Constraints -------------------------------------------
% following DEC-PRL Research Report 32, May 1993, by H. Ait-Kaci, A. Podelski
% and S.C. Goldstein on "Order-Sorted Feature Theory Unification"
% see also cft.pl, kl-one.pl, type.pl
% 940603 ECRC, 980211, 980312 Thom Fruehwirth LMU for Sicstus CHR
:- use_module( library(chr)).
handler osf.
option(already_in_store, on).
operator(150,xfx,'=>'). % label has value constraint
operator(100,xfx,'::'). % sort constraint
operator(100,xfx,'..'). % feature constraint
operator(450,xfx,'##'). % equality constraint
operator(450,fx,'theory'). % OSF theory clause
constraints (::)/2, (##)/2.
% OSF Term Dissolution
X::T <=> nonvar(T), \+ atomic(T) | dissolve(X,T).
dissolve(X,T):- T=..[S|Ls], X::S, dissolve1(X,Ls).
dissolve1(X,[]).
dissolve1(X,[L1=>T1|Ls]):- X..L1##Y, dissolve0(Y,T1), dissolve1(X,Ls).
dissolve0(Y,T):- var(T), !, Y=T.
dissolve0(Y,X::T):- !, Y=X, dissolve(Y,T).
dissolve0(Y,T):- Y::T.
% OSF Clause Normalization Rules
% see Figure 1, p. 6 of DEC-PRL RR 32
% (1) sort intersection
X::S1, X::S2 <=> atomic(S1),atomic(S2) | sort_intersection(S1,S2,S3), X::S3.
% (2) inconsistent sort
% reflected down to built-in constraints true and fail
X::bot <=> fail.
X::top <=> true.
% (3) variable elimination
% reflected down to built-in constraint for equality
X##Y <=> var(X) | X=Y.
% (4) feature decomposition
X..L##Y \ X..L##Z <=> Y=Z.
% OSF Theory Unification
% preliminary version, theory represented by Prolog facts
X::S#Id, X.._##_ ==> atomic(S),theory X::T,functor(T,S,_) | X::T.
% EXAMPLES ---------------------------------------------------------------
% cyclic structure, page 1, DEC-PRL RR 32
eg1(P):-
P::person(name=>id(first=>string,
last=>S::string),
age=>30,
spouse=>person(name=>id(last=>S),
spouse=>P)).
% cyclic structure, p. 3, DEC-PRL RR 32
eg2(X):-
X::cons(head=>1,tail=>X).
eg2a(X):- % same as eg2(X)
X::cons(head=>1,tail=>X), X::cons(head=>1,tail=>cons(head=>1,tail=>X)).
% p.17, DEC-PRL RR 32
eg3(X):-
X::s1(l1=>s),X::s2(l2=>s).
sort_intersection(s1,s2,s3).
sort_intersection(s2,s1,s3).
% non-empty theory
theory YS1::s1(l1=>Y1::s).
theory YS2::s2(l2=>Y2::s).
theory YS3::s3(l1=>Y3::s(l=>Y4::s),l2=>Y3).
theory YS::s(l=>Y5::s).
/*
| ?- eg1(X) ; eg2(X) ; eg2a(X) ; eg3(X).
X::person,
X..name##_A,
_A::id,
_A..first##_B,
_B::string,
_A..last##_C,
_C::string,
X..age##_D,
_D::30,
X..spouse##_E,
_E::person,
_E..name##_F,
_F::id,
_F..last##_C,
_E..spouse##X ? ;
X::cons,
X..head##_A,
_A::1,
X..tail##X ? ;
X::cons,
X..head##_A,
_A::1,
X..tail##X ? ;
X..l1##_A,
_A::s,
X::s3,
_A..l##_B,
_B::s,
X..l2##_A ?
*/
% end of handler osf ----------------------------------------------------------

100
CHR/chr/examples/oztype.pl
View File

@ -1,100 +0,0 @@
% rational tree handler with diseqquality and OZ type constraint, intersection
% thom fruehwirth ECRC 1993,1995
%
%
% 950519 added OZ type constraint, equalit ~ from tree.chr
% 980211 Thom Fruehwirth LMU for Sicstus CHR
:- use_module( library(chr)).
handler oztype.
option(debug_compile,on).
option(already_in_store, on).
option(already_in_heads, off).
option(check_guard_bindings, off).
constraints (~)/2, (':<')/2, ('&&')/2.
operator(100,xfx,(~)). % equality
operator(100,xfx,(':<')). % type constraint of Oz
operator(110,xfx,('&&')). % type intersection, precedence choosen so that
% need global order on variables
:- use_module( library('chr/ordering'), [globalize/1,var_compare/3]).
% var is smaller than any non-var term
lt(X,Y):- (var(X),var(Y) -> globalize(X),globalize(Y),var_compare(<,X,Y) ; X@<Y).
le(X,Y):- (var(X) -> true ; X@=<Y).
% equality ~ -----------------------------------------------------------------
% can be optimised using list of variables that are equated instead of
% seperate constraints, i.e. [X1,...Xn] ~ Term, to avoid dereferencing
ident @ T ~ T <=> true.
decompose @ T1 ~ T2 <=> nonvar(T1),nonvar(T2) |
same_functor(T1,T2),
T1=..[F|L1],T2=..[F|L2],
equate(L1,L2).
orient @ T ~ X <=> lt(X,T) | X ~ T.
simplify @ X ~ T1 \ X ~ T2 <=> le(T1,T2) | T1 ~ T2.
same_functor(T1,T2):- functor(T1,F,N),functor(T2,F,N).
equate([],[]).
equate([X|L1],[Y|L2]):- X ~ Y, equate(L1,L2).
% type constraint :< ---------------------------------------------------------
% similar to equality ~
% plus standard axioms for order relation plus intersection &&
% types are not cyclic
type_identity @ XT :< XT <=> true.
type_decompose @ T1 :< T2 <=> nonvar(T1),nonvar(T2) |
same_functor(T1,T2),
T1=..[_|L1],T2=..[_|L2],
contain(L1,L2).
type_simplify1 @ X ~ T1 \ X :< T2 <=> var(X) | T1 :< T2.
type_simplify2 @ X ~ T1 \ T2 :< X <=> var(X) | T2 :< T1.
type_transitiv @ T1 :< Y, Y :< T2 ==> var(Y) | T1 :< T2.
type_intersect @ X :< T1, X :< T2 <=> nonvar(T1),nonvar(T2) |
same_functor(T1,T2),
T1=..[F|L1],T2=..[F|L2],
type_intersect(L1,L2,L3),
T3=..[F|L3],
X :< T3.
contain([],[]).
contain([X|L1],[Y|L2]):-
X :< Y,
contain(L1,L2).
type_intersect([],[],[]).
type_intersect([X|L1],[Y|L2],[Z|L3]):-
Z~X&&Y, % was Z :< X, Z :< Y before
type_intersect(L1,L2,L3).
% X~Y&&Z parses as (X~Y)&&Z, so it does not match X~T
type_functional @ Z1~X&&Y \ Z2~X&&Y <=> Z1=Z2.
type_functional @ Z1~Y&&X \ Z2~X&&Y <=> Z1=Z2.
type_propagate @ Z~X&&Y ==> Z :< X, Z :< Y.
/*
:- f(a,b):<f(X,X). % succeeds - X is a "top" ('a hole')
a:<X,b:<X.
:- Y~f(U),Z~f(X),X:<Y,X:<Z. % succeeds
Y~f(U),Z~f(X),UX~X&&U,X:<f(UX),UX:<X,UX:<U,UX:<f(UX)
:- Y~f(U),U~a,Z~f(X),X:<Y,X:<Z. % fails
:- X:<Y,X~f(X),X:<f(Y).
X~f(X), f(X):<Y % simplifies nicely
:- X:<Y,Y~f(U),U~a,Z~f(X),X:<Z. % fails
:- X~Y,U:<X,Z:<a,U:<Z,Y:<b. % fails
:- X:<Y,X:<Z,Y~a,Z~b. % fails
:- X:<Y,X:<Z,Y~f(Y,U),Z~f(Z,V),U~a,V~b. % fails, loops without type_functional
:- X:<f(X,Y), X~f(X1,U), X1~f(X11,U1), U1~g(U), a:<U, b:<U. % succeeds
:- X~ f(X,Y), X~f(X1,U), X1~f(X11,U1), U1~g(U), a:<U, b:<U. % fails
*/
% end of handler oztype =======================================================

52
CHR/chr/examples/path.pl
View File

@ -1,52 +0,0 @@
% PATH CONSISTENCY, simple
% thom fruehwirth ECRC 941201, simplified version of time-pc.chr
% 980311 Thom Fruehwirth, LMU, adapted to Sicstus CHR
:- use_module(library(chr)).
handler path.
option(already_in_heads,on).
constraints con/3.
% con(X,Y,C) means that constraint C holds between variables X and Y
intersect_xy_xy @ con(X, Y, C1), con(X, Y, C2) <=>
inter(C1, C2, C3),
con(X,Y,C3).
intersect_xy_yx @ con(X, Y, C1), con(Y, X, CR) <=>
invert(CR, C2),
inter(C1, C2, C3),
con(X,Y,C3).
propagate_xy_yz @ con(X, Y, C1), con(Y, Z, C2) ==>
trans(C1, C2, C3)
|
con(X, Z, C3).
propagate_xy_xz @ con(X, Y, CR), con(X, Z, C2) ==>
invert(CR,C1),
trans(C1, C2, C3)
|
con(Y, Z, C3).
propagate_xy_zy @ con(X, Y, C1), con(Z, Y, CR) ==>
invert(CR,C2),
trans(C1, C2, C3)
|
con(X, Z, C3).
% Example ---------------------------------
% constraints are < and >
invert(<,>).
invert(>,<).
% fail if empty constraint would be produced
inter(C,C,C).
% fail if most general constraint would be produced
trans(C,C,C).
% ?- con(A,B,>),con(A,C,>),con(B,D,>),con(C,D,>).
/*--------------- eof path.pl ----------------------------------------------*/

38
CHR/chr/examples/pathc.pl
View File

@ -1,38 +0,0 @@
% Thom Fruehwirth, LMU, 980129, 980311
:- use_module(library(chr)).
handler pathc.
option(already_in_heads,on).
constraints c/3.
% c(X,Y,N): the distance between variables X and Y is the positive number N
c(I,J,A),c(I,J,B) <=> C is min(A,B), c(I,J,C).
c(I,J,A),c(J,K,B) ==> C is A+B, c(I,K,C).
% Only complete if both c(I,J,D) and c(J,I,D) are present for each constraint
/*
% Queries
c(A,B,D).
c(A,B,2),c(A,B,4).
c(A,B,2),c(B,C,3).
c(A,B,2),c(B,A,1).
c(A,B,2),c(B,A,0).
c(A,B,2),c(A,C,3),c(C,B,2).
c(A,B,2),c(A,C,3),c(C,B,4).
c(A,B,2),c(B,C,3),c(C,A,4).
c(A,B,2),c(B,C,3),c(C,A,4),c(B,A,2),c(C,B,3),c(A,C,4).
*/

66
CHR/chr/examples/primes.pl
View File

@ -1,66 +0,0 @@
% Sieve of eratosthenes to compute primes
% thom fruehwirth 920218-20, 980311
% christian holzbaur 980207 for Sicstus CHR
:- use_module(library(chr)).
handler primes.
% like chemical abstract machine
constraints primes/1, prime/1.
primes(1) <=> true.
primes(N) <=> N>1 | M is N-1, prime(N), primes(M).
absorb(J) @ prime(I) \ prime(J) <=> J mod I =:= 0 | true.
% shorter variant
constraints primes2/1.
primes2(N) ==> N>2 | M is N-1, primes2(M).
absorb2(J) @ primes2(I) \ primes2(J) <=> J mod I =:= 0 | true.
% faster variant
primes1(N):- primes1(2,N).
constraints primes1/2, prime1/1.
primes1(N,M) <=> N> M | true.
primes1(N,M) <=> N=<M | N1 is N+1, prime1(N), primes1(N1,M).
absorb1(J) @ prime1(I) \ prime1(J) <=> J mod I =:= 0 | true.
% faster variant, rule order sensitive
constraints primes3/1, prime3/1.
primes3(N) ==> prime3(2).
primes3(N),prime3(M) <=> M is N+1 | true.
prime3(N) ==> M is N+1, prime3(M).
absorb3(J) @ prime3(I) \ prime3(J) <=> J mod I =:= 0 | true.
% Concurrent program according to Shapiro
constraints primes/2,integers/3,sift/2,filter/3.
primes(N,Ps) <=> integers(2,N,Ns), sift(Ns,Ps).
integers(F,T,Ns) <=> F > T | Ns=[].
integers(F,T,Ns) <=> F =< T | Ns=[F|Ns1], F1 is F+1, integers(F1,T,Ns1).
sift([P|Ns],Ps) <=> Ps=[P|Ps1], filter(Ns,P,Ns1), sift(Ns1,Ps1).
sift([],Ps) <=> Ps=[].
filter([X|In],P,Out) <=> 0 =\= X mod P | Out=[X|Out1], filter(In,P,Out1).
filter([X|In],P,Out) <=> 0 =:= X mod P | filter(In,P,Out).
filter([],P,Out) <=> Out=[].

64
CHR/chr/examples/scheduling.pl
View File

@ -1,64 +0,0 @@
% 980312 Thom Fruehwirth, LMU
:- use_module(library(chr)).
handler scheduling.
option(check_guard_bindings, on).
constraints leq/2, optimize/0.
% leq(X+N,Y) means: task X starts at least N time units before task Y
% assumes leq-relation is non-circular
redundant @ leq(N,Y), leq(M,Y) <=> M=<N | leq(N,Y).
% optimize gives smallest possible value to a variable
optimize @ optimize#Id \ leq(X,Y) <=>
ground(X),var(Y),findall_constraints(Y,leq(_,Y),L),L=[]
|
Y is X
pragma passive(Id).
% classical example --------------------------------------
build_house([Start,A,B,C,D,E,F,G,H,I,J,End]) :-
leq(Start+0,A),
leq(A+7,B),
leq(A+7,D),
leq(B+3,C),
leq(C+1,E),
leq(D+8,E),
leq(C+1,G),
leq(D+8,G),
leq(D+8,F),
leq(C+1,F),
leq(F+1,H),
leq(H+3,I),
leq(G+1,J),
leq(E+2,J),
leq(I+2,J),
leq(J+1,End),
optimize,
Start=0.
/*
| ?- build_house([Start,A,B,C,D,E,F,G,H,I,J,End]).
A = 0,
B = 7,
C = 10,
D = 7,
E = 15,
F = 15,
G = 15,
H = 16,
I = 19,
J = 21,
End = 22,
Start = 0,
optimize ?
*/
% end of handler scheduling

303
CHR/chr/examples/tarski.pl
View File

@ -1,303 +0,0 @@
% geomtric constraints following Tarskis axioms for geometry
% thom fruehwirth ECRC 950722
% thom fruehwirth LMU 980207, 980312 for Sicstus CHR
:- use_module(library(chr)).
handler tarski.
constraints b/3, ol/3.
% b(X,Y,Z) 3 points are different and collinear, on same line in that order
% ol(X,Y,L) <=> X and Y are different points on line L
b(X,Y,Z) <=> ol(X,Y,L),ol(Y,Z,L).
irreflexivity @ ol(X,X,L) <=> fail. % true. % ol(X,L).
turn @ ol(X,Y,(-L)) <=> ol(Y,X,L).
same_line @ ol(X,Y,L1)\ol(X,Y,L2) <=> L1=L2.
same_line @ ol(X,Y,L1)\ol(Y,X,L2) <=> L1\==L2 | L2=(-L1). % turn direction of L2
antisymmetry @ ol(X,Y,L),ol(Y,X,L) ==> X=Y. % corresponds to axiom a1
% transitivity only for points on the same line
transitivity @ ol(X,Y,L),ol(Y,Z,L) ==> ol(X,Z,L). % corresponds to axiom a2
constraints e/4, pd/3.
% e(X,Y,U,V) line segments X-Y and U-V have same nonzero length
% ls(X,Y,D) the different points X and Y have nonzero distance D from each other
e(X,Y,U,V) <=> pd(X,Y,D),pd(U,V,D).
orient_pd @ ol(X,Y,L)\pd(Y,X,D) <=> pd(X,Y,D).
% simple cases
idempotence @ pd(X,Y,D1)\pd(X,Y,D2)<=>D1=D2. % corresponds to axiom a4 and a6
idempotence @ pd(X,Y,D1)\pd(Y,X,D2)<=>D1=D2.
zero @ pd(X,X,D) <=> fail. % corresponds to axiom a5
% more like that is missing
pd(X,Y,D),ol(X,Y,L),pd(X,Z,D),ol(X,Z,L) ==> Y=Z.
pd(X,Y,D),ol(X,Y,L),pd(Z,Y,D),ol(Z,Y,L) ==> Y=Z.
% EXAMPLES =============================================================
% simple 2-dimensional geometric objects (in German)
ld(X,Y,D):- ld(X,Y,D,_L).
ld(X,Y,D,L):- pd(X,Y,D),ol(X,Y,L).
polygon([]).
polygon([_]).
polygon([X,Y|P]):-
ol(X,Y,L),
polygon([Y|P]).
gleichseiter([],D).
gleichseiter([_],D).
gleichseiter([X,Y|P],D):-
pd(X,Y,D),
gleichseiter([Y|P],D).
dreieck(A,B,C):- polygon([A,B,C,A]).
gleichdreieck(A,B,C,W):- dreieck(A,B,C), gleichseiter([A,B,C,A],W).
viereck(A,B,C,D):- polygon([A,B,C,D,A]).
konkaves_viereck(A,B,C,D,E):-
viereck(A,B,C,D),
b(D,E,B), b(A,E,C). %diagonals
quadrat(A,B,C,D,E,U,V):-
konkaves_viereck(A,B,C,D,E),
gleichseiter([A,B,C,D,A],U),
gleichseiter([A,E,C],V),
gleichseiter([D,E,B],V).
rechtdrei(A,B,C,U):-
dreieck(A,B,C),
gleichseiter([A,_,_,B],U), %3*U
gleichseiter([B,_,_,_,C],U), %4*U
gleichseiter([C,_,_,_,_,A],U). %5*U
/*
| ?- b(X,Y,X).
no
| ?- b(X,X,Y).
no
| ?- b(X,Y,Z),b(X,Z,Y).
no
| ?- b(X,Y,Z),b(Z,Y,X).
ol(X,Y,_A),
ol(Y,Z,_A),
ol(X,Z,_A) ?
yes
| ?- b(X,Y,Z),b(X,Y,Z).
ol(X,Y,_A),
ol(Y,Z,_A),
ol(X,Z,_A) ?
| ?- b(X,Y,U),b(Y,Z,U).
ol(X,Y,_A),
ol(Y,U,_A),
ol(X,U,_A),
ol(Y,Z,_A),
ol(Z,U,_A),
ol(X,Z,_A) ?
yes
| ?- b(X,Y,Z),b(X,Y,U).
ol(X,Y,_A),
ol(Y,Z,_A),
ol(X,Z,_A),
ol(Y,U,_A),
ol(X,U,_A) ?
yes
| ?- ol(X,Y,L),ol(X,Z,L).
ol(X,Y,L),
ol(X,Z,L) ?
yes
| ?- ol(X,Y,L),ol(X,Z,L), (ol(Y,Z,L);ol(Z,Y,L)).
ol(X,Y,L),
ol(X,Z,L),
ol(Y,Z,L) ? ;
ol(X,Y,L),
ol(X,Z,L),
ol(Z,Y,L) ? ;
no
| ?- ol(X,Y,L),ol(Y,U,L1),ol(U,V,L).
ol(X,Y,L),
ol(Y,U,L1),
ol(U,V,L) ? ;
no
| ?- ol(X,Y,L),ol(Y,U,L1),ol(U,V,L1).
ol(X,Y,L),
ol(Y,U,L1),
ol(U,V,L1),
ol(Y,V,L1) ?
yes
| ?- ol(V,Y,L),ol(U,Y,L1),ol(U,V,L1).
ol(V,Y,L),
ol(U,Y,L1),
ol(U,V,L1) ? ;
no
*/
/*
| ?- e(X,Y,Y,X).
pd(X,Y,_A) ?
yes
| ?- e(X,Y,X,Y).
pd(X,Y,_A) ?
yes
| ?- e(X,Y,Z,Z).
no
| ?- e(X,Y,A,B),e(X,Y,A,B).
pd(X,Y,_A),
pd(A,B,_A) ?
yes
| ?- e(X,Y,A,B),e(Y,X,B,A).
pd(X,Y,_A),
pd(A,B,_A) ?
yes
| ?- e(X,Y,Z,U),e(X,Y,V,W).
pd(X,Y,_A),
pd(Z,U,_A),
pd(V,W,_A) ?
yes
| ?- pd(X,Y,D1),pd(Y,Z,D2).
pd(X,Y,D1),
pd(Y,Z,D2) ?
yes
| ?- pd(X,Y,D1),pd(Y,Z,D2),ol(X,Y,L),ol(Y,Z,L),pd(X,Z,D3).
pd(X,Y,D1),
pd(Y,Z,D2),
ol(X,Y,L),
ol(Y,Z,L),
ol(X,Z,L),
pd(X,Z,D3) ?
yes
| ?- e(X,Y,U,V),e(X,Y,X,U).
pd(X,Y,_A),
pd(U,V,_A),
pd(X,U,_A) ?
yes
| ?- e(X,Y,U,V),e(X,Y,X,U),b(X,Y,U).
no
| ?- e(X,Y,U,V),e(X,Y,X,U),b(X,Y,V).
pd(X,Y,_A),
pd(U,V,_A),
pd(X,U,_A),
ol(X,Y,_B),
ol(Y,V,_B),
ol(X,V,_B) ?
yes
| ?- e(X,Y,U,V),e(X,Y,X,U),b(X,U,Y).
no
| ?- pd(X,Y,D),pd(Y,Z,D),pd(X,Z,D),ol(X,Y,L),ol(Y,Z,L).
no
| ?- pd(X,Y,D),ol(X,Y,L),pd(X,Z,D),ol(X,Z,L).
Z = Y,
pd(X,Y,D),
ol(X,Y,L) ?
yes
| ?- e(X,Y,X,Z), b(X,Y,Z).
no
| ?- e(X,Y,X,Z), b(X,Y,U), b(X,Z,U).
Z = Y,
pd(X,Y,_A),
ol(X,U,_B),
ol(X,Y,_B),
ol(Y,U,_B) ?
yes
*/
/*
| ?- gleichdreieck(A,B,C,W),gleichdreieck(A,C,D,V),gleichdreieck(B,C,E,U).
V = U,
W = U,
...
% cannot find out that D-C-E is on same line
| ?- konkaves_viereck(A,B,C,D,E),gleichdreieck(A,B,C,W),gleichdreieck(A,B,E,W).
E = C,
| ?- quadrat(A,B,C,D,E,U,V),gleichdreieck(A,B,C,W).
W = U,
% does not know that diagonal is longer than sides
| ?- quadrat(A,B,C,D,E,U,V),gleichdreieck(A,B,C,W),
e(A,D,A,D1), b(E,D1,C).
| ?- quadrat(A,B,C,D,E,U,V),gleichdreieck(A,B,C,W),gleichdreieck(A,B,E,W1).
no
| ?- rechtdrei(A,B,C,U),gleichdreieck(A,B,C,W).
% no constraining, since it is not known that U+U=/=U
*/
% end of file handler tarski.pl -------------------------------------

415
CHR/chr/examples/term.pl
View File

@ -1,415 +0,0 @@
% Prolog term manipulation as constraints
% 931127 ECRC, thom fruehwirth based on ideas from 9203 and 9104
% 980207, 980312 thom fruehwirth LMU adapted for Sicstus CHR
:- use_module(library(chr)).
handler term.
option(already_in_store, off).
option(already_in_heads, off).
option(check_guard_bindings, off).
operator(100,xfx,unif).
T unif [F|L] :- chr_unif(T,F,L).
constraints chr_functor/3, chr_arg/3, chr_unif/3.
chr_functor(T,F,N) <=> (nonvar(T);nonvar(F),nonvar(N)) | functor(T,F,N).
chr_functor(T,T,N) ==> N=0.
chr_functor(T,F,0) ==> T=F.
chr_functor(T,F,N) ==> chr_nonvar(T).
chr_functor(T,F,N) \ chr_functor(T,F1,N1) <=> F1=F,N1=N.
chr_functor(T,F,N), chr_arg(M,T,A) ==> nonvar(N),nonvar(M) | N>=M,N>0.
chr_arg(0,T,A) <=> fail.
chr_arg(N,T,A) <=> nonvar(N),nonvar(T) | arg(N,T,A).
chr_arg(N,T,A) \ chr_arg(N,T,A1) <=> A1=A.
chr_unif(T,F,L) <=> (nonvar(T);nonvar(F),islist(L)) | T=..[F|L].
chr_unif(T,T,L) ==> L=[].
chr_unif(T,F,[]) ==> T=F.
chr_unif(T,F,L) ==> chr_nonvar(T),chr_nonvar(L).
chr_unif(T,F,L) \ chr_unif(T,F1,L1) <=> F1=F,L1=L.
chr_unif(T,F,L) \ chr_unif(T1,F,L) <=> T1=T.
chr_unif(T,F,L) \ chr_functor(T,F1,N) <=> (nonvar(N);islist(L)) | F1=F,length(L,N).
chr_unif(T,F,L) \ chr_arg(M,T,A) <=> nonvar(M) | nth_member(M,L,A).
nth_member(1,[X|_],X).
nth_member(N,[_|L],X):-
gt(N,1), plus(M,1,N), nth_member(M,L,X).
islist([]) ?- true.
islist([X|L]) ?-
islist(L).
constraints chr_var/1, chr_nonvar/1.
chr_var(X) <=> nonvar(X) | fail.
chr_nonvar(X) <=> nonvar(X) | true.
chr_nonvar(X), chr_var(X) <=> fail.
chr_var(X) \ chr_var(X) <=> true.
chr_nonvar(X) \ chr_nonvar(X) <=> true.
constraints plus/3, gt/2.
plus(A,B,C) <=> nonvar(A),nonvar(B) | C is A+B.
plus(A,B,C) <=> nonvar(A),nonvar(C) | B is C-A.
plus(A,B,C) <=> nonvar(B),nonvar(C) | A is C-B.
gt(A,B) <=> nonvar(A),nonvar(B) | A>B.
% Examples =================================================================
% these standard predicates using term manipulation run now backwards as well
% but sometimes this causes nontermination
% constraints needed in the examples
constraints diff/2, diff_list/2.
diff(X,X) <=> fail.
diff_list(V,[]) <=> true.
diff_list(V,L) <=> member(X,L),V==X | fail.
member(X,[Y|L]):- X=Y ; member(X,L).
% two variants of unification by sterling/shapiro
unify1(X,Y):- chr_var(X),chr_var(Y), X=Y.
unify1(X,Y):- chr_var(X),chr_nonvar(Y), X=Y.
unify1(X,Y):- chr_nonvar(X),chr_var(Y), X=Y.
unify1(X,Y):- % chr_nonvar(X),chr_nonvar(Y),
chr_functor(X,F,N),chr_functor(Y,F,N),
unify_args(N,X,Y).
unify_args(0,X,Y).
unify_args(N,X,Y):-
gt(N,0),
plus(N1,1,N),
chr_arg(N,X,A),chr_arg(N,Y,B),
unify1(A,B),
unify_args(N1,X,Y).
/*
| ?- unify1(a,b).
no
| ?- unify1(A,B).
B = A,
chr_var(A) ? ;
B = A,
chr_nonvar(A),
chr_functor(A,A,0) ? ;
chr_nonvar(A),
chr_nonvar(B),
chr_var(_A),
chr_functor(A,_B,1),
chr_functor(B,_B,1),
chr_arg(1,A,_A),
chr_arg(1,B,_A) ?
| ?- unify1(f(a,B),f(B,C)).
B = a,
C = a ? ;
% nontermination
*/
unify2(X,Y):- chr_var(X),chr_var(Y), X=Y.
unify2(X,Y):- chr_var(X),chr_nonvar(Y), X=Y.
unify2(X,Y):- chr_nonvar(X),chr_var(Y), Y=X.
unify2(X,Y):- % chr_nonvar(X),chr_nonvar(Y),
X unif [F|As],Y unif [F|Bs],
unify_list(As,Bs).
unify_list([],[]).
unify_list([A|As],[B|Bs]):-
unify2(A,B),
unify_list(As,Bs).
/*
| ?- unify2(A,B).
B = A,
chr_var(A) ? ;
B = A,
chr_nonvar(A),
chr_unif(A,A,[]) ? ;
B = A,
chr_nonvar(A),
chr_var(_A),
chr_unif(A,_B,[_A]) ? ;
B = A,
chr_nonvar(A),
chr_var(_A),
chr_var(_B),
chr_unif(A,_C,[_A,_B]) ?
| ?- unify2(f(a,B),f(B,C)).
B = a,
C = a ? ;
no
*/
% collecting the variables of a term into a list, groundness and more
varlist(A,Vars):- varlist(A,[],Vars).
varlist(V,L,[V|L]):- chr_var(V),diff_list(V,L).
varlist(V,L,L):- chr_var(V),member(V,L).
varlist(T,L1,L2):-
%chr_nonvar(T),
chr_functor(T,_,N),
varlist(N,T,L1,L2).
varlist(0,T,L,L).
varlist(N,T,L1,L3) :-
gt(N,0),
plus(K,1,N),
chr_arg(N,T,TK),
varlist(TK,L1,L2),
varlist(K,T,L2,L3).
/*
| ?- varlist(f(a,B),L).
L = [B],
chr_var(B) ? ;
L = [],
chr_nonvar(B),
chr_functor(B,B,0) ? ;
L = [_A],
chr_nonvar(B),
chr_var(_A),
chr_functor(B,_B,1),
chr_arg(1,B,_A) ?
| ?- varlist(X,[A,B]).
chr_nonvar(X),
chr_var(B),
chr_var(A),
diff_list(A,[B]),
chr_functor(X,_A,2),
chr_arg(2,X,B),
chr_arg(1,X,A) ? ;
% nontermination
*/
common_var(A,K,V1):-
varlist(A,AV), varlist(K,KV), member(V,AV), member(V,KV).
ground0(A):- varlist(A,[]).
/*
% termination problems
*/
ground1(T):-
%chr_nonvar(T),
chr_functor(T, _, N),
ground1(N, T).
ground1(0, _).
ground1(N, T):-
gt(N,0),
plus(N1,1,N),
chr_arg(N, T, A),
ground1(A),
ground1(N1, T).
/*
| ?- ground1(h(A,b,C)).
chr_nonvar(C),
chr_nonvar(A),
chr_functor(C,C,0),
chr_functor(A,A,0) ? ;
chr_nonvar(C),
chr_nonvar(A),
chr_nonvar(_A),
chr_functor(C,C,0),
chr_functor(A,_B,1),
chr_arg(1,A,_A),
chr_functor(_A,_A,0) ?
*/
ground2(T) :-
%chr_nonvar(T),
T unif [_|Args],
ground2l(Args).
ground2l([]).
ground2l([H|L]) :- ground2(H), ground2l(L).
/*
| ?- ground2(A).
chr_nonvar(A),
chr_unif(A,A,[]) ? ;
chr_nonvar(A),
chr_nonvar(_A),
chr_unif(A,_B,[_A]),
chr_unif(_A,_A,[]) ?
*/
number_vars(Term,N0,N1) :-
var(Term), % chr_var(Term) would fail later
plus(N0,1,N1),
name(N0,Digits),
name('V',[C]),
name(Term,[C|Digits]).
number_vars(Term,N0,N1) :-
%chr_nonvar(Term),
Term unif [_|Args],
number_list(Args,N0,N1).
number_list([],N0,N0).
number_list([H|T],N0,N2) :- number_vars(H,N0,N1), number_list(T,N1,N2).
undupvar(A,B,R,L):- undupvar(A,B,[],R,[],L).
undupvar(V,V,R,[V|R],L,L):- chr_var(V),diff_list(V,R).
undupvar(V,W,R,R,L,[W=V|L]):- chr_var(V),member(V,R).
undupvar(T,S,R1,R3,L1,L3):-
%chr_nonvar(T),chr_nonvar(S),
chr_functor(T,F,N),chr_functor(S,F,N),
undupvar(N,T,S,R1,R3,L1,L3).
undupvar(0,T,S,R,R,L,L).
undupvar(N,T,S,R1,R3,L1,L3):-
gt(N,0),
plus(M,1,N),
chr_arg(N,T,TK),
chr_arg(N,S,TS),
undupvar(TK,TS,R1,R2,L1,L2),
undupvar(M,T,S,R2,R3,L2,L3).
% from comp.lang.prolog on a sequent calculus implementation
% substitute(P, X, Y, Q) substitutes instances of X in P with Y, producing Q.
substitute(P1, K1, K2, P2) :-
P1 = K1, P2 = K2
;
diff(P1,K1),
%chr_nonvar(P1),chr_nonvar(P2),
P1 unif [F|Args1],
P2 unif [F|Args2],
substitute_list(Args1, K1, K2, Args2).
substitute_list([], _, _, []).
substitute_list([H1|T1], K1, K2, [H2|T2]) :-
substitute(H1, K1, K2, H2),
substitute_list(T1, K1, K2, T2).
% from comp.lang.prolog on heaps and trees
% uses is/2
%pos(Head,t(Head,Rel,L,[],0)-[], Nc, N0-N2):- /* leaf node */
% atomic(Head),
% !,
% string_length1(Head,L),
% N2 is N0+L,
% Rel is L//2, /* middle of the node */
% Nc is (N0+N2)//2. /* center over node */
pos(X,t(Head,Rel,L,Centers,Adj)-A, Nc, N0-N2):- /* non-leaf node */
%chr_nonvar(X),
X unif [Head|Args],
pos_list(Args,A,Centers,N0-N1),
string_length1(Head,L),
posdiff(N1-N0,L,Error),
Adj is (Error+((N1-N0) mod 2))//2,
N2 is N1+Error,
Rel is L//2, /* middle of the node */
Nc is (N0+N2)//2.
pos_list([], [], [], N-N).
%pos_list([H], [A], [Center], N-N1) :- !,
% pos(H,A,Center,N-N1).
pos_list([H|T],[A|Args],[C|Centers],N0-Nn):-
pos( H, A, C, N0-N1),
plus(N1,2,N2), %N2 is N1+2,
pos_list(T,Args,Centers,N2-Nn).
string_length1(X,L):- atomic(X), name(X,S), length(S,L).
posdiff(Expr,L,0):- Adj is L-Expr, Adj =< 0.
posdiff(Expr,L,Adj):- Adj is L-Expr, Adj > 0.
% lsu(A,B,G): the least specific unifier of A and B is G
% joachims schimpfs code modified by thom
lsu(A, B, G) :-
map(A, B, G, [], Map),
sort(0, =<, Map, SortedMap),
unify_duplicates(SortedMap).
map(A, B, G, Map, NewMap) :-
%chr_nonvar(A),chr_nonvar(B),
chr_functor(A, Name, Arity),
chr_functor(B, Name, Arity),
chr_functor(G, Name, Arity),
map_arg(A, B, G, Map, NewMap, Arity-0).
map(A, B, G, Map, [subst(A, B, G)| Map]):-
chr_var(A)
;
chr_var(B)
;
%chr_nonvar(A),chr_nonvar(B),
chr_functor(A, Name1, Arity1),
chr_functor(B, Name2, Arity2),
(diff(Name1,Name2);diff(Arity1,Arity2)).
map_arg(A, B, G, Map, NewMap, Ar-N) :-
Ar=N,
Map = NewMap.
map_arg(A, B, G, Map0, NewMap, Ar-N) :-
gt(Ar,N),
plus(N,1,N1),
chr_arg(N1, A, An),
chr_arg(N1, B, Bn),
chr_arg(N1, G, Gn),
map(An, Bn, Gn, Map0, Map1),
map_arg(A, B, G, Map1, NewMap, Ar-N1).
unify_duplicates([subst(A1, B1, G1)|T]) :-
T = [subst(A2, B2, G2)|_],
( A1 = A2, B1 = B2, G1 = G2 ; diff(A1,A2) ; diff(B1,B2)),
unify_duplicates(T).
unify_duplicates([T]).
unify_duplicates([]).
% end of handler term

107
CHR/chr/examples/time-pc.pl
View File

@ -1,107 +0,0 @@
% PATH CONSISTENCY to be used with time.pl
% thom fruehwirth ECRC 921030,930212,930802,930804,930908,931216,931223
% christian holzbaur 961022 more mods for Sicstus
% thom fruehwirth LMU 980206, 980312
:- use_module(library(chr)).
:- use_module( library('chr/ordering'), [globalize/1,var_compare/3]).
nonground( X) :- \+ ground( X).
handler path_consistency.
constraints arc/4, path/6.
% arc(X,Y,L,T) there is an arc in the constraint network between variables X and Y with constraint L of type T
% path(N,X,Y,L,T,I) there is a path in the constraint network between variables X and Y with constraint L of type T
%% start up
add_path @
arc(X,Y,L,T) <=> ground(L),ground(T),length(L,N) |
globalize(X-Y), % attach attribute to vars to have order on them
path(N,X,Y,L,T,1).
%% ground case
ground @
path(N,X,Y,L,T,I) <=> ground(X-Y-L-T) | path1(N,X,Y,L,T,I).
%% simple cases
empty @
path(N,X,Y,L,T,I) <=> empty(N,L,T) | fail.
universal @
path(N,X,Y,L,T,I) <=> universal(N,L,T) | true.
equality @
path(N,X,X,L,T,I) <=> equality(L,T).
unify @
path(1,X,Y,L,T,I) <=> unique(L),equality(L,T) | X=Y. % can cause problems with var order
%% special cases for finite domains
findom_unique @
path(1,X,Y,L,p-p,I) <=> number(X),unique(L) | bind_value(X,Y,L).
findom_x @
path(N,X,Y,L,p-p,I) <=> number(X),X=\=0
|
shift_interval(X,L,L1),
path(N,0,Y,L1,p-p,I).
findom_y @
path(N,Y,X,L,p-p,I) <=> number(X)
|
equality([Eq],p-p),transl(L,L2,[Eq],p-p-p), % invert path
shift_interval(X,L2,L1),
path(N,0,Y,L1,p-p,I).
%% intersection (has to come before transitivity)
intersect_xy_xy @
path(N1, X, Y, L1, U-V, I), path(N2, X, Y, L2, U-V, J) <=> % 10
intersection(L1, L2, L3, U-V),
length(L3, N3),
K is min(I, J),
path(N3, X, Y, L3, U-V, K)
pragma already_in_heads.
intersect_yx_xy @
path(N1, Y, X, L1, U-V, I), path(N2, X, Y, L, V-U, J) <=> % 11
equality([Eq], V-V), transl(L, L2, [Eq], V-U-V), % invert 2nd path
intersection(L1, L2, L3, U-V),
length(L3, N3),
K is min(I, J),
path(N3, Y, X, L3, U-V, K).
%% transitivity
propagate_xy_yz @
path(N1, X, Y, L1, U-V, I), path(N2, Y, Z, L2, V-W, J) ==>
nonground(Y),
J=1, (I=1 -> var_compare( <, X, Z) ; true) % or J=1 or N2=1 or X@<Z
|
transl(L1, L2, L3, U-V-W),
length(L3, M),
K is I+J,
path(M, X, Z, L3, U-W, K).
propagate_xy_xz @
path(N1, X, Y, L1, U-V, I), path(N2, X, Z, L3, U-W, J) ==>
nonground(X),
min(I, J)=:=1, var_compare( <, Y, Z) % or J=1 or N2=1
|
transl(L1, L2, L3, U-V-W),
length(L2, M),
K is I+J,
path(M, Y, Z, L2, V-W, K).
propagate_xy_zy @
path(N1, X, Y, L3, U-V, I), path(N2, Z, Y, L2, W-V, J) ==>
nonground(Y),
min(I, J)=:=1, var_compare( <, X, Z) % or J=1 or N2=1
|
transl(L1, L2, L3, U-W-V),
length(L1, M),
K is I+J,
path(M, X, Z, L1, U-W, K).
%% labeling by choice of primitive relation
constraints labeling/0.
labeling, path(N, X, Y, L, T, I)#Id <=> N>1 |
member(R, L),
path(1, X, Y, [R], T, I),
labeling
pragma passive(Id).
/*--------------- eof pc.chr ------------------------------------------------*/

162
CHR/chr/examples/time-point.pl
View File

@ -1,162 +0,0 @@
/* time point constraints */
% Thom Fruehwirth ECRC 1991-92, 931223, LMU 961028, 980312
% 961105 Christian Holzbaur, SICStus mods
:- use_module(library(chr)).
handler time_point.
operator(700,xfy,'=<+').
operator(700,xfy,'=<*').
constraints (=<+)/2, (=<*)/2.
% A=<*Y=<*B means: time-point Y is between A and B which are positive numbers
% C=<+Y-Z=<+D means: distance of timepoints Y and Z is between C and D whcih are positive numbers
% start(X) means: time-point X has value zero
start(X):- 0=<*X=<*0.
inconsistent @
A=<*X=<*B <=> A>B | fail.
intersect @
A=<*Y=<*B , C=<*Y=<*D <=> AC is max(A,C), BD is min(B,D), AC=<*Y=<*BD
pragma already_in_heads.
propagate_forward @
A=<*Y=<*B,C=<+Y-Z=<+D ==> AC is A+C, BD is B+D, AC=<*Z=<*BD.
propagate_backward @
A=<*Y=<*B,C=<+Z-Y=<+D ==> AC is A-D, BD is B-C, AC=<*Z=<*BD.
% EXAMPLES using RANDOM GENERATOR ------------------------------------------
% Park Miller rnd random generator
% careful: 0,2147483647 is a fixpoint
:- setval( rnd, 2183).
rand( X) :-
getval( rnd, X),
pm_randstep( X, Y),
setval( rnd, Y).
pm_randstep( State0, State1) :-
Hi is State0 // 44488,
Lo is State0 mod 44488,
Test is 48271*Lo - 3399*Hi,
( Test > 0 -> State1=Test ; State1 is Test+2147483647 ).
pm_test :- pm_test( 10000, 1).
pm_test( 0, S) :- !, S=399268537.
pm_test( N, S) :-
N1 is N-1,
pm_randstep( S, T),
pm_test( N1, T).
% random example generator
% M is number of constraints randomly generated
test(M):- N is M+1,
length(L,N),
getval( rnd, Seed),
print( redo_with(Seed)), nl,
L=[X|_],
start(X),
gen_cnstr(L,1),
all_cnstr(L,2).
gen_cnstr([],_).
gen_cnstr([_],_).
gen_cnstr([X,Y|L],N):- cnstr(N,A,B),
write(A=<+X-Y=<+B),nl,
A=<+X-Y=<+B,
gen_cnstr([Y|L],N).
cnstr(N,A,B):- rand(I), A is I mod (20*N), rand(J), B is J mod (20*N) + 10.
all_cnstr([],_).
all_cnstr([_],_).
all_cnstr(L,N):-
L=[_,_|_], random_list(L,L1), gen_cnstr(L1,N), M is N+1,
all_cnstr(L1,M).
random_list([],[]).
random_list([N|L],R):- rand(X), 0 is (X mod 3), !, random_list(L,R).
random_list([N|L],[N|R]):- random_list(L,R).
/*
% More Examples
:- start(X),3=<+X-Y=<+10,4=<+Y-Z=<+5.
0=<*X=<*0,
3=<+X-Y=<+10,
3=<*Y=<*10,
4=<+Y-Z=<+5,
7=<*Z=<*15 ?
:- start(E),
10 =<+ E - F =<+ 20,
10 =<+ H - G =<+ 20,
30 =<+ F - G =<+ 40,
40 =<+ H - I =<+ 50,
60 =<+ E - I =<+ 70.
0=<*E=<*0,
10=<+E-F=<+20,
10=<*F=<*20,
10=<+H-G=<+20,
30=<+F-G=<+40,
40=<+H-I=<+50,
60=<+E-I=<+70,
60=<*I=<*70,
20=<*H=<*30,
40=<*G=<*50 ?
:- start(E),
10 =<+ E - F =<+ 20,
10 =<+ H - G =<+ 20,
30 =<+ F - G =<+ 40,
40 =<+ H - I =<+ 50,
60 =<+ E - I =<+ 120.
0=<*E=<*0,
10=<+E-F=<+20,
10=<*F=<*20,
10=<+H-G=<+20,
30=<+F-G=<+40,
40=<*G=<*60,
20=<*H=<*50,
40=<+H-I=<+50,
60=<*I=<*100,
60=<+E-I=<+120 ?
:- start(E),
10 =<+ E - F =<+ 20,
10 =<+ H - G =<+ 20,
30 =<+ F - G =<+ 40,
40 =<+ H - I =<+ 50,
50 =<+ E - I =<+ 60.
0=<*E=<*0,
10=<+E-F=<+20,
10=<+H-G=<+20,
30=<+F-G=<+40,
40=<+H-I=<+50,
50=<+E-I=<+60,
60=<*I=<*60,
20=<*H=<*20,
40=<*G=<*40,
10=<*F=<*10 ?
:- start(A),14.3=<+A-B=<+17.5, 14.3=<+A-B=<+16.3, 12.2=<+B-C=<+14.5.
14.3=<+A-B=<+17.5,
0.0=<*A=<*0.0,
14.3=<+A-B=<+16.3,
14.3=<*B=<*16.3,
12.2=<+B-C=<+14.5,
26.5=<*C=<*30.8 ?
*/

129
CHR/chr/examples/time-rnd.pl
View File

@ -1,129 +0,0 @@
% random test generator for time.chr
% thom fruehwirth LMU 961022
% call test(N) with small N
/*
Allens interval constraints
type i-i
[after, before, contains, during, equals, finished_by, finishes, meets, met_by, overlapped_by, overlaps, started_by, starts].
time point constraints
type p-p
[le,eq,ge] or any list of interval distances, e.g. [1-2,3-5, 6-11]
point-interval constraints
type p-i [before,starts,during,finishes,after]
type i-p [after,started_by,contains,finished_by,before]
set constraints
type s-s
not fully specified
*/
:- ( current_module( prolog) -> use_module( library('chr/getval')) ; true ).
:- setval( rnd, 2183).
rand( X) :-
getval( rnd, X),
pm_randstep( X, Y),
setval( rnd, Y).
%
% Park Miller rnd
% careful: 0,2147483647 is a fixpoint
%
pm_randstep( State0, State1) :-
Hi is State0 // 44488,
Lo is State0 mod 44488,
Test is 48271*Lo - 3399*Hi,
( Test > 0 -> State1=Test ; State1 is Test+2147483647 ).
pm_test :- pm_test( 10000, 1).
pm_test( 0, S) :- !, S=399268537.
pm_test( N, S) :-
N1 is N-1,
pm_randstep( S, T),
pm_test( N1, T).
cnstr1([after, before, contains, during, equals, finished_by, finishes, meets, met_by, overlapped_by, overlaps, started_by, starts], i-i).
cnstr1([le,eq,ge],p-p):- rand(I), 0 is I mod 2. % fail sometimes to try more
cnstr1([before,starts,during,finishes,after],p-i).
cnstr1([after,started_by,contains,finished_by,before],i-p).
cnstr(L,T):- cnstr1(L1,T), rand(I), 0 is I mod 2, random_list(L1,L).
cnstr(L,p-p):- rand(I), J is (I mod 20)+10, length(L,J),
pair_list(L1,L),
rand(X), Y is (X mod 100)-50, L1=[Y|_], random_list(L1).
random_list([],[]).
random_list([N|L],R):- rand(X), 0 is (X mod 3), !, random_list(L,R).
random_list([N|L],[N|R]):- random_list(L,R).
random_list([]).
random_list([N]).
random_list([N,Y|L]):- rand(X), Y is N+(X mod 10), random_list([Y|L]).
pair_list([],[]).
pair_list([N,M|L],[N-M|R]):- pair_list(L,R).
gen_cnstr([]).
gen_cnstr([_]).
gen_cnstr([X-A,Y-B|L]):- T=A-B, cnstr(L1,T),
% arc(X,Y,L1,T),
write(arc(X,Y,L1,T)),write(','), nl,
gen_cnstr([Y-B|L]).
all_cnstr([]).
all_cnstr([_]).
all_cnstr(L):- L=[_,_|_], random_list(L,L1), gen_cnstr(L1), all_cnstr(L1).
test(N):- length(L,N),
%T=[p,p,p,p,p,i,p,p,i,i,i,i,p,i,p,i,p,i,p,p,p,p|T],
getval( rnd, Seed),
print( redo_with(Seed)),
nl,
gen_cnstr(L),
all_cnstr(L),
nl,
css( Css),
nl,
pl( Css),
fail.
css( Css) :-
current_module( prolog), % SICStus
!,
findall_constraints( _, C),
cs( C, Cs),
sort( Cs, Css).
css( Css) :-
current_module( eclipse),
findall( C, chr_get_constraint(C), Cs),
sort( Cs, Css).
cs( [], []).
cs( [C#_|Cs], [C|Ts]) :-
cs( Cs, Ts).
pl( []).
pl( [C|Cs]) :-
print( C), write(','), nl,
pl( Cs).
/*
arc(_231,_226,[34-43,52-55,62-68,72-79,84-85,93-93,100-102,103-108,114-120,124-132,135-144,149-158,165-173,174-180,187-196,204-204,209-217,223-225,229-230,237-243,249-250,256-260,263-270],p-p),
arc(_226,_6963,[le],p-p),
arc(_231,_226,[28-33,38-45,45-54,59-64,64-68,71-71,78-86,92-100,103-104,109-109,116-116,122-129,138-139,146-149,149-158,159-167,167-172],p-p),
arc(_231,_226,[-22- -14,-12- -4,-3-2,11-20,27-33,37-38,47-49,49-51,51-54,62-70,72-77,81-83,87-95,98-105,109-115,124-129,134-140,149-158,167-175,179-181,184-189,189-194,195-195],p-p),
arc(_231,_226,[le,ge],p-p),
arc(_231,_226,[28-35,42-50,59-60,63-69,78-81,81-82,85-92,95-97,98-100,102-107,107-114,114-114,115-123,127-130,138-143,148-151,151-155,163-170,172-179,183-184,186-190,192-198,206-206,206-213,217-217,218-223,226-227,230-232],p-p)
*/

444
CHR/chr/examples/time.pl
View File

@ -1,444 +0,0 @@
% TEMPORAL REASONING
% thom fruehwirth ECRC 920721
% follows work by Itay Meiri AAAI 1991
% uses path concistency handler pc.chr
% 930908 updated and modified for new CHR version
% Christian Holzbaur mods for SICStus (e.g. delay -> block/when)
:- use_module( library(chr)).
:- use_module( library(lists), [member/2,memberchk/2]).
:- multifile user:goal_expansion/3.
%
user:goal_expansion( once(G), _, (G->true)).
:- ensure_loaded('time-pc'). % get compiled path consistency handler
%% domain specific predicates ------------------------------------------------
inf( 3.40282e38).
minf( -3.40282e38).
sup( 1.0e-45).
msup( -1.0e-45).
path1(1,X,Y,[R],p-p,I):- check_pp(X,Y,R).
path1(1,X,Y,[R],p-i,I):- check_pi(X,Y,R).
path1(1,X,Y,[R],i-p,I):- check_ip(Y,X,R).
path1(1,X,Y,[R],i-i,I):- check_ii(X,Y,R).
:-block empty(-,-,?).
%
empty(0,[],T).
:- block universal(-,?,?), universal(?,-,?), universal(?,?,-).
%
universal(N,L,T):-
(is_quantl(L) ->
inf(Inf), minf(Minf),
L=[A-B],(A=<Minf),(Inf=<B)
;
T=p-p -> % 930212 to account for finite domains
sort(L,[eq, ge, le])
;
size(T,N)
),
!.
size(i-i,13).
size(p-p,3).
size(p-i,5).
size(i-p,5).
size(s-s,5).
:- block equality(?,-), equality(-,?).
%
equality(L,i-i):- !, member(equals,L).
equality(L,s-s):- !, member(eq,L).
equality(L,p-p):-
(is_quall(L) -> % succeeds also if var-case: dirty!!
member(E,L),(E=eq;number(E),E=:=0) % 930212
;
member(A-B,L),
(A=0,B=0 ; (A=<0),(0=<B))
),
!.
unique( L) :- when( ground(L), unique_g(L)).
unique_g([A-B]):- !,(A=:=B).
unique_g([A]).
% 930212 for finite domains
bind_value(X,Y,[R]):- (R=V-_;R=V)->(Y=:=X+V).
shift_interval(X,[],[]).
shift_interval(X,[A-C|L1],[B-D|L2]):- !,
B is A-X, D is C-X,
shift_interval(X,L1,L2).
shift_interval(X,[A|L1],[B|L2]):-
B is A-X,
shift_interval(X,L1,L2).
:- block intersection(-,?,?,?), intersection(?,-,?,?).
%
intersection(L1,L2,L3,T):- qtype(L1,Q1),qtype(L2,Q2),
((Q1==quall,Q2==quall) ->
intersection(L1,L2,L3)
;
qualquant(L1,Q1,LQ1),qualquant(L2,Q2,LQ2),
interint(LQ1,LQ2,L3)
),
!.
intersection([], _, []).
intersection([Head|L1tail], L2, L3) :-
memberchk(Head, L2),
!,
L3 = [Head|L3tail],
intersection(L1tail, L2, L3tail).
intersection([_|L1tail], L2, L3) :-
intersection(L1tail, L2, L3).
% interint([1-2,4-5,6-9],[2-3,3-11],L).
interint([],L,[]).
interint(L,[],[]):- L=[_|_].
interint([A|L1],[B|L2],L3):-
(
isless(A,B) -> interint(L1,[B|L2],L3);
isless(B,A) -> interint([A|L1],L2,L3);
overlaps1(A,B,C) -> L3=[C|L3N],interint([A|L1],L2,L3N);
overlaps2(A,B,C) -> L3=[C|L3N],interint(L1,[B|L2],L3N)
).
isless(A-B,C-D):- (B<C).
overlaps1(A-B,C-D,E-F):-
(B>=D),(C=<B),(A=<D),
my_max(A,C,E),my_min(B,D,F).
% E is max(float(A),float(C)), F is min(float(B),float(D)).
overlaps2(A-B,C-D,E-F):-
(D>=B),(C=<B),(A=<D),
my_max(A,C,E),my_min(B,D,F).
% E is max(float(A),float(C)), F is min(float(B),float(D)).
my_max(X,Y,Z):- (X>=Y),!,X=Z.
my_max(X,Y,Y).
my_min(X,Y,Z):- (X=<Y),!,X=Z.
my_min(X,Y,Y).
:- block transl(-,-,?,?), transl(-,?,-,?), transl(?,-,-,?).
%
transl(A,B,C,T):-
qtype(A,QA),qtype(B,QB),qtype(C,QC),
(
(T=p-p-p,(QA==quantl;QB==quantl;QC==quantl) ) -> % at least one quantl
qualquant(A,QA,A1),qualquant(B,QB,B1),qualquant(C,QC,C1),
transl(A1,B1,C1,T,quantl)
;
quantqual(A,QA,A1),quantqual(B,QB,B1),quantqual(C,QC,C1),
transl(A1,B1,C1,T,quall)
),
!.
transl(L1,L2,L3,T,Q):- var(L3),!,
setof(C,A^B^(member(A,L1),member(B,L2),trans(A,B,C,T,Q)),L3N),
mergerel(L3N,L3,T,Q).
transl(L1,L2,L3,T,Q):- var(L2),!,
setof(B,A^C^(member(A,L1),member(C,L3),trans(A,B,C,T,Q)),L2N),
mergerel(L2N,L2,T,Q).
transl(L1,L2,L3,T,Q):- var(L1),!,
setof(A,B^C^(member(B,L2),member(C,L3),trans(A,B,C,T,Q)),L1N),
mergerel(L1N,L1,T,Q).
mergerel(L1,L2,T,Q):-
(Q==quantl -> mergerel(L1,L2) ; L1=L2),
!.
mergerel([],[]).
mergerel([A-B,C-D|L1],L2):-
sup(Sup),
(B+Sup>=C), % +sup added 921029
!,
my_min(A,C,Min), % min, max added 920129
my_max(B,D,Max),
mergerel([Min-Max|L1],L2).
mergerel([X|L1],[X|L2]):-
mergerel(L1,L2).
trans(A,B,C,s-s-s,quall):- !,
strans(A,B,C).
trans(A,B,C,p-p-p,quall):- !,
prans(A,B,C).
trans(A,B,C,p-p-p,quantl):- !,
qtrans(A,B,C).
trans(A,B,C,U-V-W,quall):- !,
itrans(U-V-W,A,B,C).
%% qualitative and quantitative constraints interaction
qtype(L,T) :- when( ground(L), qtype_g(L,T)).
qtype_g(L,quantl):- is_quantl(L).
qtype_g(L,quall):- is_quall(L).
is_quantl([X|_]):- is_quant(X).
is_quall([X|_]):- is_qual(X).
:- block is_quant(-).
%
is_quant(A-B). % :- A1 is A,B1 is B,number(A1),number(B1).
:- block is_qual(-).
%
is_qual(A):- atomic(A). % single numbers are treated like atoms 930212
:- block qualquant(-,?,-). % necessary?
qualquant(A,QA,A1):- % hacked for var-case (== versus = below!)
(QA==quall -> qualquant(A,A0),mergerel(A0,A1) ; QA=quantl -> A=A1). % mergrel added 921029
:- block quantqual(-,?,-). % necessary?
quantqual(A,QA,A1):- % hacked for var-case (== versus = below!)
(QA==quantl -> quantqual(A,A1) ; QA=quall -> A=A1).
%path(N,X,Y,L,p-p) +=> qualquant(L,LIN), sort(LIN,LI), path(N,X,Y,LI,p-p).
qualquant([],[]).
qualquant([A|L1],[B|L2]):-
qualquant1(A,B),
qualquant(L1,L2).
qualquant1(le,A-B):- !, sup(A), inf(B).
qualquant1(eq,0-0):- !.
qualquant1(ge,A-B):- !, minf(A), msup(B).
% 930212 to treat single numbers
qualquant1(N,A-A):- A is N. % 'is' used to catch type error
%path(N,X,Y,LI,p-p) +=> N>2 | % quick hack condition for termination
% quantqual(LI,L), length(L,N1), path(N1,X,Y,L,p-p).
quantqual(LI,L):-
findall(X,quantqual1(LI,X),L).
quantqual1(LI,eq):-
once((member(I-J,LI), (I=<0),(0=<J))).
quantqual1(LI,le):-
once((member(I-J,LI), (0<J))).
quantqual1(LI,ge):-
once((member(I-J,LI), (I<0))).
% 930212 to treat single numbers
quantqual1(LI,N):-
once((member(N-M,LI), (N=:=M))).
% ALLENS INTERVALS ---------------------------------------------------------
:- ensure_loaded( allentable). % get cons_tri/3 transitivity table for Allens intervals
%[after, before, contains, during, equals, finished_by, finishes, meets, met_by, overlapped_by, overlaps, started_by, starts].
%930212
check_ii(X,Y,R):- interval_point(X,R,Y).
% taken from jonathan lever
interval_point([X,Y],before,[U,V]):- ((Y < U)).
interval_point([X,Y],after,[U,V]):- ((V < X)).
interval_point([X,Y],meets,[U,V]):- ((Y =:= U)).
interval_point([X,Y],met_by,[U,V]):- ((V =:= X)).
interval_point([X,Y],starts,[U,V]):- ((X =:= U, Y < V)).
interval_point([X,Y],started_by,[U,V]):- ((X =:= U, V < Y)).
interval_point([X,Y],finishes,[U,V]):- ((Y =:= V, U < X)).
interval_point([X,Y],finished_by,[U,V]):- ((Y =:= V, X < V)).
interval_point([X,Y],during,[U,V]):- ((U < X, Y < V)).
interval_point([X,Y],contains,[U,V]):- ((X < U, V < Y)).
interval_point([X,Y],overlaps,[U,V]):- ((X < U, U < Y, Y < V)).
interval_point([X,Y],overlapped_by,[U,V]):- ((U < X, X < V, V < Y)).
interval_point([X,Y],equals,[U,V]):- ((X =:= U,Y =:= V)).
itrans(U-V-W,A,B,C):-
encode(U-V,A,X),encode(V-W,B,Y),encode(U-W,C,Z),
cons_tri(X,Y,Z).
:- block encode(?,-,-).
%
encode(i-i,A,B):-!,encode(A,B).
encode(p-i,A,B):-!,pi_ii(A,Y),encode(Y,B).
encode(i-p,A,B):-!,ip_ii(A,Y),encode(Y,B).
encode(p-p,A,B):-!,pp_pi(A,X),pi_ii(X,Y),encode(Y,B).
:- block encode(-,-).
%
encode(before,1).
encode(after,2).
encode(during,3).
encode(contains,4).
encode(overlaps,5).
encode(overlapped_by,6).
encode(meets,7).
encode(met_by,8).
encode(starts,9).
encode(started_by,10).
encode(finishes,11).
encode(finished_by,12).
encode(equals,13).
% POINT ALGEBRA ---------------------------------------------------------------
%[le,eq,ge]
% 930212
check_pp(X,Y,A-B):- !, ((X+A<Y,Y<X+B)).
check_pp(X,Y,N):- number(N),!, (X+N=:=Y).
check_pp(X,Y,T):- \+ member(T,[le,eq,ge]),!, Y=T.
check_pp(X,Y,R):- ((number(X),number(Y))->check_ppn(X,Y,R);check_ppt(X,Y,R)).
check_ppn(X,Y,le):- (X<Y).
check_ppn(X,Y,eq):- (X=:=Y).
check_ppn(X,Y,ge):- (X>Y).
check_ppt(X,Y,le):- (X@<Y).
check_ppt(X,Y,eq):- (X=Y).
check_ppt(X,Y,ge):- (X@>Y).
prans(A,B,C):- (number(A);number(B);number(C)),!,qtrans(A-A,B-B,C-C).
prans(le,le,le).
prans(le,eq,le).
prans(le,ge,le).
prans(le,ge,eq).
prans(le,ge,ge).
prans(eq,le,le).
prans(eq,eq,eq).
prans(eq,ge,ge).
prans(ge,le,le).
prans(ge,le,eq).
prans(ge,le,ge).
prans(ge,eq,ge).
prans(ge,ge,ge).
% QUANTITATIVE ---------------------------------------------------------
% [I1-I2,...In-1-In] ordered Ii=<Ii+1, comparison problem with reals (equality)
qtrans(A-B,C-D,E-F):- ( (var(A),var(B)) -> safe_is(A,E-D), safe_is(B,F-C) ;
(var(C),var(D)) -> safe_is(C,E-B), safe_is(D,F-A) ;
(var(E),var(F)) -> safe_is(E,A+C), safe_is(F,B+D)
).
safe_is(A,X-Y):-
inf(Inf),
minf(Minf),
sup(Sup),
msup(Msup),
(X=:=Minf,Y=:=Inf -> A is Minf
;
X=:=Inf,Y=:=Minf -> A is Inf
;
X=:=Msup,Y=:=Sup -> A is Msup
;
X=:=Sup,Y=:=Msup -> A is Sup
;
A is X-Y).
safe_is(A,X+Y):-
inf(Inf),
minf(Minf),
sup(Sup),
msup(Msup),
(X=:=Inf,Y=:=Inf -> A is Inf
;
X=:=Minf,Y=:=Minf -> A is Minf
;
X=:=Sup,Y=:=Sup -> A is Sup
;
X=:=Msup,Y=:=Msup -> A is Msup
;
A is X+Y).
% POINT-INTERVAL ---------------------------------------------------------
% p-i [before,starts,during,finishes,after]
% i-p [after,started_by,contains,finished_by,before]
%930212
check_pi(X,[A,B],before):- ((X<A)).
check_pi(X,[A,B],starts):- ((X=:=A)).
check_pi(X,[A,B],during):- ((A<X,X<B)).
check_pi(X,[A,B],finishes):- ((X=:=B)).
check_pi(X,[A,B],after):- ((B<X)).
check_pi([A,_B],X,after):- ((X<A)).
check_pi([A,_B],X,started_by):- ((X=:=A)).
check_pi([A,B],X,contains):- ((A<X,X<B)).
check_pi([_A,B],X,finished_by):- ((X=:=B)).
check_pi([_A,B],X,before):- ((B<X)).
% trans see itrans for INTERVAL
% pi_ii
:- block pi_ii(-,-).
%
pi_ii(before, before).
pi_ii(before, meets).
pi_ii(before, finished_by).
pi_ii(before, contains).
pi_ii(before, overlaps).
pi_ii(starts, starts).
pi_ii(starts, equals).
pi_ii(starts, started_by).
pi_ii(during, during).
pi_ii(during, finishes).
pi_ii(during, overlaped_by).
pi_ii(finishes, met_by).
pi_ii(after, after).
% ip_ii (inversion of pi_ii)
:- block ip_ii(-,-).
%
ip_ii(before, before).
ip_ii(finished_by, meets).
ip_ii(contains, contains).
ip_ii(contains, overlaps).
ip_ii(contains, finished_by).
ip_ii(started_by, starts).
ip_ii(started_by, equals).
ip_ii(started_by, started_by).
ip_ii(after, during).
ip_ii(after, finishes).
ip_ii(after, overlaped_by).
ip_ii(after, met_by).
ip_ii(after, after).
% pp_pi
:- block pp_pi(-,-).
%
pp_pi(le, before).
pp_pi(eq, starts).
pp_pi(ge, during).
pp_pi(ge, finishes).
pp_pi(ge, after).
% pp_ii
:- block pp_ii(-,-).
%
pp_ii(A,B):- pp_pi(A,C),pi_ii(C,B).
% end of handler time.chr ----------------------------------------------------

203
CHR/chr/examples/tree.pl
View File

@ -1,203 +0,0 @@
% rational (finite and infinite) tree handler
% 931119 thom fruehwirth ECRC for eclipse CHR
% 980130, 980312 thom fruehwirth LMU for sicstus CHR, now simpler and better
:- use_module(library(chr)).
% need global order on variables
:- use_module( library('chr/ordering'), [globalize/1,var_compare/3]).
% var is smaller than any non-var term
lt(X,Y):- (var(X),var(Y) -> globalize(X),globalize(Y),var_compare(<,X,Y) ; X@<Y).
le(X,Y):- (var(X) -> true ; X@=<Y).
handler tree.
option(debug_compile,on).
option(already_in_store, off).
option(already_in_heads, off).
option(check_guard_bindings, off).
constraints (~)/2, ('#~')/2.
% T1 ~ T2 means: term T1 is syntactically equal to term T2
% T1 #~ T2 means: term T1 is syntactically different from term T2
operator(700,xfx,(~)).
operator(700,xfx,('#~')).
ident @ T ~ T <=> true.
decompose @ T1 ~ T2 <=> nonvar(T1),nonvar(T2) |
same_functor(T1,T2),
T1=..[F|L1],T2=..[F|L2],
equate(L1,L2).
orient @ T ~ X <=> lt(X,T) | X ~ T.
simplify @ X ~ T1 \ X ~ T2 <=> le(T1,T2) | T1 ~ T2.
same_functor(T1,T2):- functor(T1,F,N),functor(T2,F,N).
equate([],[]).
equate([X|L1],[Y|L2]):- X ~ Y, equate(L1,L2).
ident @ T #~ T <=> fail.
decompose @ T1 #~ T2 <=> nonvar(T1),nonvar(T2) |
(same_functor(T1,T2) ->
T1=..[F|L1],T2=..[F|L2],
not_equate(L1,L2)
;
true).
orient @ T #~ X <=> lt(X,T) | X #~ T.
simplify @ X ~ T1 \ X #~ T2 <=> T1 #~ T2
pragma already_in_heads.
constraints not_equate/2, label/0.
not_equate([],[]) <=> fail.
not_equate([X],[Y]) <=> X #~ Y.
not_equate([X|L1],[X|L2]) <=> fail.
not_equate([X|L1],[Y|L2]), X~Y <=> not_equate(L1,L2).
% not_equate([X|L1],[Y|L2]) <=> ground(X#~Y) | X #~ Y -> true ; not_equate(L1,L2).
label, not_equate([X|L1],[Y|L2])#Id <=> true |
(X #~ Y ; X ~ Y, not_equate(L1,L2)),
label
pragma passive(Id).
/*
% EXAMPLES ------------------------------------------------------------
write(example:10), X#~a,X~b;
write(example:11), A~B,B~C,C~D,D~A;
write(example:12), A~B,B~C,C~D,D#~A;
write(example:20), A~g(A),A~g(g(A));
write(example:21), A#~g(A),A~g(g(A));
write(example:22), A~g(A),A#~g(g(A));
write(example:23), A~g(g(g(A))),A~g(g(A));
write(example:24), A~g(g(g(A))),g(A)~g(g(A));
write(example:25), A#~g(g(g(A))),A~g(g(A));
write(example:26), A~g(g(g(A))),A#~g(g(A));
write(example:30), X~f(T1),T2~f(T2),X~T1,X~T2;
write(example:31), f(X)~T1,T2~f(T2),X~T1,X~T2;
write(example:32), X~f(T1),T1~f(T2),X~T1,X~T2;
write(example:33), f(X)~T1,f(T1)~T2,X~T1,X~T2;
write(example:34), T1~f(T1),T2~f(T2),X~T1,X~T2;
write(example:40), A~f(X),B~f(Y),Y~Z,Z~X,A#~B;
write(example:41), A~X,B~Y,Y~Z,Z~X,A#~B;
write(example:42), X~f(X,Y),X#~f(X,Y);
write(example:43), X~f(X,Y),X#~f(Y,X);
write(example:44), X~f(X,Y),X#~f(Y,X),label;
write(example:45), X~f(A,B),X#~f(a,b),A~a,B~b;
write(example:46), X~f(A,B),X#~f(a,b),A~a,B~b,label;
write(example:50), [X|L] ~ [X,X|L], L ~ [X,X,X,X|Z];
write(example:51), [X|L]#~[X,X|L], L ~ [X,X,X,X|Z],label;
write(example:52), [X|L] ~ [X,X|L], L#~[X,X,X,X|Z],label;
write(example:53), L ~ [X,X|L], L ~ [A,B,C,D];
write(done).
% results of current version with local already_in_heads pragma
example:10
X~b ? ;
example:11
B~A,
A~C,
D~C ? ;
example:12example:20
A~g(A) ? ;
example:21
A#~g(A),
A~g(g(A)) ? ;
example:22example:23
A~g(A) ? ;
example:24
A~g(A) ? ;
example:25
A~g(g(A)),
A#~g(A) ? ;
example:26
A~g(g(g(A))),
A#~g(g(A)) ? ;
example:30
T1~X,
X~T2,
T2~f(T1) ? ;
example:31
T2~f(T2),
T1~X,
X~T2 ? ;
example:32
T1~X,
X~T2,
T2~f(T2) ? ;
example:33
T2~f(T1),
T1~X,
X~T2 ? ;
example:34
T1~X,
X~T2,
T2~f(T1) ? ;
example:40example:41example:42example:43
X~f(X,Y),
not_equate([X,Y],[Y,X]) ? ;
example:44
label,
X~f(X,Y),
Y#~X ? ;
example:45
X~f(A,B),
not_equate([A,B],[a,b]),
A~a,
B~b ? ;
example:46example:50
L~Z,
Z~[X|Z] ? ;
example:51
label,
L~[X,X,X,X|Z],
Z#~[X|Z] ? ;
example:52
label,
L~[X|L],
Z#~L ? ;
example:53done
true ?
*/
% end of handler tree

87
CHR/chr/examples/type.pl
View File

@ -1,87 +0,0 @@
% rational tree handler with OZ type constraints, see also tree.pl
% ECRC 1993, 950519; LMU 980211, 980312 Thom Fruehwirth
:- use_module( library(chr)).
handler type.
constraints (~)/2, (':<')/2, ('&&')/2.
% T1 ~ T2 means: term T1 is syntactically equal to term T2
% T1 :< T2 means: term T1 has type T2, types are not to be cyclic (infinite)
% Z~X&&Y means: the type Z is the intersection of types X and Y
operator(100,xfx,(~)). % equality
operator(100,xfx,(':<')). % type constraint
operator(110,xfx,('&&')). % type intersection
% need global order on variables for equality with infinite (cyclic) terms
:- use_module( library('chr/ordering'), [globalize/1,var_compare/3]).
% var is smaller than any non-var term
lt(X,Y):- (var(X),var(Y) -> globalize(X),globalize(Y),var_compare(<,X,Y) ; X@<Y).
le(X,Y):- (var(X) -> true ; X@=<Y).
% equality ~ -----------------------------------------------------------------
ident @ T ~ T <=> true.
decompose @ T1 ~ T2 <=> nonvar(T1),nonvar(T2) |
same_functor(T1,T2),
T1=..[F|L1],T2=..[F|L2],
equate(L1,L2).
orient @ T ~ X <=> lt(X,T) | X ~ T.
simplify @ X ~ T1 \ X ~ T2 <=> le(T1,T2) | T1 ~ T2.
same_functor(T1,T2):- functor(T1,F,N),functor(T2,F,N).
equate([],[]).
equate([X|L1],[Y|L2]):- X ~ Y, equate(L1,L2).
% type constraint :< ---------------------------------------------------------
type_identity @ XT :< XT <=> true.
type_decompose @ T1 :< T2 <=> nonvar(T1),nonvar(T2) |
same_functor(T1,T2),
T1=..[_|L1],T2=..[_|L2],
contain(L1,L2).
type_simplify1 @ X ~ T1 \ X :< T2 <=> var(X) | T1 :< T2.
type_simplify2 @ X ~ T1 \ T2 :< X <=> var(X) | T2 :< T1.
type_intersect @ X :< T1, X :< T2 <=> nonvar(T1),nonvar(T2) |
same_functor(T1,T2),
T1=..[F|L1],T2=..[F|L2],
type_intersect(L1,L2,L3),
T3=..[F|L3],
X :< T3.
type_transitiv @ T1 :< Y, Y :< T2 ==> var(Y) | T1 :< T2.
contain([],[]).
contain([X|L1],[Y|L2]):- X :< Y,
contain(L1,L2).
type_intersect([],[],[]).
type_intersect([X|L1],[Y|L2],[Z|L3]):- Z~X&&Y,
type_intersect(L1,L2,L3).
% X~Y&&Z parses as (X~Y)&&Z, therefore it cannot match X~T
type_functional @ Z1~X&&Y \ Z2~X&&Y <=> Z1=Z2.
type_functional @ Z1~Y&&X \ Z2~X&&Y <=> Z1=Z2.
type_propagate @ Z~X&&Y ==> Z :< X, Z :< Y.
/*
% Examples
:- f(a,b):<f(X,X). % succeeds - X is a "top" ('a hole')
a:<X,b:<X.
:- Y~f(U),Z~f(X),X:<Y,X:<Z. % succeeds
Y~f(U),Z~f(X),UX~X&&U,X:<f(UX),UX:<X,UX:<U,UX:<f(UX)
:- Y~f(U),U~a,Z~f(X),X:<Y,X:<Z. % fails
:- X:<Y,X~f(X),X:<f(Y).
X~f(X), f(X):<Y % simplifies nicely
:- X:<Y,Y~f(U),U~a,Z~f(X),X:<Z. % fails
:- X~Y,U:<X,Z:<a,U:<Z,Y:<b. % fails
:- X:<Y,X:<Z,Y~a,Z~b. % fails
:- X:<Y,X:<Z,Y~f(Y,U),Z~f(Z,V),U~a,V~b. % fails
:- X:<f(X,Y), X~f(X1,U), X1~f(X11,U1), U1~g(U), a:<U, b:<U. % succeeds
:- X~ f(X,Y), X~f(X1,U), X1~f(X11,U1), U1~g(U), a:<U, b:<U. % fails
*/
% end of handler type =======================================================

52
CHR/chr/getval.pl
View File

@ -1,52 +0,0 @@
%
% We use macros because because the
% bb operations are module specific.
% Thus the names are relative to the module
% loading this file
%
:- module( getval, []).
:- multifile
user:goal_expansion/3.
:- dynamic
user:goal_expansion/3.
user:goal_expansion( setval(Name,Value), _, bb_put(Name,Value)).
user:goal_expansion( getval(Name,Value), _, bb_get(Name,Value)).
user:goal_expansion( incval(Name,New), _, Exp) :-
Exp = (
bb_get( Name, Old),
New is Old+1,
bb_put( Name, New)
).
user:goal_expansion( decval(Name,New), _, Exp) :-
Exp = (
bb_get( Name, Old),
New is Old-1,
bb_put( Name, New)
).
end_of_file.
setval( Name, Value) :- bb_put( Name, Value).
getval( Name, Value) :- bb_get( Name, Value).
%
% ++i
%
incval( Name, New) :-
bb_get( Name, O),
New is O+1,
bb_put( Name, New).
%
% --i
%
decval( Name, New) :-
bb_get( Name, O),
New is O-1,
bb_put( Name, New).

102
CHR/chr/matching.pl
View File

@ -1,102 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Constraint Handling Rules version 2.2 %
% %
% (c) Copyright 1996-98 %
% LMU, Muenchen %
% %
% File: matching.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Head matching for SICStus
% ch, Aug. 95
%
:- module( matching, []).
:- op( 1200, xfx, ?-).
:- use_module( library(assoc),
[
empty_assoc/1,
get_assoc/3,
put_assoc/4
]).
:- multifile
user:term_expansion/2,
user:goal_expansion/3.
:- dynamic
user:term_expansion/2,
user:goal_expansion/3.
%
user:term_expansion( ?-(M:H0,B), (M:H1 :- Body)) :- !,
functor( H0, N, A),
functor( H1, N, A),
subs( H0, H1, Code, [B]),
l2conj( Code, Body).
user:term_expansion( ?-(H0,B), (H1 :- Body)) :-
functor( H0, N, A),
functor( H1, N, A),
subs( H0, H1, Code, [B]),
l2conj( Code, Body).
%
user:goal_expansion( inline_matching(Pattern,Datum), _, Exp) :-
code( Pattern, Datum, Exp).
code( Pattern, Datum, Code) :-
subs( Pattern, Datum, L, []),
l2conj( L, Code).
%
% partial evaluation of subsumes( H0, H1)
%
subs( Pattern, Datum, L, Lt) :-
empty_assoc( Dict),
subs( Pattern, Datum, Dict,_, L, Lt).
subs( Pattern, Datum, D0,D1) --> {var(Pattern)}, !,
{var(Datum)},
( {get_assoc( Pattern, D0, _),D0=D1} -> % subsequent occ
[ Pattern == Datum ]
; % first occ
{
Pattern = Datum,
put_assoc( Pattern, D0, _, D1)
}
).
subs( Pattern, Datum, D0,D1) --> {var(Datum)}, !,
{
functor( Pattern, N, A),
functor( Skel, N, A)
},
[
nonvar( Datum),
Datum = Skel
],
subs( 1, A, Pattern, Skel, D0,D1).
subs( Pattern, Datum, D0,D1) -->
{
functor( Pattern, N, A),
functor( Datum, N, A)
},
subs( 1, A, Pattern, Datum, D0,D1).
subs( N, M, _, _, D0,D0) --> {N>M}, !.
subs( N, M, G, S, D0,D2) -->
{
arg( N, G, Ga),
arg( N, S, Sa),
N1 is N+1
},
subs( Ga, Sa, D0,D1),
subs( N1, M, G, S, D1,D2).
l2conj( [], true).
l2conj( [X|Xs], Conj) :-
( Xs = [], Conj = X
; Xs = [_|_], Conj = (X,Xc), l2conj( Xs, Xc)
).

13
CHR/chr/operator.pl
View File

@ -1,13 +0,0 @@
:- op(1200, xfx, @). % rulename
:- op(1190, xfx, pragma).
:- op(1180, xfx, [==>, <=>]).
:- op(1180,fy,chr_spy).
:- op(1180,fy,chr_nospy).
:- op(1150, fx, handler).
:- op(1150, fx, constraints).
:- op(1150, fx, rules).
% :- op(1100, xfx, '|'). % read as ; by sicstus
:- op(1100, xfx, \ ).
:- op(1050,xfx,&). % current_op(1000,xfy,',')
% :- op(500,yfx,#). % already defined in SICStus

81
CHR/chr/ordering.pl
View File

@ -1,81 +0,0 @@
%
% Preliminary support for some CHR handlers
%
% Define a stable ordering on variables
% (Term/Var ordering changes under put_atts, delay, etc.)
%
% Bindings still brake our ordering!
%
%
:- module( ordering,
[
globalize/1,
unglobalize/1,
var_compare/3
]).
:- use_module( library(terms), [term_variables/2]).
:- use_module( library(atts)).
:- attribute id/1.
%
% The exception mechanism copies the thrown term.
% Thus we cannot pass the variable to the catcher ...
%
verify_attributes( X, Y, []) :-
get_atts( X, id(Id)),
!,
( var(Y) ->
( get_atts( Y, id(_)) ->
true % raise_exception( binding_globalized_var)
;
put_atts( Y, id(Id))
)
;
true % raise_exception( binding_globalized_var)
).
verify_attributes( _, _, []).
globalize( Term) :-
term_variables( Term, Vars),
var_globalize( Vars).
var_globalize( X) :- var( X), !, % indexing only
( get_atts( X, id(_)) ->
true
;
put_atts( X, id(_))
).
var_globalize( []).
var_globalize( [X|Xs]) :-
var_globalize( X),
var_globalize( Xs).
unglobalize( Term) :-
term_variables( Term, Vars),
var_unglobalize( Vars).
var_unglobalize( X) :- var( X), !, % indexing only
put_atts( X, -id(_)).
var_unglobalize( []).
var_unglobalize( [X|Xs]) :-
var_unglobalize( X),
var_unglobalize( Xs).
var_compare( Rel, X, Y) :-
(var(X),get_atts( X, id(IdX)) ->
true
;
raise_exception( not_globalized)
),
(var(Y),get_atts( Y, id(IdY)) ->
true
;
raise_exception( not_globalized)
),
compare( Rel, IdX, IdY).

89
CHR/chr/sbag.pl
View File

@ -1,89 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Constraint Handling Rules version 2.2 %
% %
% (c) Copyright 1996-98 %
% LMU, Muenchen %
% %
% File: sbag_l.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% bags of suspensions
%
:- module( sbag,
[
iter_init/2,
iter_last/1,
iter_next/3,
list_to_sbag/2,
sbag_empty/1,
sbag_member/2,
sbag_union/3,
sbag_add_element/3,
sbag_del_element/3
]).
:- use_module( library(ordsets),
[
merge/3
]).
% -----------------------------------------------------------------
%
% *** MACROS ***
%
:- multifile
user:goal_expansion/3.
:- dynamic
user:goal_expansion/3.
%
user:goal_expansion( iter_init(A,A), _, true).
user:goal_expansion( iter_last([]), _, true).
user:goal_expansion( iter_next([A|B],A,B), _, true).
user:goal_expansion( list_to_sbag(A,A), _, true).
user:goal_expansion( sbag_empty(A), _, A==[]).
user:goal_expansion( sbag_add_element(A,B,C), _, C=[B|A]).
% -----------------------------------------------------------------
iter_init( A, A).
iter_last( []).
iter_next( [A|B], A, B).
list_to_sbag( L, L).
sbag_empty( B) :- B == [].
%
% here for profiling
%
sbag_member( Element, [Head|Tail]) :-
sbag_member( Element, Tail, Head).
% auxiliary to avoid choicepoint for last element
%
sbag_member( E, _, E).
sbag_member( E, [Head|Tail], _) :-
sbag_member( E, Tail, Head).
sbag_union( A, B, C) :-
sort( A, As),
sort( B, Bs),
merge( As, Bs, C).
sbag_add_element( Set1, Elem, Set2) :- Set2 = [Elem|Set1].
sbag_del_element( [], _, []).
sbag_del_element( [X|Xs], Elem, Set2) :-
( X==Elem ->
Set2 = Xs
;
Set2 = [X|Xss],
sbag_del_element( Xs, Elem, Xss)
).
end_of_file.

129
CHR/chr/sbag_a.pl
View File

@ -1,129 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Constraint Handling Rules version 2.2 %
% %
% (c) Copyright 1996-98 %
% LMU, Muenchen %
% %
% File: sbag_a.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% bags of suspensions
%
:- module( sbag,
[
iter_init/2,
iter_last/1,
iter_next/3,
list_to_sbag/2,
sbag_empty/1,
sbag_member/2,
sbag_union/3,
sbag_add_element/3,
sbag_del_element/3
]).
:- use_module( library(assoc),
[
assoc_to_list/2,
put_assoc/4,
del_assoc/4,
gen_assoc/3,
list_to_assoc/2,
ord_list_to_assoc/2
]).
:- use_module( library(ordsets),
[
merge/3
]).
% -----------------------------------------------------------------
%
% *** MACROS ***
%
:- multifile
user:goal_expansion/3.
:- dynamic
user:goal_expansion/3.
%
user:goal_expansion( iter_init(A,B), _, sbag:down(A,[],B)).
user:goal_expansion( iter_last([]), _, true).
user:goal_expansion( iter_next([A|B],C,D), _, sbag:iter_next(A,B,D,C)).
user:goal_expansion( sbag_empty(A), _, A==t).
% -----------------------------------------------------------------
iter_init( Assoc, Contin) :-
down( Assoc, [], Contin).
iter_last( []).
sbag_empty( B) :- B == t.
%
% fails for empty
%
iter_next( [Node|Cont], Elem, Next) :-
iter_next( Node, Cont, Next, Elem).
iter_next( t(K,_,_,_,R), Cont, Next, K) :- % cf. assoc.pl
down( R, Cont, Next).
/*
( R==t,L==t -> Next=Cont
; R==t -> Next=Cont % Next=[t(K,V,0,t,t)|Cont]
; down( R, Cont, Next)
).
*/
down( t, Ci, Ci).
down( Node, Ci, Co) :-
Node = t(_,_,_,L,_),
down( L, [Node|Ci], Co).
list_to_sbag( L, A) :-
list_to_sbag( L, t, A).
list_to_sbag([], Assoc, Assoc).
list_to_sbag([X|Xs], Assoc0, Assoc) :-
put_assoc( X, Assoc0, 0, Assoc1),
list_to_sbag( Xs, Assoc1, Assoc).
sbag_member( Elem, A) :-
gen_assoc( Elem, A, _).
sbag_union( A, B, C) :-
assoc_to_list( A, As),
assoc_to_list( B, Bs),
merge( As, Bs, Cs),
ord_list_to_assoc( Cs, C).
sbag_add_element( S1, E, S2) :- put_assoc( E, S1, 0, S2).
sbag_del_element( S1, E, S2) :- del_assoc( E, S1, _, S2).
end_of_file.
% -----------------------------------------------------------------
test( N) :-
length( L, N),
list_to_assoc( L, A),
down( A, [], C),
a2l( C, L1),
assoc_to_list( A, L2),
( L1==L1 -> true ; raise_exception( mismatch(L1,L2))).
bug(L) :-
A = t(c,0,0,t(b,0,-1,t(a,0,0,t,t),t),
t(e,0,0,t(d,0,0,t,t),
t(f,0,0,t,t))),
iter_init( A, S),
a2l( S, L).
a2l( S, []) :- iter_last( S).
a2l( S, [X|Xs]) :-
iter_next( S, X, N),
a2l( N, Xs).

89
CHR/chr/sbag_l.pl
View File

@ -1,89 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Constraint Handling Rules version 2.2 %
% %
% (c) Copyright 1996-98 %
% LMU, Muenchen %
% %
% File: sbag_l.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% bags of suspensions
%
:- module( sbag,
[
iter_init/2,
iter_last/1,
iter_next/3,
list_to_sbag/2,
sbag_empty/1,
sbag_member/2,
sbag_union/3,
sbag_add_element/3,
sbag_del_element/3
]).
:- use_module( library(ordsets),
[
merge/3
]).
% -----------------------------------------------------------------
%
% *** MACROS ***
%
:- multifile
user:goal_expansion/3.
:- dynamic
user:goal_expansion/3.
%
user:goal_expansion( iter_init(A,A), _, true).
user:goal_expansion( iter_last([]), _, true).
user:goal_expansion( iter_next([A|B],A,B), _, true).
user:goal_expansion( list_to_sbag(A,A), _, true).
user:goal_expansion( sbag_empty(A), _, A==[]).
user:goal_expansion( sbag_add_element(A,B,C), _, C=[B|A]).
% -----------------------------------------------------------------
iter_init( A, A).
iter_last( []).
iter_next( [A|B], A, B).
list_to_sbag( L, L).
sbag_empty( B) :- B == [].
%
% here for profiling
%
sbag_member( Element, [Head|Tail]) :-
sbag_member( Element, Tail, Head).
% auxiliary to avoid choicepoint for last element
%
sbag_member( E, _, E).
sbag_member( E, [Head|Tail], _) :-
sbag_member( E, Tail, Head).
sbag_union( A, B, C) :-
sort( A, As),
sort( B, Bs),
merge( As, Bs, C).
sbag_add_element( Set1, Elem, Set2) :- Set2 = [Elem|Set1].
sbag_del_element( [], _, []).
sbag_del_element( [X|Xs], Elem, Set2) :-
( X==Elem ->
Set2 = Xs
;
Set2 = [X|Xss],
sbag_del_element( Xs, Elem, Xss)
).
end_of_file.

592
CHR/chr/trace.pl
View File

@ -1,592 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Constraint Handling Rules version 2.2 %
% %
% (c) Copyright 1998 %
% LMU, Muenchen %
% %
% File: trace.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
/*
2 Mechanisms: trace+leash, debug+spy
Debugger integration issue:
We could use conditional spypoints of the Prolog debugger
to get hooked, but then we depend a lot on it ...
:- spypoint_condition( debug_event(E), P, chr:de(P,E)).
Todo:
-) module_wrap/3 for all terms (M as arg to debug_event)
-) guard-fail = rule-delay reason?
*/
:- dynamic spy_rule/2.
:- dynamic spy_constraint/2.
:- initialization
getval( debug, _) -> true ; setval( debug, off).
:- initialization
retractall( spy_rule(_,_)).
:- initialization
retractall( spy_constraint(_,_)).
chr_trace :-
setval( debug, trace),
what_is_on( informational).
chr_notrace :-
setval( debug, off),
what_is_on( informational).
chr_debug :-
setval( debug, debug),
what_is_on( informational).
chr_nodebug :-
chr_notrace.
chr_spy( constraints(Cs)) :-
parse_spy_constraints( Cs, L, []),
member( N/A, L),
assert( spy_constraint(N,A)),
fail.
chr_spy( rules(Rs)) :-
parse_spy_rules( Rs, L, []),
member( Handler:Rule, L),
assert( spy_rule(Rule,Handler)),
fail.
chr_spy( _) :- getval( debug, trace), !.
chr_spy( _) :- chr_debug.
chr_nospy( rules(Rs)) :-
parse_spy_rules( Rs, L1, []),
member( Handler:Rule, L1),
retract( spy_rule(Rule,Handler)),
fail.
chr_nospy( constraints(Cs)) :-
parse_spy_constraints( Cs, L, []),
member( N/A, L),
retract( spy_constraint(N,A)),
fail.
chr_nospy( _).
parse_spy_constraints( C) --> {var(C)}, !, [ _ ].
parse_spy_constraints( (C,Cs)) -->
parse_spy_constraints( C),
parse_spy_constraints( Cs).
parse_spy_constraints( N) --> {atom(N)}, [ N/_ ].
parse_spy_constraints( N/A) --> {atom(N),integer(A),A>0}, [ N/A ].
parse_spy_rules( R) --> {var(R)}, !, [ _ ].
parse_spy_rules( (R,Rs)) --> !,
parse_spy_rules( R),
parse_spy_rules( Rs).
parse_spy_rules( H:R) --> !, [ H:R ].
parse_spy_rules( R) --> [ _:R ]. % any handler
chr_leash( Spec) :-
nonvar( Spec),
chr_leash( Spec, I),
setval( leashing, I),
what_is_leashed( informational).
chr_leash( none, 0) :- !.
chr_leash( off, 0) :- !.
chr_leash( all, -1) :- !.
chr_leash( default, I) :- !, chr_leash( 0, I, [call,wake,apply,exit,fail], []).
chr_leash( L, I) :- chr_leash( 0, I, L, []), !.
chr_leash( X, I) :- chr_leash( 0, I, [X], []).
chr_leash( I, K) --> [call], {J is I\/2'100000000}, chr_leash( J, K).
chr_leash( I, K) --> [wake], {J is I\/2'010000000}, chr_leash( J, K).
chr_leash( I, K) --> [try], {J is I\/2'001000000}, chr_leash( J, K).
chr_leash( I, K) --> [apply], {J is I\/2'000100000}, chr_leash( J, K).
chr_leash( I, K) --> [exit], {J is I\/2'000010000}, chr_leash( J, K).
chr_leash( I, K) --> [redo], {J is I\/2'000001000}, chr_leash( J, K).
chr_leash( I, K) --> [fail], {J is I\/2'000000100}, chr_leash( J, K).
%
chr_leash( I, K) --> [insert], {J is I\/2'000000010}, chr_leash( J, K).
chr_leash( I, K) --> [remove], {J is I\/2'000000001}, chr_leash( J, K).
chr_leash( I, I) --> [].
:- initialization
chr_leash( default, I), setval( leashing, I).
debug_stop( call(S), L, Why) :-
( L/\2'100000000 > 0 -> true
; spypoint_susp( S, Why)
).
debug_stop( wake(S), L, Why) :-
( L/\2'010000000 > 0 -> true
; spypoint_susp( S, Why)
).
debug_stop( exit(S), L, Why) :-
( L/\2'000010000 > 0 -> true
; spypoint_susp( S, Why)
).
debug_stop( redo(S), L, Why) :-
( L/\2'000001000 > 0 -> true
; spypoint_susp( S, Why)
).
debug_stop( fail(S), L, Why) :-
( L/\2'000000100 > 0 -> true
; spypoint_susp( S, Why)
).
%
debug_stop( insert(S), L, Why) :-
( L/\2'000000010 > 0 -> true
; spypoint_susp( S, Why)
).
debug_stop( remove(S), L, Why) :-
( L/\2'000000001 > 0 -> true
; spypoint_susp( S, Why)
).
%
debug_stop( try(H,R,_,Hs,_,_), L, Why) :-
( L/\2'001000000 > 0 -> true
; spy_rule(R,H) -> Why = r
; spypoint_head( Hs, Why)
).
debug_stop( apply(H,R,_,Hs,_,_), L, Why) :-
( L/\2'000100000 > 0 -> true
; spy_rule(R,H) -> Why = r
; spypoint_head( Hs, Why)
).
spypoint_susp( S, c) :-
S =.. [suspension,_,_,_,_,_,N|Args],
length( Args, A),
spy_constraint( N, A).
spypoint_head( Hs, c) :-
member( H, Hs),
arg( 1, H, Term),
functor( Term, N, A),
spy_constraint( N, A).
debug_stop_reason( Why, _) :- nonvar( Why).
debug_stop_reason( Why, Event) :- var( Why),
( debug_stop( Event, 0, Why) ->
true
;
Why = ' '
).
chr_debugging :-
what_is_on( help),
what_is_leashed( help),
what_spypoints( help).
what_is_on( Type) :-
getval( debug, Mode),
print_message( Type, debug(Mode)).
what_is_leashed( Type) :-
getval( leashing, Leash),
findall( P, (chr_leash(0,K,[P],[]),K/\Leash>0), L),
print_message( Type, leash(L)).
what_spypoints( Type) :-
findall( rules(E), (spy_rule(R,H),(var(H)->E=R;E=H:R)), L0, L1),
findall( constraints(E), (spy_constraint(N,A),(var(A)->E=N;E=N/A)), L1, []),
sort( L0, Ls),
print_message( Type, spypoints(Ls)).
% -----------------------------------------------------------------
debug_event( Event) :-
getval( debug, State),
( State == off ->
true
;
debug_event( State, Event),
debug_stack( Event)
).
debug_event( trace, Event) :-
getval( leashing, L),
( debug_stop( Event, L, SpyInd) ->
debug_stop_reason( SpyInd, Event),
debug_show( SpyInd, Event),
get_command( Cmd),
debug_do( Cmd, Event, trace)
;
debug_stop_reason( SpyInd, Event),
debug_show( SpyInd, Event),
errnl
).
debug_event( debug, Event) :-
( debug_stop( Event, 0, SpyInd) ->
debug_show( SpyInd, Event),
get_command( Cmd),
debug_do( Cmd, Event, debug)
;
true
).
debug_event( skip(N,S), Event) :-
stack_depth( M),
( M =< N, member( Event, [exit(_),fail(_)]) ->
setval( debug, S),
debug_event( S, Event)
;
true
).
debug_event( off, _).
debug_stack( Event) :- Event = call(_), !, stack_push( Event).
debug_stack( Event) :- Event = wake(_), !, stack_push( Event).
%
debug_stack( Event) :- Event = apply(_,_,_,_,_,_), !,
stack_pop,
stack_push( Event).
%
debug_stack( exit(_)) :- !, stack_pop.
%
debug_stack( _).
stack_push( S) :-
get_dbg_state( Ref),
get_mutable( Stack, Ref),
update_mutable( [S|Stack], Ref).
stack_pop :-
get_dbg_state( Ref),
get_mutable( [_|Stack], Ref),
update_mutable( Stack, Ref).
stack_depth( Depth) :-
get_dbg_state( Ref),
get_mutable( Stack, Ref),
length( Stack, Depth).
show_stack :-
get_dbg_state( Ref),
get_mutable( Stack, Ref),
length( Stack, N),
errwrite('Ancestors:'), errnl,
show_stack( Stack, N), errnl.
show_stack( [], _).
show_stack( [S|Ss], N) :-
M is N-1,
show_stack( Ss, M),
Spy = ' ',
( arg( 3, S, Hp) -> true ; Hp = '-' ),
functor( S, Port, _),
errformat( ' ~w ~|~t~d~4+ ~|~t~w~3+ ~|~p~t~7+', [Spy,N,Hp,Port]),
debug_show_event( S),
errnl.
debug_show( Spy, Event) :-
functor( Event, Port, _),
( arg( 3, Event, Hp) -> true ; Hp = '-' ),
stack_depth( Depth),
errformat( ' ~w ~|~t~d~4+ ~|~t~w~3+ ~|~p~t~7+', [Spy,Depth,Hp,Port]),
debug_show_event( Event).
debug_show_event( call(S)) :-
debug_susp_term( S, Term), errtab( 1), errprint( Term).
debug_show_event( wake(S)) :-
debug_susp_term( S, Term), errtab( 1), errprint( Term).
debug_show_event( exit(S)) :-
debug_susp_term( S, Term), errtab( 1), errprint( Term).
debug_show_event( redo(S)) :-
debug_susp_term( S, Term), errtab( 1), errprint( Term).
debug_show_event( fail(S)) :-
debug_susp_term( S, Term), errtab( 1), errprint( Term).
debug_show_event( remove(S)) :-
debug_susp_term( S, Term), errtab( 1), errprint( Term).
debug_show_event( insert(C)) :-
errtab( 1), errprint( C).
debug_show_event( try(Handler,Rule,_,Heads,_,_)) :-
errformat( ' ~p:~p @ ', [Handler,Rule]),
show_heads( Heads, 0, 0, _).
debug_show_event( apply(Handler,Rule,_,Heads,_,_)) :-
errformat( ' ~p:~p @ ', [Handler,Rule]),
show_heads( Heads, 0, 0, _).
debug_susp_term( S, Term#S) :-
S =.. [suspension,_,_,_,_,_,F|Args],
Term =.. [F|Args].
debug_do( 0'a, _, _) :- !, abort.
debug_do( 0'n, _, _) :- !, chr_notrace.
debug_do( 0'&, E, S) :- !, show_store( 0), debug_event( S, E).
debug_do( [0'&|_], E, S) :- !, show_store( 1), debug_event( S, E).
debug_do( 0'g, E, S) :- !, show_stack, debug_event( S, E).
debug_do( 0'., E, S) :-
dbg_at_rule( E, _, _),
!,
show_rule( E),
debug_event( S, E).
debug_do( 0'+, E, S) :- !,
( dbg_at_rule( E, Handler, Rule) ->
chr_spy( rules( Handler:Rule))
; dbg_at_constraint( E, N, A) ->
chr_spy( constraints( N/A))
),
debug_event( S, E).
debug_do( 0'-, E, S) :- !,
( dbg_at_rule( E, Handler, Rule) ->
chr_nospy( rules( Handler:Rule))
; dbg_at_constraint( E, N, A) ->
chr_nospy( constraints( N/A))
),
debug_event( S, E).
debug_do( 0'b, E, S) :- !,
setval( debug, off),
break,
setval( debug, S),
debug_event( S, E).
debug_do( 0'
, _, _) :- !, setval( debug, trace). % CR = creep
debug_do( 0'c, _, _) :- !, setval( debug, trace). % creep
debug_do( 0'l, _, _) :- !, setval( debug, debug). % leap
debug_do( 0's, E, S) :- chr_skip( E, S, _), !. % skip
debug_do( [0's,N], E, S) :- chr_skip( E, S, N), !. % skip
debug_do( 0'<, E, S) :- !, set_pd(10), debug_event( S, E).
debug_do( [0'<,N], E, S) :- !, set_pd(N), debug_event( S, E).
debug_do( 0'=, E, S) :- !, chr_debugging, debug_event( S, E).
debug_do( 0'?, E, S) :- !, dbg_help, debug_event( S, E).
debug_do( 0'h, E, S) :- !, dbg_help, debug_event( S, E).
debug_do( _, E, S) :-
print_message( informational, wrong_option),
debug_event( S, E).
chr_skip( E, S, K) :- E = exit(_), stack_depth( K), !, debug_event( S, E).
chr_skip( E, S, K) :- E = fail(_), stack_depth( K), !, debug_event( S, E).
chr_skip( _, S, K) :-
stack_depth( Depth),
( var(K) ->
N is Depth+1
;
1 =< K, K =< Depth,
N = K
),
setval( debug, skip(N,S)).
dbg_at_rule( try(Handler,Rule,_,_,_,_), Handler, Rule).
dbg_at_rule( apply(Handler,Rule,_,_,_,_), Handler, Rule).
dbg_at_constraint( E, N, A) :-
dbg_at_constraint( E, S),
S =.. [suspension,_,_,_,_,_,N|Args],
length( Args, A).
dbg_at_constraint( call(S), S).
dbg_at_constraint( wake(S), S).
dbg_at_constraint( exit(S), S).
dbg_at_constraint( redo(S), S).
dbg_at_constraint( fail(S), S).
dbg_at_constraint( insert(S), S).
dbg_at_constraint( remove(S), S).
%
% numbervars binds variables ...
%
show_rule( Event) :-
Event =.. [Which,Handler,Rule,_,Heads,Guard,Body],
member( Which, [try,apply]),
current_handler( Handler, _),
!,
show_rule( Rule, Heads, Guard, Body).
show_rule( _).
show_rule :-
chrcmp:rule( _, _, Name, Heads, Guard, Body, _),
numbervars( Heads/Name/Guard/Body, 0, _),
show_rule( Name, Heads, Guard, Body),
fail.
show_rule.
show_rule( Name, Heads, Guard, Body) :-
errformat( '~n ~p @', [Name]),
show_heads( Heads, 2, 2, Ident),
( member( k(_,_), Heads) ->
errformat( ' <=>~n~n', [])
;
errformat( ' ==>~n~n', [])
),
( Guard==true ->
show_body( Body, Ident)
;
show_body( Guard, Ident), errnl,
errtab( Ident), errwrite( '|'), errnl,
show_body( Body, Ident)
),
errput( 0'.), errnl, errnl.
show_body( (A,B), Tab) :- !,
show_body( A, Tab),
errwrite( ','), errnl,
show_body( B, Tab).
show_body( (A->B;C), Tab) :- !,
errtab( Tab), errwrite( '('), errnl,
NTab1 is Tab+2,
NTab2 is Tab+5,
show_body( A, NTab1),
errwrite( ' ->'), errnl,
show_body( B, NTab2), errnl,
errtab( Tab), errwrite( ';'), errnl,
show_body( C, NTab2), errnl,
errtab( Tab), errwrite( ')').
show_body( (A->B), Tab) :- !,
errtab( Tab), errwrite( '('), errnl,
NTab1 is Tab+2,
NTab2 is Tab+5,
show_body( A, NTab1),
errwrite( ' ->'), errnl,
show_body( B, NTab2), errnl,
errtab( Tab), errwrite( ')').
show_body( (A;B), Tab) :- !,
errtab( Tab), errwrite( '('), errnl,
NTab is Tab+5,
show_body( A, NTab), errnl,
errtab( Tab), errwrite( ';'), errnl,
show_body( B, NTab), errnl,
errtab( Tab), errwrite( ')').
show_body( A, Tab) :-
errtab( Tab),
errwriteq( A).
show_heads( [], I, _, I).
show_heads( [H|Hs], I, D, If) :-
arg( 1, H, C),
arg( 2, H, T),
( I>0 -> errnl ; true ),
errtab( I), errprint( C#T),
( Hs=[] ->
If = I
; H=r(_,_), Hs=[k(_,_)|_] ->
errput(0' ), errput(0'\\), errput(0' ),
J is I+D,
show_heads( Hs, J, D, If)
;
errput(0',), errput(0' ),
J is I+D,
show_heads( Hs, J, D, If)
).
show_store( 0) :-
errnl,
global_term_ref_1( Global),
find_constraint_internal( Global, Term, S, active, Module),
module_wrap( Term, Module, Wrapped),
errprint( Wrapped#S), errnl,
fail.
show_store( 1) :-
prolog_flag( debugger_print_options, Options),
errnl,
global_term_ref_1( Global),
find_constraint_internal( Global, Term, S, State, Module),
S =.. [suspension,Id,_,_Closure,Gref,Href|_],
get_mutable( Generation, Gref),
get_mutable( Hist, Href),
assoc_to_list( Hist, History),
module_wrap( Term, Module, Wrapped),
errformat( '~|~t~p~5+ ~|~t~d~3+ ~|~p~t~10+ ~|~@~t~50+ ',
[Id,Generation,State,write_term(Wrapped,Options)]),
show_history( History),
errnl,
fail.
show_store( _) :- errnl.
show_history( []).
show_history( [K-_|Hs]) :-
errprint( K),
( Hs==[] -> true ; errput(0',) ),
show_history( Hs).
set_pd( N) :-
prolog_flag( debugger_print_options, Old),
( select( max_depth(_), Old, Rest) ->
true
;
Rest = Old
),
( N < 0 -> D = 0 ; D = N ),
prolog_flag( debugger_print_options, _, [max_depth(D)|Rest]).
dbg_help :-
errnl,
errwrite('CHR debugging options:'), errnl,
errwrite(' <cr> creep c creep'), errnl,
errwrite(' l leap '), errnl,
errwrite(' s skip s <i> skip i'), errnl,
errwrite(' g ancestors '), errnl,
errwrite(' & constraints & <i> constraints (details)'), errnl,
errwrite(' n nodebug = debugging'), errnl,
errwrite(' + spy this '), errnl,
errwrite(' - nospy this . show rule'), errnl,
errwrite(' < reset printdepth < <n> set printdepth'), errnl,
errwrite(' a abort b break'), errnl,
errwrite(' ? help h help'), errnl,
errnl.
errnl :- nl( user_error).
errput( X) :- put( user_error, X).
errtab( X) :- tab( user_error, X).
errwrite( X) :- write( user_error, X).
errwriteq( X) :- writeq( user_error, X).
errprint( X) :-
prolog_flag( debugger_print_options, Options),
write_term( user_error, X, Options).
errformat( F, A) :- format( user_error, F, A).
% ----------------------------------------------------------
%
% code from the Bips/trace.pl
%
get_command(Command) :-
errwrite(' ? '),
ttyflush,
ttyget0(C1),
get_command(C1, Command).
get_command(0'
, 0'
) :- !.
get_command(C1, Command) :-
ttyget0(C2),
get_args(C2, Args),
( Args = [] -> Command = C1
; Command = [C1|Args]
).
get_args(0'
, []) :- !.
get_args(C1, [Arg|Args]) :-
C1 >= 0'0, C1 =< 0'9, !,
get_arg(C1, 0, Arg, C2),
get_args(C2, Args).
get_args(0'-, [Arg|Args]) :- !,
ttyget0(C2),
get_arg(C2, 0, Arg1, C3),
Arg is -Arg1,
get_args(C3, Args).
get_args(_, Args) :-
ttyget0(C2),
get_args(C2, Args).
get_arg(C1, Arg0, Arg, C) :-
C1 >= 0'0, C1 =< 0'9, !,
Arg1 is Arg0*10 + C1 - 0'0,
ttyget0(C2),
get_arg(C2, Arg1, Arg, C).
get_arg(C1, Arg, Arg, C1).

593
CHR/chr/trace.yap
View File

@ -1,593 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Constraint Handling Rules version 2.2 %
% %
% (c) Copyright 1998 %
% LMU, Muenchen %
% %
% File: trace.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
/*
2 Mechanisms: trace+leash, debug+spy
Debugger integration issue:
We could use conditional spypoints of the Prolog debugger
to get hooked, but then we depend a lot on it ...
:- spypoint_condition( debug_event(E), P, chr:de(P,E)).
Todo:
-) module_wrap/3 for all terms (M as arg to debug_event)
-) guard-fail = rule-delay reason?
*/
:- dynamic spy_rule/2.
:- dynamic spy_constraint/2.
:- initialization
getval( debug, _) -> true ; setval( debug, off).
:- initialization
retractall( spy_rule(_,_)).
:- initialization
retractall( spy_constraint(_,_)).
chr_trace :-
setval( debug, trace),
what_is_on( informational).
chr_notrace :-
setval( debug, off),
what_is_on( informational).
chr_debug :-
setval( debug, debug),
what_is_on( informational).
chr_nodebug :-
chr_notrace.
chr_spy( constraints(Cs)) :-
parse_spy_constraints( Cs, L, []),
member( N/A, L),
assert( spy_constraint(N,A)),
fail.
chr_spy( rules(Rs)) :-
parse_spy_rules( Rs, L, []),
member( Handler:Rule, L),
assert( spy_rule(Rule,Handler)),
fail.
chr_spy( _) :- getval( debug, trace), !.
chr_spy( _) :- chr_debug.
chr_nospy( rules(Rs)) :-
parse_spy_rules( Rs, L1, []),
member( Handler:Rule, L1),
retract( spy_rule(Rule,Handler)),
fail.
chr_nospy( constraints(Cs)) :-
parse_spy_constraints( Cs, L, []),
member( N/A, L),
retract( spy_constraint(N,A)),
fail.
chr_nospy( _).
parse_spy_constraints( C) --> {var(C)}, !, [ _ ].
parse_spy_constraints( (C,Cs)) -->
parse_spy_constraints( C),
parse_spy_constraints( Cs).
parse_spy_constraints( N) --> {atom(N)}, [ N/_ ].
parse_spy_constraints( N/A) --> {atom(N),integer(A),A>0}, [ N/A ].
parse_spy_rules( R) --> {var(R)}, !, [ _ ].
parse_spy_rules( (R,Rs)) --> !,
parse_spy_rules( R),
parse_spy_rules( Rs).
parse_spy_rules( H:R) --> !, [ H:R ].
parse_spy_rules( R) --> [ _:R ]. % any handler
chr_leash( Spec) :-
nonvar( Spec),
chr_leash( Spec, I),
setval( leashing, I),
what_is_leashed( informational).
chr_leash( none, 0) :- !.
chr_leash( off, 0) :- !.
chr_leash( all, -1) :- !.
chr_leash( default, I) :- !, chr_leash( 0, I, [call,wake,apply,exit,fail], []).
chr_leash( L, I) :- chr_leash( 0, I, L, []), !.
chr_leash( X, I) :- chr_leash( 0, I, [X], []).
chr_leash( I, K) --> [call], {J is I\/2'100000000}, chr_leash( J, K).
chr_leash( I, K) --> [wake], {J is I\/2'010000000}, chr_leash( J, K).
chr_leash( I, K) --> [try], {J is I\/2'001000000}, chr_leash( J, K).
chr_leash( I, K) --> [apply], {J is I\/2'000100000}, chr_leash( J, K).
chr_leash( I, K) --> [exit], {J is I\/2'000010000}, chr_leash( J, K).
chr_leash( I, K) --> [redo], {J is I\/2'000001000}, chr_leash( J, K).
chr_leash( I, K) --> [fail], {J is I\/2'000000100}, chr_leash( J, K).
%
chr_leash( I, K) --> [insert], {J is I\/2'000000010}, chr_leash( J, K).
chr_leash( I, K) --> [remove], {J is I\/2'000000001}, chr_leash( J, K).
chr_leash( I, I) --> [].
:- initialization
chr_leash( default, I), setval( leashing, I).
debug_stop( call(S), L, Why) :-
( L/\2'100000000 > 0 -> true
; spypoint_susp( S, Why)
).
debug_stop( wake(S), L, Why) :-
( L/\2'010000000 > 0 -> true
; spypoint_susp( S, Why)
).
debug_stop( exit(S), L, Why) :-
( L/\2'000010000 > 0 -> true
; spypoint_susp( S, Why)
).
debug_stop( redo(S), L, Why) :-
( L/\2'000001000 > 0 -> true
; spypoint_susp( S, Why)
).
debug_stop( fail(S), L, Why) :-
( L/\2'000000100 > 0 -> true
; spypoint_susp( S, Why)
).
%
debug_stop( insert(S), L, Why) :-
( L/\2'000000010 > 0 -> true
; spypoint_susp( S, Why)
).
debug_stop( remove(S), L, Why) :-
( L/\2'000000001 > 0 -> true
; spypoint_susp( S, Why)
).
%
debug_stop( try(H,R,_,Hs,_,_), L, Why) :-
( L/\2'001000000 > 0 -> true
; spy_rule(R,H) -> Why = r
; spypoint_head( Hs, Why)
).
debug_stop( apply(H,R,_,Hs,_,_), L, Why) :-
( L/\2'000100000 > 0 -> true
; spy_rule(R,H) -> Why = r
; spypoint_head( Hs, Why)
).
spypoint_susp( S, c) :-
S =.. [suspension,_,_,_,_,_,N|Args],
length( Args, A),
spy_constraint( N, A).
spypoint_head( Hs, c) :-
member( H, Hs),
arg( 1, H, Term),
functor( Term, N, A),
spy_constraint( N, A).
debug_stop_reason( Why, _) :- nonvar( Why).
debug_stop_reason( Why, Event) :- var( Why),
( debug_stop( Event, 0, Why) ->
true
;
Why = ' '
).
chr_debugging :-
what_is_on( help),
what_is_leashed( help),
what_spypoints( help).
what_is_on( Type) :-
getval( debug, Mode),
print_message( Type, debug(Mode)).
what_is_leashed( Type) :-
getval( leashing, Leash),
findall( P, (chr_leash(0,K,[P],[]),K/\Leash>0), L),
print_message( Type, leash(L)).
what_spypoints( Type) :-
findall( rules(E), (spy_rule(R,H),(var(H)->E=R;E=H:R)), L0, L1),
findall( constraints(E), (spy_constraint(N,A),(var(A)->E=N;E=N/A)), L1, []),
sort( L0, Ls),
print_message( Type, spypoints(Ls)).
% -----------------------------------------------------------------
debug_event( Event) :-
getval( debug, State),
( State == off ->
true
;
debug_event( State, Event),
debug_stack( Event)
).
debug_event( trace, Event) :-
getval( leashing, L),
( debug_stop( Event, L, SpyInd) ->
debug_stop_reason( SpyInd, Event),
debug_show( SpyInd, Event),
get_command( Cmd),
debug_do( Cmd, Event, trace)
;
debug_stop_reason( SpyInd, Event),
debug_show( SpyInd, Event),
errnl
).
debug_event( debug, Event) :-
( debug_stop( Event, 0, SpyInd) ->
debug_show( SpyInd, Event),
get_command( Cmd),
debug_do( Cmd, Event, debug)
;
true
).
debug_event( skip(N,S), Event) :-
stack_depth( M),
( M =< N, member( Event, [exit(_),fail(_)]) ->
setval( debug, S),
debug_event( S, Event)
;
true
).
debug_event( off, _).
debug_stack( Event) :- Event = call(_), !, stack_push( Event).
debug_stack( Event) :- Event = wake(_), !, stack_push( Event).
%
debug_stack( Event) :- Event = apply(_,_,_,_,_,_), !,
stack_pop,
stack_push( Event).
%
debug_stack( exit(_)) :- !, stack_pop.
%
debug_stack( _).
stack_push( S) :-
get_dbg_state( Ref),
get_mutable( Stack, Ref),
update_mutable( [S|Stack], Ref).
stack_pop :-
get_dbg_state( Ref),
get_mutable( [_|Stack], Ref),
update_mutable( Stack, Ref).
stack_depth( Depth) :-
get_dbg_state( Ref),
get_mutable( Stack, Ref),
length( Stack, Depth).
show_stack :-
get_dbg_state( Ref),
get_mutable( Stack, Ref),
length( Stack, N),
errwrite('Ancestors:'), errnl,
show_stack( Stack, N), errnl.
show_stack( [], _).
show_stack( [S|Ss], N) :-
M is N-1,
show_stack( Ss, M),
Spy = ' ',
( arg( 3, S, Hp) -> true ; Hp = '-' ),
functor( S, Port, _),
errformat( ' ~w ~|~t~d~4+ ~|~t~w~3+ ~|~p~t~7+', [Spy,N,Hp,Port]),
debug_show_event( S),
errnl.
debug_show( Spy, Event) :-
functor( Event, Port, _),
( arg( 3, Event, Hp) -> true ; Hp = '-' ),
stack_depth( Depth),
errformat( ' ~w ~|~t~d~4+ ~|~t~w~3+ ~|~p~t~7+', [Spy,Depth,Hp,Port]),
debug_show_event( Event).
debug_show_event( call(S)) :-
debug_susp_term( S, Term), errtab( 1), errprint( Term).
debug_show_event( wake(S)) :-
debug_susp_term( S, Term), errtab( 1), errprint( Term).
debug_show_event( exit(S)) :-
debug_susp_term( S, Term), errtab( 1), errprint( Term).
debug_show_event( redo(S)) :-
debug_susp_term( S, Term), errtab( 1), errprint( Term).
debug_show_event( fail(S)) :-
debug_susp_term( S, Term), errtab( 1), errprint( Term).
debug_show_event( remove(S)) :-
debug_susp_term( S, Term), errtab( 1), errprint( Term).
debug_show_event( insert(C)) :-
errtab( 1), errprint( C).
debug_show_event( try(Handler,Rule,_,Heads,_,_)) :-
errformat( ' ~p:~p @ ', [Handler,Rule]),
show_heads( Heads, 0, 0, _).
debug_show_event( apply(Handler,Rule,_,Heads,_,_)) :-
errformat( ' ~p:~p @ ', [Handler,Rule]),
show_heads( Heads, 0, 0, _).
debug_susp_term( S, Term#S) :-
S =.. [suspension,_,_,_,_,_,F|Args],
Term =.. [F|Args].
debug_do( 0'a, _, _) :- !, abort.
debug_do( 0'n, _, _) :- !, chr_notrace.
debug_do( 0'&, E, S) :- !, show_store( 0), debug_event( S, E).
debug_do( [0'&|_], E, S) :- !, show_store( 1), debug_event( S, E).
debug_do( 0'g, E, S) :- !, show_stack, debug_event( S, E).
debug_do( 0'., E, S) :-
dbg_at_rule( E, _, _),
!,
show_rule( E),
debug_event( S, E).
debug_do( 0'+, E, S) :- !,
( dbg_at_rule( E, Handler, Rule) ->
chr_spy( rules( Handler:Rule))
; dbg_at_constraint( E, N, A) ->
chr_spy( constraints( N/A))
),
debug_event( S, E).
debug_do( 0'-, E, S) :- !,
( dbg_at_rule( E, Handler, Rule) ->
chr_nospy( rules( Handler:Rule))
; dbg_at_constraint( E, N, A) ->
chr_nospy( constraints( N/A))
),
debug_event( S, E).
debug_do( 0'b, E, S) :- !,
setval( debug, off),
break,
setval( debug, S),
debug_event( S, E).
debug_do( 0'
, _, _) :- !, setval( debug, trace). % CR = creep
debug_do( 0'c, _, _) :- !, setval( debug, trace). % creep
debug_do( 0'l, _, _) :- !, setval( debug, debug). % leap
debug_do( 0's, E, S) :- chr_skip( E, S, _), !. % skip
debug_do( [0's,N], E, S) :- chr_skip( E, S, N), !. % skip
debug_do( 0'<, E, S) :- !, set_pd(10), debug_event( S, E).
debug_do( [0'<,N], E, S) :- !, set_pd(N), debug_event( S, E).
debug_do( 0'=, E, S) :- !, chr_debugging, debug_event( S, E).
debug_do( 0'?, E, S) :- !, dbg_help, debug_event( S, E).
debug_do( 0'h, E, S) :- !, dbg_help, debug_event( S, E).
debug_do( _, E, S) :-
print_message( informational, wrong_option),
debug_event( S, E).
chr_skip( E, S, K) :- E = exit(_), stack_depth( K), !, debug_event( S, E).
chr_skip( E, S, K) :- E = fail(_), stack_depth( K), !, debug_event( S, E).
chr_skip( _, S, K) :-
stack_depth( Depth),
( var(K) ->
N is Depth+1
;
1 =< K, K =< Depth,
N = K
),
setval( debug, skip(N,S)).
dbg_at_rule( try(Handler,Rule,_,_,_,_), Handler, Rule).
dbg_at_rule( apply(Handler,Rule,_,_,_,_), Handler, Rule).
dbg_at_constraint( E, N, A) :-
dbg_at_constraint( E, S),
S =.. [suspension,_,_,_,_,_,N|Args],
length( Args, A).
dbg_at_constraint( call(S), S).
dbg_at_constraint( wake(S), S).
dbg_at_constraint( exit(S), S).
dbg_at_constraint( redo(S), S).
dbg_at_constraint( fail(S), S).
dbg_at_constraint( insert(S), S).
dbg_at_constraint( remove(S), S).
%
% numbervars binds variables ...
%
show_rule( Event) :-
Event =.. [Which,Handler,Rule,_,Heads,Guard,Body],
member( Which, [try,apply]),
current_handler( Handler, _),
!,
show_rule( Rule, Heads, Guard, Body).
show_rule( _).
show_rule :-
chrcmp:rule( _, _, Name, Heads, Guard, Body, _),
numbervars( Heads/Name/Guard/Body, 0, _),
show_rule( Name, Heads, Guard, Body),
fail.
show_rule.
show_rule( Name, Heads, Guard, Body) :-
errformat( '~n ~p @', [Name]),
show_heads( Heads, 2, 2, Ident),
( member( k(_,_), Heads) ->
errformat( ' <=>~n~n', [])
;
errformat( ' ==>~n~n', [])
),
( Guard==true ->
show_body( Body, Ident)
;
show_body( Guard, Ident), errnl,
errtab( Ident), errwrite( '|'), errnl,
show_body( Body, Ident)
),
errput( 0'.), errnl, errnl.
show_body( (A,B), Tab) :- !,
show_body( A, Tab),
errwrite( ','), errnl,
show_body( B, Tab).
show_body( (A->B;C), Tab) :- !,
errtab( Tab), errwrite( '('), errnl,
NTab1 is Tab+2,
NTab2 is Tab+5,
show_body( A, NTab1),
errwrite( ' ->'), errnl,
show_body( B, NTab2), errnl,
errtab( Tab), errwrite( ';'), errnl,
show_body( C, NTab2), errnl,
errtab( Tab), errwrite( ')').
show_body( (A->B), Tab) :- !,
errtab( Tab), errwrite( '('), errnl,
NTab1 is Tab+2,
NTab2 is Tab+5,
show_body( A, NTab1),
errwrite( ' ->'), errnl,
show_body( B, NTab2), errnl,
errtab( Tab), errwrite( ')').
show_body( (A;B), Tab) :- !,
errtab( Tab), errwrite( '('), errnl,
NTab is Tab+5,
show_body( A, NTab), errnl,
errtab( Tab), errwrite( ';'), errnl,
show_body( B, NTab), errnl,
errtab( Tab), errwrite( ')').
show_body( A, Tab) :-
errtab( Tab),
errwriteq( A).
show_heads( [], I, _, I).
show_heads( [H|Hs], I, D, If) :-
arg( 1, H, C),
arg( 2, H, T),
( I>0 -> errnl ; true ),
errtab( I), errprint( C#T),
( Hs=[] ->
If = I
; H=r(_,_), Hs=[k(_,_)|_] ->
errput(0' ), errput(0'\\ ), errput(0' ),
J is I+D,
show_heads( Hs, J, D, If)
;
errput(0',), errput(0' ),
J is I+D,
show_heads( Hs, J, D, If)
).
show_store( 0) :-
errnl,
global_term_ref_1( Global),
find_constraint_internal( Global, Term, S, active, Module),
module_wrap( Term, Module, Wrapped),
errprint( Wrapped#S), errnl,
fail.
show_store( 1) :-
prolog_flag( debugger_print_options, Options),
errnl,
global_term_ref_1( Global),
find_constraint_internal( Global, Term, S, State, Module),
S =.. [suspension,Id,_,_Closure,Gref,Href|_],
get_mutable( Generation, Gref),
get_mutable( Hist, Href),
assoc_to_list( Hist, History),
module_wrap( Term, Module, Wrapped),
errformat( '~|~t~p~5+ ~|~t~d~3+ ~|~p~t~10+ ~|~@~t~50+ ',
[Id,Generation,State,write_term(Wrapped,Options)]),
show_history( History),
errnl,
fail.
show_store( _) :- errnl.
show_history( []).
show_history( [K-_|Hs]) :-
errprint( K),
( Hs==[] -> true ; errput(0',) ),
show_history( Hs).
set_pd( N) :-
prolog_flag( debugger_print_options, Old),
( select( max_depth(_), Old, Rest) ->
true
;
Rest = Old
),
( N < 0 -> D = 0 ; D = N ),
prolog_flag( debugger_print_options, _, [max_depth(D)|Rest]).
dbg_help :-
errnl,
errwrite('CHR debugging options:'), errnl,
errwrite(' <cr> creep c creep'), errnl,
errwrite(' l leap '), errnl,
errwrite(' s skip s <i> skip i'), errnl,
errwrite(' g ancestors '), errnl,
errwrite(' & constraints & <i> constraints (details)'), errnl,
errwrite(' n nodebug = debugging'), errnl,
errwrite(' + spy this '), errnl,
errwrite(' - nospy this . show rule'), errnl,
errwrite(' < reset printdepth < <n> set printdepth'), errnl,
errwrite(' a abort b break'), errnl,
errwrite(' ? help h help'), errnl,
errnl.
errnl :- nl( user_error).
errput( X) :- put( user_error, X).
errtab( X) :- tab( user_error, X).
errwrite( X) :- write( user_error, X).
errwriteq( X) :- writeq( user_error, X).
errprint( X) :-
prolog_flag( debugger_print_options, Options),
write_term( user_error, X, Options).
errformat( F, A) :- format( user_error, F, A).
% ----------------------------------------------------------
%
% code from the Bips/trace.pl
%
get_command(Command) :-
errwrite(' ? '),
ttyflush,
ttyget0(C1),
get_command(C1, Command).
get_command(0'
, 0'
) :- !.
get_command(C1, Command) :-
ttyget0(C2),
get_args(C2, Args),
( Args = [] -> Command = C1
; Command = [C1|Args]
).
get_args(0'
, []) :- !.
get_args(C1, [Arg|Args]) :-
C1 >= 0'0, C1 =< 0'9, !,
get_arg(C1, 0, Arg, C2),
get_args(C2, Args).
get_args(0'-, [Arg|Args]) :- !,
ttyget0(C2),
get_arg(C2, 0, Arg1, C3),
Arg is -Arg1,
get_args(C3, Args).
get_args(_, Args) :-
ttyget0(C2),
get_args(C2, Args).
get_arg(C1, Arg0, Arg, C) :-
C1 >= 0'0, C1 =< 0'9, !,
Arg1 is Arg0*10 + C1 - 0'0,
ttyget0(C2),
get_arg(C2, Arg1, Arg, C).
get_arg(C1, Arg, Arg, C1).