port of LGPLed CHR
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1416 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc
parent
1fa46c6051
commit
4d94446c25
208
LGPL/chr/Changelog
Normal file
208
LGPL/chr/Changelog
Normal file
@ -0,0 +1,208 @@
|
||||
Sep 2, 2005
|
||||
|
||||
* TS: Synchronized with hProlog.
|
||||
|
||||
Aug 31, 2005
|
||||
|
||||
* TS: Added missing operator declarations for prefix (?).
|
||||
|
||||
Aug 9, 2005
|
||||
|
||||
* JW: import lists into chr_compiler_utility.pl
|
||||
|
||||
* JW: make message hook for query(yes) detect CHR global variables.
|
||||
|
||||
* JW: Exported pairlist_delete_eq/3 from pairlist and use this in
|
||||
chr_hashtable_store.pl
|
||||
|
||||
Aug 4, 2005
|
||||
|
||||
* TS: Renamed pairlist:delete/3 to pairlist:pairlist_delete/3.
|
||||
Mike Elston.
|
||||
Aug 1, 2005
|
||||
|
||||
* TS: Extended more efficient ground matching code to
|
||||
removed simpagation occurrence code.
|
||||
|
||||
Jul 28, 2005
|
||||
|
||||
* TS: New input verification: duplicate constraint declaration
|
||||
now reported as an error. Requested by Mike Elston.
|
||||
* TS: More efficient matching code for ground constraints
|
||||
when matching an argument of a partner constraint with
|
||||
a ground term
|
||||
* JS: Bug fix in guard simplification.
|
||||
|
||||
Jul 3, 2005
|
||||
|
||||
* TS: Factored out option functionality into separate module.
|
||||
* TS: Factored out utility code into separate module.
|
||||
|
||||
Jun 29, 2005
|
||||
|
||||
* TS: Changed chr_show_store/1 to use print/1 instead of write/1.
|
||||
|
||||
Jun 28, 2005
|
||||
|
||||
* TS: Removed spurious and conflicting operator definitions
|
||||
for +, - and ? as mode declarations.
|
||||
|
||||
Jun 27, 2005
|
||||
|
||||
* TS: Added find_chr_constraint/1 functionality.
|
||||
|
||||
Jun 8, 2005
|
||||
|
||||
* TS: Improved compiler scalability: use nb_setval/2 to
|
||||
remember compiled code through backtracking over
|
||||
compilation process instead of assert/1.
|
||||
* TS: Removed spurious comma from file.
|
||||
|
||||
Jun 1, 2005
|
||||
|
||||
* TS: Added option to disable toplevel constraint store printing.
|
||||
* TS: Slightly improved hash table constraint store implementation.
|
||||
|
||||
Apr 16, 2005
|
||||
|
||||
* JW: Added patch from Jon Sneyers.
|
||||
|
||||
Mar 11, 2005
|
||||
|
||||
* TS: Improved head reordering heuristic.
|
||||
* TS: Added support primitive for alternate built-in solver dependency.
|
||||
|
||||
Mar 4, 2005
|
||||
|
||||
* TS: Fixed bug that causes wrong output in chr_show_store.
|
||||
|
||||
Feb 25, 2005
|
||||
|
||||
* TS: Fixed several bugs in generation of debugable code.
|
||||
|
||||
Feb 19, 2005
|
||||
|
||||
* JW: Cleanup integration in SWI-Prolog environment:
|
||||
- Extended SWI-Prolog library ordsets. Renamed ord_delete/3 to
|
||||
ord_del_element/3 and ord_difference/3 to ord_subtract/3 for
|
||||
better compatibility.
|
||||
- Renamed module find to chr_find to avoid name conflict and declared
|
||||
preds as meta-predicate.
|
||||
- Re-inserted and exported strip_attributes/2 and
|
||||
restore_attributes/2 in hprolog.pl. Deleted hprolog: from
|
||||
chr_translate.chr.
|
||||
- Added dummy option declarations to bootstrap compiler.
|
||||
- Fixed path problems in makefile (-p chr=.) and install new
|
||||
components.
|
||||
- Fixed typo 'chr show_store' --> chr_show_store.
|
||||
|
||||
Feb 17, 2005
|
||||
|
||||
* JS: Added guard entailment optimizations and
|
||||
new syntax for type and mode declarations.
|
||||
|
||||
Dec 15, 2004
|
||||
|
||||
* TS: Use prolog:message/3 hook to automatically print
|
||||
contents of CHR constraint stores with query bindings
|
||||
on toplevel.
|
||||
|
||||
Dec 3, 2004
|
||||
|
||||
* TS: Bugfix in code generation. Reported by Lyosha Ilyukhin.
|
||||
|
||||
Jul 28, 2004
|
||||
|
||||
* TS: Updated hashtable stores. They now start small and expand.
|
||||
|
||||
Jul 19, 2004
|
||||
|
||||
* JW: Removed chr_pp: module prefixes
|
||||
* JW: Updated Windows makefile.mak (more similar organisation, added check)
|
||||
|
||||
Jul 17, 2004
|
||||
|
||||
* TS: Added chr_hashtable_store library.
|
||||
* TS: Added find library.
|
||||
* TS: Added builtins library.
|
||||
* TS: Added clean_code library.
|
||||
* TS: Added binomial_heap library.
|
||||
* TS: Added a_star library.
|
||||
* TS: Added new intermediate bootstrapping step
|
||||
* TS: Synchronized CHR compiler with most recent development version
|
||||
|
||||
Summary of changes:
|
||||
|
||||
"The new version of the compiler contains several new optimizations, both
|
||||
fully automatic, such as the antimonotny-based delay avoidance (see
|
||||
http://www.cs.kuleuven.ac.be/publicaties/rapporten/cw/CW385.abs.html for
|
||||
the technical report), and enabled by mode declarations (see CHR
|
||||
documentation), such as hashtable-based constraint indexes."
|
||||
|
||||
Apr 9, 2004
|
||||
|
||||
* JW: Added chr_messages.pl. Make all debug messages use the print_message/2
|
||||
interface to enable future embedding.
|
||||
|
||||
Apr 7, 2004
|
||||
|
||||
* JW: Added chr:debug_interact/3 hook. Defined in chr_swi.pl to void
|
||||
showing constraints first as goal and then as CHR call.
|
||||
* JW: Added chr:debug_event/2 hook. Defined in chr_swi.pl to make the
|
||||
CHR debugger honour a skip command from the Prolog tracer.
|
||||
|
||||
Apr 6, 2004
|
||||
|
||||
* JW: Added b (break) to the CHR debugger.
|
||||
* TS: added chr_expandable/2 clause for pragma/2
|
||||
|
||||
Apr 5, 2004
|
||||
|
||||
* JW: fixed reference to format_rule/2.
|
||||
* JW: Use select/3 rather than delete/3 in diff/2 in Tests/zebra.pl
|
||||
* TS: CHR translation now leaves CHR store empty
|
||||
|
||||
Apr 4, 2004
|
||||
|
||||
* JW: added :- use_module(library(chr)) to all examples.
|
||||
* JW: mapped -O --> option(optimize, full).
|
||||
* JW: introduced file-search-path `chr' for clarity and to enable running
|
||||
make check from the local environment instead of the public installation.
|
||||
* JW: mapped prolog flag generate_debug_info --> option(debug, on)
|
||||
* JW: Replaced the chr -> pl step with term_expansion/2.
|
||||
* JW: Moved insert_declarations/2 to chr_swi.pl
|
||||
|
||||
Apr 2, 2004
|
||||
|
||||
* JW: fixed Undefined procedure: chr_runtime:run_suspensions_loop_d/1
|
||||
* TS: Added <space> for creep and shortened debug line prefix to CHR:
|
||||
|
||||
Mar 29, 2004
|
||||
|
||||
* JW: Use \+ \+ in chr_compile/3 to undo changes to the constraint
|
||||
pool. Regression test suite using "make check" works again.
|
||||
|
||||
Mar 25, 2004
|
||||
|
||||
* TS: Added skip and ancestor debug commands
|
||||
|
||||
Mar 24, 2004
|
||||
|
||||
* TS: Added bootstrapping process for CHR compiler using CHR.
|
||||
* TS: CHR compiler now uses CHR.
|
||||
* TS: Fixed bug in compilation of multi-headed simpagation rules.
|
||||
* TS: Cleaned up compiler.
|
||||
* TS: Added analysis + optimization for never attached constraints.
|
||||
* TS: Exploit uniqueness (functional dependency) results to detect
|
||||
set semantics type simpagation rules where one rule can be passive
|
||||
* TS: Compiler generates 'chr debug_event'/1 calls
|
||||
* TS: Rudimentary support for debugging.
|
||||
option(debug,on) causes a trace of CHR events to be printed
|
||||
|
||||
Mar 15, 2004
|
||||
|
||||
* JW: Fix operator handling.
|
||||
|
||||
Mar 3, 2004
|
||||
|
||||
* JW: Integrated new version from Tom Schrijvers.
|
||||
148
LGPL/chr/Makefile.in
Normal file
148
LGPL/chr/Makefile.in
Normal file
@ -0,0 +1,148 @@
|
||||
#
|
||||
# default base directory for YAP installation
|
||||
# (EROOT for architecture-dependent files)
|
||||
#
|
||||
prefix = @prefix@
|
||||
ROOTDIR = $(prefix)
|
||||
EROOTDIR = @exec_prefix@
|
||||
|
||||
srcdir=@srcdir@
|
||||
|
||||
SHELL=@SHELL@
|
||||
PLBASE=@PLBASE@
|
||||
PLARCH=@PLARCH@
|
||||
PL="../../yap"
|
||||
XPCEBASE=$(PLBASE)/xpce
|
||||
PKGDOC=$(PLBASE)/doc/packages
|
||||
PCEHOME=../../xpce
|
||||
LIBDIR=$(PLBASE)/library
|
||||
SHAREDIR=$(ROOTDIR)/share/Yap
|
||||
CHRDIR=$(SHAREDIR)/chr
|
||||
EXDIR=$(CHRDIR)/examples/chr
|
||||
DESTDIR=
|
||||
LN_S=@LN_S@
|
||||
|
||||
DOCTOTEX=$(PCEHOME)/bin/doc2tex
|
||||
PLTOTEX=$(PCEHOME)/bin/pl2tex
|
||||
LATEX=latex
|
||||
DOC=chr
|
||||
TEX=$(DOC).tex
|
||||
DVI=$(DOC).dvi
|
||||
PDF=$(DOC).pdf
|
||||
HTML=$(DOC).html
|
||||
|
||||
INSTALL=@INSTALL@
|
||||
INSTALL_PROGRAM=@INSTALL_PROGRAM@
|
||||
INSTALL_DATA=@INSTALL_DATA@
|
||||
|
||||
|
||||
LIBPL= $(srcdir)/chr_runtime.pl $(srcdir)/chr_op.pl chr_translate.pl $(srcdir)/chr_debug.pl \
|
||||
$(srcdir)/chr_messages.pl $(srcdir)/hprolog.yap $(srcdir)/pairlist.pl $(srcdir)/clean_code.pl \
|
||||
$(srcdir)/find.pl $(srcdir)/a_star.pl $(srcdir)/binomialheap.pl $(srcdir)/builtins.pl \
|
||||
$(srcdir)/chr_hashtable_store.pl $(srcdir)/listmap.pl guard_entailment.pl \
|
||||
$(srcdir)/chr_compiler_options.pl $(srcdir)/chr_compiler_utility.pl
|
||||
CHRPL= $(srcdir)/chr_swi.pl
|
||||
CHRYAP= $(srcdir)/chr.yap
|
||||
EXAMPLES= $(srcdir)/Benchmarks/chrfreeze.chr $(srcdir)/Benchmarks/fib.chr $(srcdir)/Benchmarks/gcd.chr $(srcdir)/Benchmarks/primes.chr \
|
||||
$(srcdir)/Benchmarks/bool.chr $(srcdir)/Benchmarks/family.chr $(srcdir)/Benchmarks/fibonacci.chr $(srcdir)/Benchmarks/leq.chr $(srcdir)/Benchmarks/listdom.chr \
|
||||
$(srcdir)/Benchmarks/chrdif.chr
|
||||
|
||||
all: chr_translate.pl
|
||||
|
||||
chr_translate_bootstrap1.pl: $(srcdir)/chr_translate_bootstrap1.chr
|
||||
$(PL) -l chr_swi_bootstrap.yap \
|
||||
-g "chr_compile_step1('$<','$@'),halt." \
|
||||
-z 'halt(1).'
|
||||
$(PL) -l chr_swi_bootstrap.yap \
|
||||
-g "chr_compile_step2('$<','$@'),halt." \
|
||||
-z 'halt(1).'
|
||||
|
||||
chr_translate_bootstrap2.pl: $(srcdir)/chr_translate_bootstrap2.chr
|
||||
$(PL) -l chr_swi_bootstrap.yap \
|
||||
-g "chr_compile_step2('$<','$@'),halt." \
|
||||
-z 'halt(1).'
|
||||
$(PL) -l chr_swi_bootstrap.yap \
|
||||
-g "chr_compile_step3('$<','$@'),halt." \
|
||||
-z 'halt(1).'
|
||||
|
||||
guard_entailment.pl: $(srcdir)/guard_entailment.chr chr_translate_bootstrap2.pl
|
||||
$(PL) -l chr_swi_bootstrap.yap \
|
||||
-g "chr_compile_step3('$<','$@'),halt." \
|
||||
-z 'halt(1).'
|
||||
|
||||
chr_translate.pl: $(srcdir)/chr_translate.chr chr_translate_bootstrap2.pl guard_entailment.pl
|
||||
$(PL) -l chr_swi_bootstrap.yap \
|
||||
-g "chr_compile_step3('$<','$@'),halt." \
|
||||
-z 'halt(1).'
|
||||
$(PL) -p chr=. -l chr_swi_bootstrap.yap \
|
||||
-g "chr_compile_step4('guard_entailment.chr','guard_entailment.pl'),halt." \
|
||||
-z 'halt(1).'
|
||||
$(PL) -p chr=. -l chr_swi_bootstrap.yap \
|
||||
-g "chr_compile_step4('$<','$@'),halt." \
|
||||
-z 'halt(1).'
|
||||
|
||||
chr.pl: chr_swi.pl
|
||||
cp $< $@
|
||||
|
||||
install: chr_translate.pl guard_entailment.pl
|
||||
mkdir -p $(DESTDIR)$(CHRDIR)
|
||||
$(INSTALL) -m 644 $(LIBPL) $(DESTDIR)$(CHRDIR)
|
||||
$(INSTALL) -m 644 $(CHRPL) $(DESTDIR)$(SHAREDIR)/chr.pl
|
||||
$(INSTALL) -m 644 $(CHRYAP) $(DESTDIR)$(SHAREDIR)
|
||||
$(INSTALL) -m 644 $(srcdir)/README $(DESTDIR)$(CHRDIR)
|
||||
# $(PL) -g make -z halt
|
||||
|
||||
rpm-install: install
|
||||
|
||||
pdf-install: install-examples
|
||||
|
||||
html-install: install-examples
|
||||
|
||||
install-examples::
|
||||
mkdir -p $(DESTDIR)$(EXDIR)
|
||||
(cd Examples && $(INSTALL_DATA) $(EXAMPLES) $(DESTDIR)$(EXDIR))
|
||||
|
||||
uninstall:
|
||||
(cd $(PLBASE)/library && rm -f $(LIBPL))
|
||||
$(PL) -f none -g make -t halt
|
||||
|
||||
check: chr.pl
|
||||
$(PL) -f chr_test.pl -g test,halt -t 'halt(1)'
|
||||
|
||||
|
||||
################################################################
|
||||
# Documentation
|
||||
################################################################
|
||||
|
||||
doc: $(PDF) $(HTML)
|
||||
pdf: $(PDF)
|
||||
html: $(HTML)
|
||||
|
||||
$(HTML): $(TEX)
|
||||
latex2html $(DOC)
|
||||
mv html/index.html $@
|
||||
|
||||
$(PDF): $(TEX)
|
||||
runtex --pdf $(DOC)
|
||||
|
||||
$(TEX): $(DOCTOTEX)
|
||||
|
||||
.doc.tex:
|
||||
$(DOCTOTEX) $*.doc > $*.tex
|
||||
.pl.tex:
|
||||
$(PLTOTEX) $*.pl > $*.tex
|
||||
|
||||
################################################################
|
||||
# Clean
|
||||
################################################################
|
||||
|
||||
clean:
|
||||
rm -f *~ *% config.log
|
||||
rm -f chr.pl chr_translate.pl
|
||||
rm -f chr_translate_bootstrap1.pl chr_translate_bootstrap2.pl
|
||||
rm -f guard_entailment.pl
|
||||
|
||||
distclean: clean
|
||||
rm -f $(TARGETS) config.h config.cache config.status Makefile
|
||||
rm -f $(TEX)
|
||||
runtex --clean $(DOC)
|
||||
141
LGPL/chr/Makefile.yap
Normal file
141
LGPL/chr/Makefile.yap
Normal file
@ -0,0 +1,141 @@
|
||||
################################################################
|
||||
# SWI-Prolog CHR package
|
||||
# Author: Jan Wielemaker. jan@swi.psy.uva.nl
|
||||
# Copyright: LGPL (see COPYING or www.gnu.org
|
||||
################################################################
|
||||
|
||||
.SUFFIXES: .tex .dvi .doc .pl
|
||||
|
||||
SHELL=/bin/sh
|
||||
PLBASE=/usr/lib/pl-5.5.31
|
||||
#PL=~/Yap/bins/devel/yap
|
||||
PL=~/osx/yap
|
||||
XPCEBASE=$(PLBASE)/xpce
|
||||
PKGDOC=$(PLBASE)/doc/packages
|
||||
PCEHOME=../../xpce
|
||||
LIBDIR=$(PLBASE)/library
|
||||
CHRDIR=$(LIBDIR)/chr
|
||||
EXDIR=$(PKGDOC)/examples/chr
|
||||
DESTDIR=
|
||||
|
||||
DOCTOTEX=$(PCEHOME)/bin/doc2tex
|
||||
PLTOTEX=$(PCEHOME)/bin/pl2tex
|
||||
LATEX=latex
|
||||
DOC=chr
|
||||
TEX=$(DOC).tex
|
||||
DVI=$(DOC).dvi
|
||||
PDF=$(DOC).pdf
|
||||
HTML=$(DOC).html
|
||||
|
||||
INSTALL=/usr/bin/install -c
|
||||
INSTALL_PROGRAM=${INSTALL}
|
||||
INSTALL_DATA=/usr/bin/install -c -m 644
|
||||
|
||||
LIBPL= chr_runtime.pl chr_op.pl chr_translate.pl chr_debug.pl \
|
||||
chr_messages.pl hprolog.pl pairlist.pl clean_code.pl \
|
||||
find.pl a_star.pl binomialheap.pl builtins.pl \
|
||||
chr_hashtable_store.pl listmap.pl guard_entailment.pl \
|
||||
chr_compiler_options.pl chr_compiler_utility.pl
|
||||
CHRPL= chr_swi.pl
|
||||
EXAMPLES= chrfreeze.chr fib.chr gcd.chr primes.chr \
|
||||
bool.chr family.chr fibonacci.chr leq.chr listdom.chr \
|
||||
chrdif.chr
|
||||
|
||||
all: chr_translate.pl
|
||||
|
||||
chr_translate_bootstrap1.pl: chr_translate_bootstrap1.chr
|
||||
$(PL) -l chr_swi_bootstrap.yap \
|
||||
-g "chr_compile_step1('$<','$@'),halt." \
|
||||
-z 'halt(1).'
|
||||
$(PL) -l chr_swi_bootstrap.yap \
|
||||
-g "chr_compile_step2('$<','$@'),halt." \
|
||||
-z 'halt(1).'
|
||||
|
||||
chr_translate_bootstrap2.pl: chr_translate_bootstrap2.chr chr_translate_bootstrap1.pl
|
||||
$(PL) -l chr_swi_bootstrap.yap \
|
||||
-g "chr_compile_step2('$<','$@'),halt." \
|
||||
-z 'halt(1).'
|
||||
$(PL) -l chr_swi_bootstrap.yap \
|
||||
-g "chr_compile_step3('$<','$@'),halt." \
|
||||
-z 'halt(1).'
|
||||
|
||||
guard_entailment.pl: guard_entailment.chr chr_translate_bootstrap2.pl
|
||||
$(PL) -l chr_swi_bootstrap.yap \
|
||||
-g "chr_compile_step3('$<','$@'),halt." \
|
||||
-z 'halt(1).'
|
||||
|
||||
chr_translate.pl: chr_translate.chr chr_translate_bootstrap2.pl guard_entailment.pl
|
||||
$(PL) -l chr_swi_bootstrap.yap \
|
||||
-g "chr_compile_step3('$<','$@'),halt." \
|
||||
-z 'halt(1)'
|
||||
$(PL) -p chr=. -l chr_swi_bootstrap.yap \
|
||||
-g "chr_compile_step4('guard_entailment.chr','guard_entailment.pl'),halt." \
|
||||
-z 'halt(1).'
|
||||
$(PL) -p chr=. -l chr_swi_bootstrap.yap \
|
||||
-g "chr_compile_step4('$<','$@'),halt." \
|
||||
-z 'halt(1).'
|
||||
|
||||
chr.pl: chr_swi.pl
|
||||
cp $< $@
|
||||
|
||||
install: $(LIBPL)
|
||||
mkdir -p $(DESTDIR)$(CHRDIR)
|
||||
$(INSTALL) -m 644 $(LIBPL) $(DESTDIR)$(CHRDIR)
|
||||
$(INSTALL) -m 644 $(CHRPL) $(DESTDIR)$(LIBDIR)/chr.pl
|
||||
$(INSTALL) -m 644 README $(DESTDIR)$(CHRDIR)
|
||||
$(PL) -f none -g make -z halt
|
||||
|
||||
rpm-install: install
|
||||
|
||||
pdf-install: install-examples
|
||||
|
||||
html-install: install-examples
|
||||
|
||||
install-examples::
|
||||
mkdir -p $(DESTDIR)$(EXDIR)
|
||||
(cd Examples && $(INSTALL_DATA) $(EXAMPLES) $(DESTDIR)$(EXDIR))
|
||||
|
||||
uninstall:
|
||||
(cd $(PLBASE)/library && rm -f $(LIBPL))
|
||||
$(PL) -f none -g make -z halt
|
||||
|
||||
check: chr.pl
|
||||
$(PL) -f chr_test.pl -g "test,halt." -z 'halt(1).'
|
||||
|
||||
|
||||
################################################################
|
||||
# Documentation
|
||||
################################################################
|
||||
|
||||
doc: $(PDF) $(HTML)
|
||||
pdf: $(PDF)
|
||||
html: $(HTML)
|
||||
|
||||
$(HTML): $(TEX)
|
||||
latex2html $(DOC)
|
||||
mv html/index.html $@
|
||||
|
||||
$(PDF): $(TEX)
|
||||
runtex --pdf $(DOC)
|
||||
|
||||
$(TEX): $(DOCTOTEX)
|
||||
|
||||
.doc.tex:
|
||||
$(DOCTOTEX) $*.doc > $*.tex
|
||||
.pl.tex:
|
||||
$(PLTOTEX) $*.pl > $*.tex
|
||||
|
||||
################################################################
|
||||
# Clean
|
||||
################################################################
|
||||
|
||||
clean:
|
||||
rm -f *~ *% config.log
|
||||
rm -f chr.pl chr_translate.pl
|
||||
rm -f chr_translate_bootstrap1.pl chr_translate_bootstrap2.pl
|
||||
rm -f guard_entailment.pl
|
||||
|
||||
distclean: clean
|
||||
rm -f $(TARGETS) config.h config.cache config.status Makefile
|
||||
rm -f $(TEX)
|
||||
runtex --clean $(DOC)
|
||||
47
LGPL/chr/README
Normal file
47
LGPL/chr/README
Normal file
@ -0,0 +1,47 @@
|
||||
CHR for SWI-Prolog
|
||||
==================
|
||||
|
||||
Authors and license
|
||||
====================
|
||||
|
||||
This package contains code from the following authors. All code is
|
||||
distributed under the SWI-Prolog conditions with permission from the
|
||||
authors.
|
||||
|
||||
|
||||
* Tom Schrijvers, K.U.Leuven Tom.Schrijvers@cs.kuleuven.ac
|
||||
* Christian Holzbaur christian@ai.univie.ac.at
|
||||
* Jan Wielemaker jan@swi-prolog.org
|
||||
|
||||
|
||||
Files and their roles:
|
||||
======================
|
||||
|
||||
# library(chr) chr_swi.pl
|
||||
Make user-predicates and hooks for loading CHR files available
|
||||
to the user.
|
||||
|
||||
# library(chr/chr_op)
|
||||
Include file containing the operator declaractions
|
||||
|
||||
# library(chr/chr_translate)
|
||||
Core translation module. Defines chr_translate/2.
|
||||
|
||||
# library(chr/chr_debug)
|
||||
Debugging routines, made available to the user through
|
||||
library(chr). Very incomplete.
|
||||
|
||||
# library(chr/hprolog)
|
||||
Compatibility to hProlog. Should be abstracted.
|
||||
|
||||
# library(chr/pairlist)
|
||||
Deal with lists of Name-Value. Used by chr_translate.pl
|
||||
|
||||
|
||||
Status
|
||||
======
|
||||
|
||||
Work in progress. The compiler source (chr_translate.pl) contains
|
||||
various `todo' issues. The debugger is almost non existent. Future work
|
||||
should improve on the compatibility with the reference CHR
|
||||
documentation. Details on loading CHR files are subject to change.
|
||||
53
LGPL/chr/a_star.pl
Normal file
53
LGPL/chr/a_star.pl
Normal file
@ -0,0 +1,53 @@
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
% Author: Tom Schrijvers
|
||||
% Email: Tom.Schrijvers@cs.kuleuven.ac.be
|
||||
% Copyright: K.U.Leuven 2004
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
:- module(a_star,
|
||||
[
|
||||
a_star/4
|
||||
]).
|
||||
|
||||
:- use_module(library(lists)).
|
||||
|
||||
:- use_module(binomialheap).
|
||||
|
||||
:- use_module(find).
|
||||
|
||||
:- use_module(hprolog).
|
||||
|
||||
a_star(DataIn,FinalData,ExpandData,DataOut) :-
|
||||
a_star_node(DataIn,0,InitialNode),
|
||||
empty_q(NewQueue),
|
||||
insert_q(NewQueue,InitialNode,Queue),
|
||||
a_star_aux(Queue,FinalData,ExpandData,EndNode),
|
||||
a_star_node(DataOut,_,EndNode).
|
||||
|
||||
a_star_aux(Queue,FinalData,ExpandData,EndNode) :-
|
||||
delete_min_q(Queue,Queue1,Node),
|
||||
( final_node(FinalData,Node) ->
|
||||
Node = EndNode
|
||||
;
|
||||
expand_node(ExpandData,Node,Nodes),
|
||||
insert_list_q(Nodes,Queue1,NQueue),
|
||||
a_star_aux(NQueue,FinalData,ExpandData,EndNode)
|
||||
).
|
||||
|
||||
final_node(D^Call,Node) :-
|
||||
a_star_node(Data,_,Node),
|
||||
term_variables(Call,Vars),
|
||||
chr_delete(Vars,D,DVars),
|
||||
copy_term(D^Call-DVars,Data^NCall-DVars),
|
||||
call(NCall).
|
||||
|
||||
expand_node(D^Ds^C^Call,Node,Nodes) :-
|
||||
a_star_node(Data,Score,Node),
|
||||
term_variables(Call,Vars),
|
||||
chr_delete(Vars,D,DVars0),
|
||||
chr_delete(DVars0,Ds,DVars1),
|
||||
chr_delete(DVars1,C,DVars),
|
||||
copy_term(D^Ds^C^Call-DVars,Data^EData^Cost^NCall-DVars),
|
||||
term_variables(Node,NVars,DVars),
|
||||
find_with_var_identity(ENode,NVars,(NCall,EScore is Cost + Score,a_star:a_star_node(EData,EScore,ENode)),Nodes).
|
||||
|
||||
a_star_node(Data,Score,Data-Score).
|
||||
113
LGPL/chr/binomialheap.pl
Normal file
113
LGPL/chr/binomialheap.pl
Normal file
@ -0,0 +1,113 @@
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
% Binomial Heap imlementation based on
|
||||
%
|
||||
% Functional Binomial Queues
|
||||
% James F. King
|
||||
% University of Glasgow
|
||||
%
|
||||
% Author: Tom Schrijvers
|
||||
% Email: Tom.Schrijvers@cs.kuleuven.ac.be
|
||||
% Copyright: K.U.Leuven 2004
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
:- module(binomialheap,
|
||||
[
|
||||
empty_q/1,
|
||||
insert_q/3,
|
||||
insert_list_q/3,
|
||||
delete_min_q/3,
|
||||
find_min_q/2
|
||||
]).
|
||||
|
||||
:- use_module(library(lists)).
|
||||
|
||||
% data Tree a = Node a [Tree a]
|
||||
% type BinQueue a = [Maybe (Tree a)]
|
||||
% data Maybe a = Zero | One a
|
||||
% type Item = (Entry,Key)
|
||||
|
||||
entry(Entry-_,Entry).
|
||||
key(_-Key,Key).
|
||||
|
||||
empty_q([]).
|
||||
|
||||
meld_q(P,Q,R) :-
|
||||
meld_qc(P,Q,zero,R).
|
||||
|
||||
meld_qc([],Q,zero,Q) :- !.
|
||||
meld_qc([],Q,C,R) :- !,
|
||||
meld_q(Q,[C],R).
|
||||
meld_qc(P,[],C,R) :- !,
|
||||
meld_qc([],P,C,R).
|
||||
meld_qc([zero|Ps],[zero|Qs],C,R) :- !,
|
||||
R = [C | Rs],
|
||||
meld_q(Ps,Qs,Rs).
|
||||
meld_qc([one(node(X,Xs))|Ps],[one(node(Y,Ys))|Qs],C,R) :- !,
|
||||
key(X,KX),
|
||||
key(Y,KY),
|
||||
( KX < KY ->
|
||||
T = node(X,[node(Y,Ys)|Xs])
|
||||
;
|
||||
T = node(Y,[node(X,Xs)|Ys])
|
||||
),
|
||||
R = [C|Rs],
|
||||
meld_qc(Ps,Qs,one(T),Rs).
|
||||
meld_qc([P|Ps],[Q|Qs],C,Rs) :-
|
||||
meld_qc([Q|Ps],[C|Qs],P,Rs).
|
||||
|
||||
insert_q(Q,I,NQ) :-
|
||||
meld_q([one(node(I,[]))],Q,NQ).
|
||||
|
||||
insert_list_q([],Q,Q).
|
||||
insert_list_q([I|Is],Q,NQ) :-
|
||||
insert_q(Q,I,Q1),
|
||||
insert_list_q(Is,Q1,NQ).
|
||||
|
||||
min_tree([T|Ts],MT) :-
|
||||
min_tree_acc(Ts,T,MT).
|
||||
|
||||
min_tree_acc([],MT,MT).
|
||||
min_tree_acc([T|Ts],Acc,MT) :-
|
||||
least(T,Acc,NAcc),
|
||||
min_tree_acc(Ts,NAcc,MT).
|
||||
|
||||
least(zero,T,T) :- !.
|
||||
least(T,zero,T) :- !.
|
||||
least(one(node(X,Xs)),one(node(Y,Ys)),T) :-
|
||||
key(X,KX),
|
||||
key(Y,KY),
|
||||
( KX < KY ->
|
||||
T = one(node(X,Xs))
|
||||
;
|
||||
T = one(node(Y,Ys))
|
||||
).
|
||||
|
||||
remove_tree([],_,[]).
|
||||
remove_tree([T|Ts],I,[NT|NTs]) :-
|
||||
( T == zero ->
|
||||
NT = T
|
||||
;
|
||||
T = one(node(X,_)),
|
||||
( X == I ->
|
||||
NT = zero
|
||||
;
|
||||
NT = T
|
||||
)
|
||||
),
|
||||
remove_tree(Ts,I,NTs).
|
||||
|
||||
delete_min_q(Q,NQ,Min) :-
|
||||
min_tree(Q,one(node(Min,Ts))),
|
||||
remove_tree(Q,Min,Q1),
|
||||
reverse(Ts,RTs),
|
||||
make_ones(RTs,Q2),
|
||||
meld_q(Q2,Q1,NQ).
|
||||
|
||||
make_ones([],[]).
|
||||
make_ones([N|Ns],[one(N)|RQ]) :-
|
||||
make_ones(Ns,RQ).
|
||||
|
||||
find_min_q(Q,I) :-
|
||||
min_tree(Q,one(node(I,_))).
|
||||
|
||||
|
||||
121
LGPL/chr/builtins.pl
Normal file
121
LGPL/chr/builtins.pl
Normal file
@ -0,0 +1,121 @@
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
% Author: Tom Schrijvers
|
||||
% Email: Tom.Schrijvers@cs.kuleuven.ac.be
|
||||
% Copyright: K.U.Leuven 2004
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
:- module(builtins,
|
||||
[
|
||||
negate_b/2,
|
||||
entails_b/2,
|
||||
binds_b/2
|
||||
]).
|
||||
|
||||
:- use_module(hprolog).
|
||||
%:- use_module(library(lists)).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
negate_b(A,B) :- once(negate(A,B)).
|
||||
negate((A,B),NotB) :- A==true,negate(B,NotB). % added by jon
|
||||
negate((A,B),NotA) :- B==true,negate(A,NotA). % added by jon
|
||||
negate((A,B),(NotA;NotB)) :- negate(A,NotA),negate(B,NotB). % added by jon
|
||||
negate((A;B),(NotA,NotB)) :- negate(A,NotA),negate(B,NotB). % added by jon
|
||||
negate(true,fail).
|
||||
negate(fail,true).
|
||||
negate(X =< Y, Y < X).
|
||||
negate(X > Y, Y >= X).
|
||||
negate(X >= Y, Y > X).
|
||||
negate(X < Y, Y =< X).
|
||||
negate(X == Y, X \== Y). % added by jon
|
||||
negate(X \== Y, X == Y). % added by jon
|
||||
negate(X =:= Y, X =\= Y). % added by jon
|
||||
negate(X is Y, X =\= Y). % added by jon
|
||||
negate(X =\= Y, X =:= Y). % added by jon
|
||||
negate(X = Y, X \= Y). % added by jon
|
||||
negate(X \= Y, X = Y). % added by jon
|
||||
negate(var(X),nonvar(X)).
|
||||
negate(nonvar(X),var(X)).
|
||||
negate(\+ X,X). % added by jon
|
||||
negate(X,\+ X). % added by jon
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
entails_b(fail,_) :-!.
|
||||
entails_b(A,B) :-
|
||||
( var(B) ->
|
||||
entails(A,B,[A])
|
||||
;
|
||||
once((
|
||||
entails(A,C,[A]),
|
||||
B == C
|
||||
))
|
||||
).
|
||||
|
||||
entails(A,A,_).
|
||||
entails(A,C,History) :-
|
||||
entails_(A,B),
|
||||
\+ hprolog:memberchk_eq(B,History),
|
||||
entails(B,C,[B|History]).
|
||||
|
||||
entails_(X > Y, X >= Y).
|
||||
entails_(X > Y, Y < X).
|
||||
entails_(X >= Y, Y =< X).
|
||||
entails_(X =< Y, Y >= X). %added by jon
|
||||
entails_(X < Y, Y > X).
|
||||
entails_(X < Y, X =< Y).
|
||||
entails_(X > Y, X \== Y).
|
||||
entails_(X \== Y, Y \== X).
|
||||
entails_(X == Y, Y == X).
|
||||
entails_(X == Y, X =:= Y) :- ground(X). %added by jon
|
||||
entails_(X == Y, X =:= Y) :- ground(Y). %added by jon
|
||||
entails_(X \== Y, X =\= Y) :- ground(X). %added by jon
|
||||
entails_(X \== Y, X =\= Y) :- ground(Y). %added by jon
|
||||
entails_(X =:= Y, Y =:= X). %added by jon
|
||||
entails_(X =\= Y, Y =\= X). %added by jon
|
||||
entails_(X == Y, X >= Y). %added by jon
|
||||
entails_(X == Y, X =< Y). %added by jon
|
||||
entails_(ground(X),nonvar(X)).
|
||||
entails_(compound(X),nonvar(X)).
|
||||
entails_(atomic(X),nonvar(X)).
|
||||
entails_(number(X),nonvar(X)).
|
||||
entails_(atom(X),nonvar(X)).
|
||||
entails_(fail,true).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
binds_b(G,Vars) :-
|
||||
binds_(G,L,[]),
|
||||
sort(L,Vars).
|
||||
|
||||
binds_(var(_),L,L).
|
||||
binds_(nonvar(_),L,L).
|
||||
binds_(ground(_),L,L).
|
||||
binds_(compound(_),L,L).
|
||||
binds_(number(_),L,L).
|
||||
binds_(atom(_),L,L).
|
||||
binds_(atomic(_),L,L).
|
||||
binds_(integer(_),L,L).
|
||||
binds_(float(_),L,L).
|
||||
|
||||
binds_(_ > _ ,L,L).
|
||||
binds_(_ < _ ,L,L).
|
||||
binds_(_ =< _,L,L).
|
||||
binds_(_ >= _,L,L).
|
||||
binds_(_ =:= _,L,L).
|
||||
binds_(_ =\= _,L,L).
|
||||
binds_(_ == _,L,L).
|
||||
binds_(_ \== _,L,L).
|
||||
binds_(true,L,L).
|
||||
|
||||
binds_(X is _,[X|L],L).
|
||||
binds_((G1,G2),L,T) :-
|
||||
binds_(G1,L,R),
|
||||
binds_(G2,R,T).
|
||||
binds_((G1;G2),L,T) :-
|
||||
binds_(G1,L,R),
|
||||
binds_(G2,R,T).
|
||||
binds_((G1->G2),L,T) :-
|
||||
binds_(G1,L,R),
|
||||
binds_(G2,R,T).
|
||||
|
||||
binds_(\+ G,L,T) :-
|
||||
binds_(G,L,T).
|
||||
|
||||
binds_(G,L,T) :- term_variables(G,GVars),append(GVars,T,L). %jon
|
||||
7
LGPL/chr/chr.yap
Normal file
7
LGPL/chr/chr.yap
Normal file
@ -0,0 +1,7 @@
|
||||
|
||||
:- ensure_loaded(library(swi)).
|
||||
|
||||
:- include('chr.pl').
|
||||
|
||||
|
||||
|
||||
284
LGPL/chr/chr_compiler_options.pl
Normal file
284
LGPL/chr/chr_compiler_options.pl
Normal file
@ -0,0 +1,284 @@
|
||||
/* $Id: chr_compiler_options.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2005-2006, K.U. Leuven
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
:- module(chr_compiler_options,
|
||||
[ handle_option/2
|
||||
, init_chr_pp_flags/0
|
||||
, chr_pp_flag/2
|
||||
]).
|
||||
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
% Global Options
|
||||
%
|
||||
|
||||
handle_option(Var,Value) :-
|
||||
var(Var), !,
|
||||
format('CHR compiler ERROR: ~w.\n',[option(Var,Value)]),
|
||||
format(' `--> First argument should be an atom, not a variable.\n',[]),
|
||||
fail.
|
||||
|
||||
handle_option(Name,Value) :-
|
||||
var(Value), !,
|
||||
format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]),
|
||||
format(' `--> Second argument should be a nonvariable.\n',[]),
|
||||
fail.
|
||||
|
||||
handle_option(Name,Value) :-
|
||||
option_definition(Name,Value,Flags),
|
||||
!,
|
||||
set_chr_pp_flags(Flags).
|
||||
|
||||
handle_option(Name,Value) :-
|
||||
\+ option_definition(Name,_,_), !,
|
||||
setof(N,_V ^ _F ^ (option_definition(N,_V,_F)),Ns),
|
||||
format('CHR compiler WARNING: ~w.\n',[option(Name,Value)]),
|
||||
format(' `--> Invalid option name ~w: should be one of ~w.\n',[Name,Ns]).
|
||||
|
||||
handle_option(Name,Value) :-
|
||||
findall(V,option_definition(Name,V,_),Vs),
|
||||
format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]),
|
||||
format(' `--> Invalid value ~w: should be one of ~w.\n',[Value,Vs]),
|
||||
fail.
|
||||
|
||||
option_definition(optimize,experimental,Flags) :-
|
||||
Flags = [ functional_dependency_analysis - on,
|
||||
check_unnecessary_active - off,
|
||||
reorder_heads - on,
|
||||
set_semantics_rule - off,
|
||||
storage_analysis - on,
|
||||
guard_via_reschedule - on,
|
||||
guard_simplification - on,
|
||||
check_impossible_rules - on,
|
||||
occurrence_subsumption - on,
|
||||
observation - on,
|
||||
ai_observation_analysis - on,
|
||||
late_allocation - on,
|
||||
reduced_indexing - on
|
||||
].
|
||||
option_definition(optimize,full,Flags) :-
|
||||
Flags = [ functional_dependency_analysis - on,
|
||||
check_unnecessary_active - full,
|
||||
reorder_heads - on,
|
||||
set_semantics_rule - on,
|
||||
storage_analysis - on,
|
||||
guard_via_reschedule - on,
|
||||
guard_simplification - on,
|
||||
check_impossible_rules - on,
|
||||
occurrence_subsumption - on,
|
||||
observation - on,
|
||||
ai_observation_analysis - on,
|
||||
late_allocation - on,
|
||||
reduced_indexing - on
|
||||
].
|
||||
|
||||
option_definition(optimize,sicstus,Flags) :-
|
||||
Flags = [ functional_dependency_analysis - off,
|
||||
check_unnecessary_active - simplification,
|
||||
reorder_heads - off,
|
||||
set_semantics_rule - off,
|
||||
storage_analysis - off,
|
||||
guard_via_reschedule - off,
|
||||
guard_simplification - off,
|
||||
check_impossible_rules - off,
|
||||
occurrence_subsumption - off,
|
||||
observation - off,
|
||||
ai_observation_analysis - off,
|
||||
late_allocation - off,
|
||||
reduced_indexing - off
|
||||
].
|
||||
|
||||
option_definition(optimize,off,Flags) :-
|
||||
Flags = [ functional_dependency_analysis - off,
|
||||
check_unnecessary_active - off,
|
||||
reorder_heads - off,
|
||||
set_semantics_rule - off,
|
||||
storage_analysis - off,
|
||||
guard_via_reschedule - off,
|
||||
guard_simplification - off,
|
||||
check_impossible_rules - off,
|
||||
occurrence_subsumption - off,
|
||||
observation - off,
|
||||
ai_observation_analysis - off,
|
||||
late_allocation - off,
|
||||
reduced_indexing - off
|
||||
].
|
||||
|
||||
option_definition(functional_dependency_analysis,on,Flags) :-
|
||||
Flags = [ functional_dependency_analysis - on ].
|
||||
option_definition(functional_dependency_analysis,off,Flags) :-
|
||||
Flags = [ functional_dependency_analysis - off ].
|
||||
|
||||
option_definition(set_semantics_rule,on,Flags) :-
|
||||
Flags = [ set_semantics_rule - on ].
|
||||
option_definition(set_semantics_rule,off,Flags) :-
|
||||
Flags = [ set_semantics_rule - off ].
|
||||
|
||||
option_definition(check_unnecessary_active,full,Flags) :-
|
||||
Flags = [ check_unnecessary_active - full ].
|
||||
option_definition(check_unnecessary_active,simplification,Flags) :-
|
||||
Flags = [ check_unnecessary_active - simplification ].
|
||||
option_definition(check_unnecessary_active,off,Flags) :-
|
||||
Flags = [ check_unnecessary_active - off ].
|
||||
|
||||
option_definition(check_guard_bindings,on,Flags) :-
|
||||
Flags = [ guard_locks - on ].
|
||||
option_definition(check_guard_bindings,off,Flags) :-
|
||||
Flags = [ guard_locks - off ].
|
||||
|
||||
option_definition(reduced_indexing,on,Flags) :-
|
||||
Flags = [ reduced_indexing - on ].
|
||||
option_definition(reduced_indexing,off,Flags) :-
|
||||
Flags = [ reduced_indexing - off ].
|
||||
|
||||
option_definition(storage_analysis,on,Flags) :-
|
||||
Flags = [ storage_analysis - on ].
|
||||
option_definition(storage_analysis,off,Flags) :-
|
||||
Flags = [ storage_analysis - off ].
|
||||
|
||||
option_definition(guard_simplification,on,Flags) :-
|
||||
Flags = [ guard_simplification - on ].
|
||||
option_definition(guard_simplification,off,Flags) :-
|
||||
Flags = [ guard_simplification - off ].
|
||||
|
||||
option_definition(check_impossible_rules,on,Flags) :-
|
||||
Flags = [ check_impossible_rules - on ].
|
||||
option_definition(check_impossible_rules,off,Flags) :-
|
||||
Flags = [ check_impossible_rules - off ].
|
||||
|
||||
option_definition(occurrence_subsumption,on,Flags) :-
|
||||
Flags = [ occurrence_subsumption - on ].
|
||||
option_definition(occurrence_subsumption,off,Flags) :-
|
||||
Flags = [ occurrence_subsumption - off ].
|
||||
|
||||
option_definition(late_allocation,on,Flags) :-
|
||||
Flags = [ late_allocation - on ].
|
||||
option_definition(late_allocation,off,Flags) :-
|
||||
Flags = [ late_allocation - off ].
|
||||
|
||||
option_definition(type_definition,TypeDef,[]) :-
|
||||
( nonvar(TypeDef) ->
|
||||
TypeDef = type(T,D),
|
||||
chr_translate:type_definition(T,D)
|
||||
; true).
|
||||
option_definition(type_declaration,TypeDecl,[]) :-
|
||||
( nonvar(TypeDecl) ->
|
||||
functor(TypeDecl,F,A),
|
||||
TypeDecl =.. [_|ArgTypes],
|
||||
chr_translate:constraint_type(F/A,ArgTypes)
|
||||
; true).
|
||||
|
||||
option_definition(mode,ModeDecl,[]) :-
|
||||
( nonvar(ModeDecl) ->
|
||||
functor(ModeDecl,F,A),
|
||||
ModeDecl =.. [_|ArgModes],
|
||||
chr_translate:constraint_mode(F/A,ArgModes)
|
||||
; true).
|
||||
option_definition(store,FA-Store,[]) :-
|
||||
chr_translate:store_type(FA,Store).
|
||||
|
||||
option_definition(debug,off,Flags) :-
|
||||
Flags = [ debugable - off ].
|
||||
option_definition(debug,on,Flags) :-
|
||||
Flags = [ debugable - on ].
|
||||
|
||||
option_definition(store_counter,off,[]).
|
||||
option_definition(store_counter,on,[store_counter-on]).
|
||||
|
||||
option_definition(observation,off,Flags) :-
|
||||
Flags = [
|
||||
observation_analysis - off,
|
||||
ai_observation_analysis - off,
|
||||
late_allocation - off,
|
||||
storage_analysis - off
|
||||
].
|
||||
option_definition(observation,on,Flags) :-
|
||||
Flags = [
|
||||
observation_analysis - on,
|
||||
ai_observation_analysis - on
|
||||
].
|
||||
option_definition(observation,regular,Flags) :-
|
||||
Flags = [
|
||||
observation_analysis - on,
|
||||
ai_observation_analysis - off
|
||||
].
|
||||
option_definition(observation,ai,Flags) :-
|
||||
Flags = [
|
||||
observation_analysis - off,
|
||||
ai_observation_analysis - on
|
||||
].
|
||||
|
||||
option_definition(solver_events,NMod,Flags) :-
|
||||
Flags = [solver_events - NMod].
|
||||
|
||||
init_chr_pp_flags :-
|
||||
chr_pp_flag_definition(Name,[DefaultValue|_]),
|
||||
set_chr_pp_flag(Name,DefaultValue),
|
||||
fail.
|
||||
init_chr_pp_flags.
|
||||
|
||||
set_chr_pp_flags([]).
|
||||
set_chr_pp_flags([Name-Value|Flags]) :-
|
||||
set_chr_pp_flag(Name,Value),
|
||||
set_chr_pp_flags(Flags).
|
||||
|
||||
set_chr_pp_flag(Name,Value) :-
|
||||
atom_concat('$chr_pp_',Name,GlobalVar),
|
||||
nb_setval(GlobalVar,Value).
|
||||
|
||||
chr_pp_flag_definition(functional_dependency_analysis,[off,on]).
|
||||
chr_pp_flag_definition(check_unnecessary_active,[off,full,simplification]).
|
||||
chr_pp_flag_definition(reorder_heads,[off,on]).
|
||||
chr_pp_flag_definition(set_semantics_rule,[off,on]).
|
||||
chr_pp_flag_definition(guard_via_reschedule,[off,on]).
|
||||
chr_pp_flag_definition(guard_locks,[on,off]).
|
||||
chr_pp_flag_definition(storage_analysis,[off,on]).
|
||||
chr_pp_flag_definition(debugable,[on,off]).
|
||||
chr_pp_flag_definition(reduced_indexing,[off,on]).
|
||||
chr_pp_flag_definition(observation_analysis,[off,on]).
|
||||
chr_pp_flag_definition(ai_observation_analysis,[off,on]).
|
||||
chr_pp_flag_definition(late_allocation,[off,on]).
|
||||
chr_pp_flag_definition(store_counter,[off,on]).
|
||||
chr_pp_flag_definition(guard_simplification,[off,on]).
|
||||
chr_pp_flag_definition(check_impossible_rules,[off,on]).
|
||||
chr_pp_flag_definition(occurrence_subsumption,[off,on]).
|
||||
chr_pp_flag_definition(observation,[off,on]).
|
||||
chr_pp_flag_definition(show,[off,on]).
|
||||
chr_pp_flag_definition(solver_events,[none,_]).
|
||||
|
||||
chr_pp_flag(Name,Value) :-
|
||||
atom_concat('$chr_pp_',Name,GlobalVar),
|
||||
nb_getval(GlobalVar,V),
|
||||
( V == [] ->
|
||||
chr_pp_flag_definition(Name,[Value|_])
|
||||
;
|
||||
V = Value
|
||||
).
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
256
LGPL/chr/chr_compiler_utility.pl
Normal file
256
LGPL/chr/chr_compiler_utility.pl
Normal file
@ -0,0 +1,256 @@
|
||||
/* $Id: chr_compiler_utility.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2005-2006, K.U. Leuven
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
:- module(chr_compiler_utility,
|
||||
[ is_variant/2
|
||||
, time/2
|
||||
, replicate/3
|
||||
, pair_all_with/3
|
||||
, conj2list/2
|
||||
, list2conj/2
|
||||
, disj2list/2
|
||||
, list2disj/2
|
||||
, variable_replacement/3
|
||||
, variable_replacement/4
|
||||
, identical_rules/2
|
||||
, copy_with_variable_replacement/3
|
||||
, my_term_copy/3
|
||||
, my_term_copy/4
|
||||
, atom_concat_list/2
|
||||
, init/2
|
||||
, member2/3
|
||||
, select2/6
|
||||
, set_elems/2
|
||||
, instrument_goal/4
|
||||
]).
|
||||
|
||||
:- use_module(pairlist).
|
||||
:- use_module(library(lists), [permutation/2]).
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
is_variant(A,B) :-
|
||||
copy_term_nat(A,AC),
|
||||
copy_term_nat(B,BC),
|
||||
term_variables(AC,AVars),
|
||||
term_variables(BC,BVars),
|
||||
AC = BC,
|
||||
is_variant1(AVars),
|
||||
is_variant2(BVars).
|
||||
|
||||
is_variant1([]).
|
||||
is_variant1([X|Xs]) :-
|
||||
var(X),
|
||||
X = '$test',
|
||||
is_variant1(Xs).
|
||||
|
||||
is_variant2([]).
|
||||
is_variant2([X|Xs]) :-
|
||||
X == '$test',
|
||||
is_variant2(Xs).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
time(Phase,Goal) :-
|
||||
statistics(runtime,[T1|_]),
|
||||
call(Goal),
|
||||
statistics(runtime,[T2|_]),
|
||||
T is T2 - T1,
|
||||
format(' ~w:\t\t~w ms\n',[Phase,T]).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
replicate(N,E,L) :-
|
||||
( N =< 0 ->
|
||||
L = []
|
||||
;
|
||||
L = [E|T],
|
||||
M is N - 1,
|
||||
replicate(M,E,T)
|
||||
).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
pair_all_with([],_,[]).
|
||||
pair_all_with([X|Xs],Y,[X-Y|Rest]) :-
|
||||
pair_all_with(Xs,Y,Rest).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
conj2list(Conj,L) :- %% transform conjunctions to list
|
||||
conj2list(Conj,L,[]).
|
||||
|
||||
conj2list(Conj,L,T) :-
|
||||
Conj = (true,G2), !,
|
||||
conj2list(G2,L,T).
|
||||
conj2list(Conj,L,T) :-
|
||||
Conj = (G1,G2), !,
|
||||
conj2list(G1,L,T1),
|
||||
conj2list(G2,T1,T).
|
||||
conj2list(G,[G | T],T).
|
||||
|
||||
disj2list(Conj,L) :- %% transform disjunctions to list
|
||||
disj2list(Conj,L,[]).
|
||||
disj2list(Conj,L,T) :-
|
||||
Conj = (fail;G2), !,
|
||||
disj2list(G2,L,T).
|
||||
disj2list(Conj,L,T) :-
|
||||
Conj = (G1;G2), !,
|
||||
disj2list(G1,L,T1),
|
||||
disj2list(G2,T1,T).
|
||||
disj2list(G,[G | T],T).
|
||||
|
||||
list2conj([],true).
|
||||
list2conj([G],X) :- !, X = G.
|
||||
list2conj([G|Gs],C) :-
|
||||
( G == true -> %% remove some redundant trues
|
||||
list2conj(Gs,C)
|
||||
;
|
||||
C = (G,R),
|
||||
list2conj(Gs,R)
|
||||
).
|
||||
|
||||
list2disj([],fail).
|
||||
list2disj([G],X) :- !, X = G.
|
||||
list2disj([G|Gs],C) :-
|
||||
( G == fail -> %% remove some redundant fails
|
||||
list2disj(Gs,C)
|
||||
;
|
||||
C = (G;R),
|
||||
list2disj(Gs,R)
|
||||
).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
% check wether two rules are identical
|
||||
|
||||
identical_rules(rule(H11,H21,G1,B1),rule(H12,H22,G2,B2)) :-
|
||||
G1 == G2,
|
||||
identical_bodies(B1,B2),
|
||||
permutation(H11,P1),
|
||||
P1 == H12,
|
||||
permutation(H21,P2),
|
||||
P2 == H22.
|
||||
|
||||
identical_bodies(B1,B2) :-
|
||||
( B1 = (X1 = Y1),
|
||||
B2 = (X2 = Y2) ->
|
||||
( X1 == X2,
|
||||
Y1 == Y2
|
||||
; X1 == Y2,
|
||||
X2 == Y1
|
||||
),
|
||||
!
|
||||
; B1 == B2
|
||||
).
|
||||
|
||||
% replace variables in list
|
||||
|
||||
copy_with_variable_replacement(X,Y,L) :-
|
||||
( var(X) ->
|
||||
( lookup_eq(L,X,Y) ->
|
||||
true
|
||||
; X = Y
|
||||
)
|
||||
; functor(X,F,A),
|
||||
functor(Y,F,A),
|
||||
X =.. [_|XArgs],
|
||||
Y =.. [_|YArgs],
|
||||
copy_with_variable_replacement_l(XArgs,YArgs,L)
|
||||
).
|
||||
|
||||
copy_with_variable_replacement_l([],[],_).
|
||||
copy_with_variable_replacement_l([X|Xs],[Y|Ys],L) :-
|
||||
copy_with_variable_replacement(X,Y,L),
|
||||
copy_with_variable_replacement_l(Xs,Ys,L).
|
||||
|
||||
%% build variable replacement list
|
||||
|
||||
variable_replacement(X,Y,L) :-
|
||||
variable_replacement(X,Y,[],L).
|
||||
|
||||
variable_replacement(X,Y,L1,L2) :-
|
||||
( var(X) ->
|
||||
var(Y),
|
||||
( lookup_eq(L1,X,Z) ->
|
||||
Z == Y,
|
||||
L2 = L1
|
||||
; ( X == Y -> L2=L1 ; L2 = [X-Y,Y-X|L1])
|
||||
)
|
||||
; X =.. [F|XArgs],
|
||||
nonvar(Y),
|
||||
Y =.. [F|YArgs],
|
||||
variable_replacement_l(XArgs,YArgs,L1,L2)
|
||||
).
|
||||
|
||||
variable_replacement_l([],[],L,L).
|
||||
variable_replacement_l([X|Xs],[Y|Ys],L1,L3) :-
|
||||
variable_replacement(X,Y,L1,L2),
|
||||
variable_replacement_l(Xs,Ys,L2,L3).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
my_term_copy(X,Dict,Y) :-
|
||||
my_term_copy(X,Dict,_,Y).
|
||||
|
||||
my_term_copy(X,Dict1,Dict2,Y) :-
|
||||
( var(X) ->
|
||||
( lookup_eq(Dict1,X,Y) ->
|
||||
Dict2 = Dict1
|
||||
; Dict2 = [X-Y|Dict1]
|
||||
)
|
||||
; functor(X,XF,XA),
|
||||
functor(Y,XF,XA),
|
||||
X =.. [_|XArgs],
|
||||
Y =.. [_|YArgs],
|
||||
my_term_copy_list(XArgs,Dict1,Dict2,YArgs)
|
||||
).
|
||||
|
||||
my_term_copy_list([],Dict,Dict,[]).
|
||||
my_term_copy_list([X|Xs],Dict1,Dict3,[Y|Ys]) :-
|
||||
my_term_copy(X,Dict1,Dict2,Y),
|
||||
my_term_copy_list(Xs,Dict2,Dict3,Ys).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
atom_concat_list([X],X) :- ! .
|
||||
atom_concat_list([X|Xs],A) :-
|
||||
atom_concat_list(Xs,B),
|
||||
atom_concat(X,B,A).
|
||||
|
||||
set_elems([],_).
|
||||
set_elems([X|Xs],X) :-
|
||||
set_elems(Xs,X).
|
||||
|
||||
init([],[]).
|
||||
init([_],[]) :- !.
|
||||
init([X|Xs],[X|R]) :-
|
||||
init(Xs,R).
|
||||
|
||||
member2([X|_],[Y|_],X-Y).
|
||||
member2([_|Xs],[_|Ys],P) :-
|
||||
member2(Xs,Ys,P).
|
||||
|
||||
select2(X, Y, [X|Xs], [Y|Ys], Xs, Ys).
|
||||
select2(X, Y, [X1|Xs], [Y1|Ys], [X1|NXs], [Y1|NYs]) :-
|
||||
select2(X, Y, Xs, Ys, NXs, NYs).
|
||||
|
||||
instrument_goal(Goal,Pre,Post,(Pre,Goal,Post)).
|
||||
59
LGPL/chr/chr_debug.pl
Normal file
59
LGPL/chr/chr_debug.pl
Normal file
@ -0,0 +1,59 @@
|
||||
/* $Id: chr_debug.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, K.U. Leuven
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(chr_debug,
|
||||
[ chr_show_store/1, % +Module
|
||||
find_chr_constraint/1
|
||||
]).
|
||||
:- use_module(chr(chr_runtime)).
|
||||
:- use_module(library(lists)).
|
||||
:- set_prolog_flag(generate_debug_info, false).
|
||||
|
||||
|
||||
% chr_show_store(+Module)
|
||||
%
|
||||
% Prints all suspended constraints of module Mod to the standard
|
||||
% output.
|
||||
|
||||
chr_show_store(Mod) :-
|
||||
(
|
||||
Mod:'$enumerate_suspensions'(Susp),
|
||||
arg(6,Susp,C),
|
||||
print(C),nl, % allows use of portray to control printing
|
||||
fail
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
find_chr_constraint(C) :-
|
||||
chr:'$chr_module'(Mod),
|
||||
Mod:'$enumerate_suspensions'(Susp),
|
||||
arg(6,Susp,C).
|
||||
231
LGPL/chr/chr_hashtable_store.pl
Normal file
231
LGPL/chr/chr_hashtable_store.pl
Normal file
@ -0,0 +1,231 @@
|
||||
% author: Tom Schrijvers
|
||||
% email: Tom.Schrijvers@cs.kuleuven.ac.be
|
||||
% copyright: K.U.Leuven, 2004
|
||||
|
||||
:- module(chr_hashtable_store,
|
||||
[ new_ht/1,
|
||||
lookup_ht/3,
|
||||
insert_ht/3,
|
||||
delete_ht/3,
|
||||
value_ht/2
|
||||
]).
|
||||
|
||||
:- use_module(pairlist).
|
||||
:- use_module(hprolog).
|
||||
%:- use_module(library(lists)).
|
||||
|
||||
initial_capacity(1).
|
||||
|
||||
new_ht(HT) :-
|
||||
initial_capacity(Capacity),
|
||||
new_ht(Capacity,HT).
|
||||
|
||||
new_ht(Capacity,HT) :-
|
||||
functor(T1,t,Capacity),
|
||||
HT = ht(Capacity,0,Table),
|
||||
Table = T1.
|
||||
|
||||
lookup_ht(HT,Key,Values) :-
|
||||
term_hash(Key,Hash),
|
||||
HT = ht(Capacity,_,Table),
|
||||
Index is (Hash mod Capacity) + 1,
|
||||
arg(Index,Table,Bucket),
|
||||
nonvar(Bucket),
|
||||
( Bucket = K-Vs ->
|
||||
K == Key,
|
||||
Values = Vs
|
||||
;
|
||||
lookup_eq(Bucket,Key,Values)
|
||||
).
|
||||
|
||||
lookup_pair_eq([P | KVs],Key,Pair) :-
|
||||
P = K-_,
|
||||
( K == Key ->
|
||||
P = Pair
|
||||
;
|
||||
lookup_pair_eq(KVs,Key,Pair)
|
||||
).
|
||||
|
||||
insert_ht(HT,Key,Value) :-
|
||||
term_hash(Key,Hash),
|
||||
HT = ht(Capacity0,Load,Table0),
|
||||
LookupIndex is (Hash mod Capacity0) + 1,
|
||||
arg(LookupIndex,Table0,LookupBucket),
|
||||
( var(LookupBucket) ->
|
||||
Inc = yes,
|
||||
LookupBucket = Key - [Value]
|
||||
; LookupBucket = K-Values ->
|
||||
( K == Key ->
|
||||
( hprolog:memberchk_eq(Value,Values) ->
|
||||
true
|
||||
;
|
||||
Inc = yes,
|
||||
setarg(2,LookupBucket,[Value|Values])
|
||||
)
|
||||
;
|
||||
Inc = yes,
|
||||
setarg(LookupIndex,Table0,[Key-[Value],LookupBucket])
|
||||
)
|
||||
;
|
||||
( lookup_pair_eq(LookupBucket,Key,Pair) ->
|
||||
Pair = _-Values,
|
||||
( hprolog:memberchk_eq(Value,Values) ->
|
||||
true
|
||||
;
|
||||
Inc = yes,
|
||||
setarg(2,Pair,[Value|Values])
|
||||
)
|
||||
;
|
||||
Inc = yes,
|
||||
setarg(LookupIndex,Table0,[Key-[Value]|LookupBucket])
|
||||
)
|
||||
),
|
||||
( Inc == yes ->
|
||||
NLoad is Load + 1,
|
||||
setarg(2,HT,NLoad),
|
||||
( Load == Capacity0 ->
|
||||
expand_ht(HT,_Capacity)
|
||||
;
|
||||
true
|
||||
)
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
delete_ht(HT,Key,Value) :-
|
||||
HT = ht(Capacity,Load,Table),
|
||||
NLoad is Load - 1,
|
||||
term_hash(Key,Hash),
|
||||
Index is (Hash mod Capacity) + 1,
|
||||
arg(Index,Table,Bucket),
|
||||
( var(Bucket) ->
|
||||
true
|
||||
;
|
||||
( Bucket = K-Vs ->
|
||||
( K == Key,
|
||||
delete_first_fail(Vs,Value,NVs) ->
|
||||
setarg(2,HT,NLoad),
|
||||
( NVs == [] ->
|
||||
setarg(Index,Table,_)
|
||||
;
|
||||
setarg(2,Bucket,NVs)
|
||||
)
|
||||
;
|
||||
true
|
||||
)
|
||||
;
|
||||
( lookup_pair_eq(Bucket,Key,Pair),
|
||||
Pair = _-Vs,
|
||||
delete_first_fail(Vs,Value,NVs) ->
|
||||
setarg(2,HT,NLoad),
|
||||
( NVs == [] ->
|
||||
pairlist_delete_eq(Bucket,Key,NBucket),
|
||||
setarg(Index,Table,NBucket)
|
||||
;
|
||||
setarg(2,Pair,NVs)
|
||||
)
|
||||
;
|
||||
true
|
||||
)
|
||||
)
|
||||
).
|
||||
|
||||
delete_first_fail([X | Xs], Y, Zs) :-
|
||||
( X == Y ->
|
||||
Zs = Xs
|
||||
;
|
||||
Zs = [X | Zs1],
|
||||
delete_first_fail(Xs, Y, Zs1)
|
||||
).
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
value_ht(HT,Value) :-
|
||||
HT = ht(Capacity,_,Table),
|
||||
value_ht(1,Capacity,Table,Value).
|
||||
|
||||
value_ht(I,N,Table,Value) :-
|
||||
I =< N,
|
||||
arg(I,Table,Bucket),
|
||||
(
|
||||
nonvar(Bucket),
|
||||
( Bucket = _-Vs ->
|
||||
true
|
||||
;
|
||||
member(_-Vs,Bucket)
|
||||
),
|
||||
member(Value,Vs)
|
||||
;
|
||||
J is I + 1,
|
||||
value_ht(J,N,Table,Value)
|
||||
).
|
||||
|
||||
values_ht(HT,Values) :-
|
||||
HT = ht(Capacity,_,Table),
|
||||
values_ht(1,Capacity,Table,Values).
|
||||
values_ht(I,N,Table,Values) :-
|
||||
( I =< N ->
|
||||
arg(I,Table,Bucket),
|
||||
( nonvar(Bucket) ->
|
||||
( Bucket = _-Vs ->
|
||||
append(Vs,Tail,Values)
|
||||
;
|
||||
append_snd(Bucket,Tail,Values)
|
||||
)
|
||||
;
|
||||
Values = Tail
|
||||
),
|
||||
J is I + 1,
|
||||
values_ht(J,N,Table,Tail)
|
||||
;
|
||||
Values = []
|
||||
).
|
||||
|
||||
append_snd([],L,L).
|
||||
append_snd([_-H|Ps],L,NL) :-
|
||||
append(H,T,NL),
|
||||
append_snd(Ps,L,T).
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
expand_ht(HT,NewCapacity) :-
|
||||
HT = ht(Capacity,_,Table),
|
||||
NewCapacity is Capacity * 2,
|
||||
functor(NewTable,t,NewCapacity),
|
||||
setarg(1,HT,NewCapacity),
|
||||
setarg(3,HT,NewTable),
|
||||
expand_copy(Table,1,Capacity,NewTable,NewCapacity).
|
||||
|
||||
expand_copy(Table,I,N,NewTable,NewCapacity) :-
|
||||
( I > N ->
|
||||
true
|
||||
;
|
||||
arg(I,Table,Bucket),
|
||||
( var(Bucket) ->
|
||||
true
|
||||
; Bucket = Key - Value ->
|
||||
expand_insert(NewTable,NewCapacity,Key,Value)
|
||||
;
|
||||
expand_inserts(Bucket,NewTable,NewCapacity)
|
||||
),
|
||||
J is I + 1,
|
||||
expand_copy(Table,J,N,NewTable,NewCapacity)
|
||||
).
|
||||
|
||||
expand_inserts([],_,_).
|
||||
expand_inserts([K-V|R],Table,Capacity) :-
|
||||
expand_insert(Table,Capacity,K,V),
|
||||
expand_inserts(R,Table,Capacity).
|
||||
|
||||
expand_insert(Table,Capacity,K,V) :-
|
||||
term_hash(K,Hash),
|
||||
Index is (Hash mod Capacity) + 1,
|
||||
arg(Index,Table,Bucket),
|
||||
( var(Bucket) ->
|
||||
Bucket = K - V
|
||||
; Bucket = _-_ ->
|
||||
setarg(Index,Table,[K-V,Bucket])
|
||||
;
|
||||
setarg(Index,Table,[K-V|Bucket])
|
||||
).
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
term_hash(Term,Hash) :-
|
||||
hash_term(Term,Hash).
|
||||
|
||||
173
LGPL/chr/chr_messages.pl
Normal file
173
LGPL/chr/chr_messages.pl
Normal file
@ -0,0 +1,173 @@
|
||||
/* $Id: chr_messages.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Jan Wielemaker and Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, K.U. Leuven
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(chr_messages,
|
||||
[ chr_message/3 % +CHR Message, Out, Rest
|
||||
]).
|
||||
:- use_module(chr(chr_runtime)).
|
||||
|
||||
:- discontiguous
|
||||
chr_message/3.
|
||||
|
||||
% compiler messages
|
||||
|
||||
chr_message(compilation_failed(From)) -->
|
||||
[ 'CHR Failed to compile ~w'-[From] ].
|
||||
|
||||
% debug messages
|
||||
|
||||
chr_message(prompt) -->
|
||||
[ at_same_line, ' ? ', flush ].
|
||||
chr_message(command(Command)) -->
|
||||
[ at_same_line, '[~w]'-[Command] ].
|
||||
chr_message(invalid_command) -->
|
||||
[ nl, 'CHR: Not a valid debug option. Use ? for help.' ].
|
||||
chr_message(debug_options) -->
|
||||
{ bagof(Ls-Cmd,
|
||||
bagof(L, 'chr debug command'(L, Cmd), Ls),
|
||||
Lines)
|
||||
},
|
||||
[ 'CHR Debugger commands:', nl, nl ],
|
||||
debug_commands(Lines),
|
||||
[ nl ].
|
||||
|
||||
debug_commands([]) -->
|
||||
[].
|
||||
debug_commands([Ls-Cmd|T]) -->
|
||||
[ '\t' ], chars(Ls), [ '~t~28|~w'-[Cmd], nl ],
|
||||
debug_commands(T).
|
||||
|
||||
chars([C]) --> !,
|
||||
char(C).
|
||||
chars([C|T]) -->
|
||||
char(C), [', '],
|
||||
chars(T).
|
||||
|
||||
char(' ') --> !, ['<space>'].
|
||||
char('\r') --> !, ['<cr>'].
|
||||
char(end_of_file) --> !, ['EOF'].
|
||||
char(C) --> [C].
|
||||
|
||||
|
||||
chr_message(ancestors(History, Depth)) -->
|
||||
[ 'CHR Ancestors:', nl ],
|
||||
ancestors(History, Depth).
|
||||
|
||||
ancestors([], _) -->
|
||||
[].
|
||||
ancestors([Event|Events], Depth) -->
|
||||
[ '\t' ], event(Event, Depth), [ nl ],
|
||||
{ NDepth is Depth - 1
|
||||
},
|
||||
ancestors(Events, NDepth).
|
||||
|
||||
|
||||
% debugging ports
|
||||
|
||||
chr_message(event(Port, Depth)) -->
|
||||
[ 'CHR: ' ],
|
||||
event(Port, Depth),
|
||||
[ flush ]. % do not emit a newline
|
||||
|
||||
event(Port, Depth) -->
|
||||
depth(Depth),
|
||||
port(Port).
|
||||
event(apply(H1,H2,G,B), Depth) -->
|
||||
depth(Depth),
|
||||
[ 'Apply: ' ],
|
||||
rule(H1,H2,G,B).
|
||||
event(try(H1,H2,G,B), Depth) -->
|
||||
depth(Depth),
|
||||
[ 'Try: ' ],
|
||||
rule(H1,H2,G,B).
|
||||
event(insert(#(_,Susp)), Depth) -->
|
||||
depth(Depth),
|
||||
[ 'Insert: ' ],
|
||||
head(Susp).
|
||||
|
||||
port(call(Susp)) -->
|
||||
[ 'Call: ' ],
|
||||
head(Susp).
|
||||
port(wake(Susp)) -->
|
||||
[ 'Wake: ' ],
|
||||
head(Susp).
|
||||
port(exit(Susp)) -->
|
||||
[ 'Exit: ' ],
|
||||
head(Susp).
|
||||
port(fail(Susp)) -->
|
||||
[ 'Fail: ' ],
|
||||
head(Susp).
|
||||
port(redo(Susp)) -->
|
||||
[ 'Redo: ' ],
|
||||
head(Susp).
|
||||
port(remove(Susp)) -->
|
||||
[ 'Remove: ' ],
|
||||
head(Susp).
|
||||
|
||||
|
||||
depth(Depth) -->
|
||||
[ '~t(~D)~10| '-[Depth] ].
|
||||
|
||||
head(Susp) -->
|
||||
{ Susp =.. [_,ID,_,_,_,_,Goal|_Args]
|
||||
},
|
||||
[ '~w # <~w>'-[Goal, ID] ].
|
||||
|
||||
heads([H]) --> !,
|
||||
head(H).
|
||||
heads([H|T]) -->
|
||||
head(H),
|
||||
[ ', ' ],
|
||||
heads(T).
|
||||
|
||||
|
||||
% rule(H1, H2, G, B)
|
||||
%
|
||||
% Produce text for the CHR rule "H1 \ H2 [<=]=> G | B"
|
||||
|
||||
rule(H1, H2, G, B) -->
|
||||
rule_head(H1, H2),
|
||||
rule_body(G, B).
|
||||
|
||||
rule_head([], H2) --> !,
|
||||
heads(H2),
|
||||
[ ' ==> ' ].
|
||||
rule_head(H1, []) --> !,
|
||||
heads(H1),
|
||||
[ ' <=> ' ].
|
||||
rule_head(H1, H2) -->
|
||||
heads(H1), [ ' \\ ' ], heads(H2).
|
||||
|
||||
|
||||
rule_body(true, B) --> !,
|
||||
[ '~w.'-[B] ].
|
||||
rule_body(G, B) -->
|
||||
[ '~w | ~w.'-[G, B] ].
|
||||
49
LGPL/chr/chr_op.pl
Normal file
49
LGPL/chr/chr_op.pl
Normal file
@ -0,0 +1,49 @@
|
||||
/* $Id: chr_op.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, K.U. Leuven
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%% Operator Priorities
|
||||
|
||||
:- op( 700, xfx, ::).
|
||||
:- op(1180, xfx, ==>).
|
||||
:- op(1180, xfx, <=>).
|
||||
:- op(1150, fx, constraints).
|
||||
:- op(1150, fx, handler).
|
||||
:- op(1150, fx, rules).
|
||||
:- op(1100, xfx, \).
|
||||
:- op(1200, xfx, @). % values from hProlog
|
||||
:- op(1190, xfx, pragma). % values from hProlog
|
||||
:- op( 500, yfx, #). % values from hProlog
|
||||
%:- op(1100, xfx, '|').
|
||||
:- op(1150, fx, chr_type).
|
||||
:- op(1130, xfx, --->).
|
||||
:- op(1150, fx, (?)).
|
||||
51
LGPL/chr/chr_op2.pl
Normal file
51
LGPL/chr/chr_op2.pl
Normal file
@ -0,0 +1,51 @@
|
||||
/* $Id: chr_op2.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, K.U. Leuven
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%% Operator Priorities
|
||||
|
||||
|
||||
% old version, without the type/mode operators
|
||||
|
||||
:- op( 700, xfx, ::).
|
||||
:- op(1180, xfx, ==>).
|
||||
:- op(1180, xfx, <=>).
|
||||
:- op(1150, fx, constraints).
|
||||
:- op(1150, fx, handler).
|
||||
:- op(1150, fx, rules).
|
||||
:- op(1100, xfx, \).
|
||||
:- op(1200, xfx, @). % values from hProlog
|
||||
:- op(1190, xfx, pragma). % values from hProlog
|
||||
:- op( 500, yfx, #). % values from hProlog
|
||||
%:- op(1100, xfx, '|').
|
||||
%:- op(1150, fx, chr_type).
|
||||
%:- op(1130, xfx, --->).
|
||||
750
LGPL/chr/chr_runtime.pl
Normal file
750
LGPL/chr/chr_runtime.pl
Normal file
@ -0,0 +1,750 @@
|
||||
/* $Id: chr_runtime.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Christian Holzbaur and Tom Schrijvers
|
||||
E-mail: christian@ai.univie.ac.at
|
||||
Tom.Schrijvers@cs.kuleuven.ac.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, K.U. Leuven
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
|
||||
Distributed with SWI-Prolog under the above conditions with
|
||||
permission from the authors.
|
||||
*/
|
||||
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%% _ _ _
|
||||
%% ___| |__ _ __ _ __ _ _ _ __ | |_(_)_ __ ___ ___
|
||||
%% / __| '_ \| '__| | '__| | | | '_ \| __| | '_ ` _ \ / _ \
|
||||
%% | (__| | | | | | | | |_| | | | | |_| | | | | | | __/
|
||||
%% \___|_| |_|_| |_| \__,_|_| |_|\__|_|_| |_| |_|\___|
|
||||
%%
|
||||
%% hProlog CHR runtime:
|
||||
%%
|
||||
%% * based on the SICStus CHR runtime by Christian Holzbaur
|
||||
%%
|
||||
%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%% % Constraint Handling Rules version 2.2 %
|
||||
%% % %
|
||||
%% % (c) Copyright 1996-98 %
|
||||
%% % LMU, Muenchen %
|
||||
%% % %
|
||||
%% % File: chr.pl %
|
||||
%% % Author: Christian Holzbaur christian@ai.univie.ac.at %
|
||||
%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%%
|
||||
%% * modified by Tom Schrijvers, K.U.Leuven, Tom.Schrijvers@cs.kuleuven.ac.be
|
||||
%% - ported to hProlog
|
||||
%% - modified for eager suspension removal
|
||||
%%
|
||||
%% * First working version: 6 June 2003
|
||||
%%
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%% SWI-Prolog changes
|
||||
%%
|
||||
%% * Added initialization directives for saved-states
|
||||
%% * Renamed merge/3 --> sbag_merge/3 (name conflict)
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
:- module(chr_runtime,
|
||||
[ 'chr sbag_del_element'/3,
|
||||
'chr sbag_member'/2,
|
||||
'chr merge_attributes'/3,
|
||||
|
||||
'chr run_suspensions'/1,
|
||||
'chr run_suspensions_loop'/1,
|
||||
|
||||
'chr run_suspensions_d'/1,
|
||||
'chr run_suspensions_loop_d'/1,
|
||||
|
||||
'chr insert_constraint_internal'/5,
|
||||
'chr remove_constraint_internal'/2,
|
||||
'chr allocate_constraint'/4,
|
||||
'chr activate_constraint'/3,
|
||||
|
||||
'chr global_term_ref_1'/1,
|
||||
|
||||
'chr via_1'/2,
|
||||
'chr via_2'/3,
|
||||
'chr via'/2,
|
||||
|
||||
'chr lock'/1,
|
||||
'chr unlock'/1,
|
||||
'chr not_locked'/1,
|
||||
'chr none_locked'/1,
|
||||
|
||||
'chr update_mutable'/2,
|
||||
'chr get_mutable'/2,
|
||||
|
||||
'chr novel_production'/2,
|
||||
'chr extend_history'/2,
|
||||
'chr empty_history'/1,
|
||||
|
||||
'chr gen_id'/1,
|
||||
|
||||
'chr debug_event'/1,
|
||||
'chr debug command'/2, % Char, Command
|
||||
|
||||
'chr chr_indexed_variables'/2,
|
||||
|
||||
chr_trace/0,
|
||||
chr_notrace/0,
|
||||
chr_leash/1
|
||||
]).
|
||||
:- set_prolog_flag(generate_debug_info, false).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
:- use_module(library(assoc)).
|
||||
:- use_module(hprolog).
|
||||
%:- use_module(library(lists)).
|
||||
:- include(chr_op).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
% I N I T I A L I S A T I O N
|
||||
|
||||
chr_init :-
|
||||
nb_setval(id,0),
|
||||
nb_setval(chr_global,_),
|
||||
nb_setval(chr_debug,mutable(off)),
|
||||
nb_setval(chr_debug_history,mutable([],0)).
|
||||
|
||||
:- initialization chr_init.
|
||||
|
||||
show_store(Mod) :-
|
||||
(
|
||||
Mod:'$enumerate_suspensions'(Susp),
|
||||
arg(6,Susp,C),
|
||||
writeln(C),
|
||||
fail
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
'chr merge_attributes'( As, Bs, Cs) :-
|
||||
sbag_union(As,Bs,Cs).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
'chr run_suspensions'( Slots) :-
|
||||
run_suspensions( Slots).
|
||||
|
||||
'chr run_suspensions_loop'([]).
|
||||
'chr run_suspensions_loop'([L|Ls]) :-
|
||||
run_suspensions(L),
|
||||
'chr run_suspensions_loop'(Ls).
|
||||
|
||||
run_suspensions([]).
|
||||
run_suspensions([S|Next] ) :-
|
||||
arg( 2, S, Mref),
|
||||
Mref = mutable(Status), % get_mutable( Status, Mref), % XXX Inlined
|
||||
( Status==active ->
|
||||
update_mutable( triggered, Mref),
|
||||
arg( 4, S, Gref),
|
||||
Gref = mutable(Gen), % get_mutable( Gen, Gref), % XXX Inlined
|
||||
Generation is Gen+1,
|
||||
update_mutable( Generation, Gref),
|
||||
arg( 3, S, Goal),
|
||||
call( Goal),
|
||||
% get_mutable( Post, Mref), % XXX Inlined
|
||||
( Mref = mutable(triggered) -> % Post==triggered ->
|
||||
update_mutable( removed, Mref)
|
||||
;
|
||||
true
|
||||
)
|
||||
;
|
||||
true
|
||||
),
|
||||
run_suspensions( Next).
|
||||
|
||||
'chr run_suspensions_d'( Slots) :-
|
||||
run_suspensions_d( Slots).
|
||||
|
||||
'chr run_suspensions_loop_d'([]).
|
||||
'chr run_suspensions_loop_d'([L|Ls]) :-
|
||||
run_suspensions_d(L),
|
||||
'chr run_suspensions_loop_d'(Ls).
|
||||
|
||||
run_suspensions_d([]).
|
||||
run_suspensions_d([S|Next] ) :-
|
||||
arg( 2, S, Mref),
|
||||
Mref = mutable(Status), % get_mutable( Status, Mref), % XXX Inlined
|
||||
( Status==active ->
|
||||
update_mutable( triggered, Mref),
|
||||
arg( 4, S, Gref),
|
||||
Gref = mutable(Gen), % get_mutable( Gen, Gref), % XXX Inlined
|
||||
Generation is Gen+1,
|
||||
update_mutable( Generation, Gref),
|
||||
arg( 3, S, Goal),
|
||||
(
|
||||
'chr debug_event'(wake(S)),
|
||||
call( Goal)
|
||||
;
|
||||
'chr debug_event'(fail(S)), !,
|
||||
fail
|
||||
),
|
||||
(
|
||||
'chr debug_event'(exit(S))
|
||||
;
|
||||
'chr debug_event'(redo(S)),
|
||||
fail
|
||||
),
|
||||
% get_mutable( Post, Mref), % XXX Inlined
|
||||
( Mref = mutable(triggered) -> % Post==triggered ->
|
||||
update_mutable( removed, Mref)
|
||||
;
|
||||
true
|
||||
)
|
||||
;
|
||||
true
|
||||
),
|
||||
run_suspensions_d( Next).
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
locked:attr_unify_hook(_,_) :- fail.
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
'chr lock'(T) :-
|
||||
lock(T).
|
||||
|
||||
'chr unlock'(T) :-
|
||||
unlock(T).
|
||||
|
||||
'chr not_locked'(T) :-
|
||||
not_locked(T).
|
||||
|
||||
lock(T) :-
|
||||
( var(T)
|
||||
-> put_attr(T, locked, x)
|
||||
; term_variables(T,L),
|
||||
lockv(L)
|
||||
).
|
||||
|
||||
lockv([]).
|
||||
lockv([T|R]) :- put_attr( T, locked, x), lockv(R).
|
||||
|
||||
unlock(T) :-
|
||||
( var(T)
|
||||
-> del_attr(T, locked)
|
||||
; term_variables(T,L),
|
||||
unlockv(L)
|
||||
).
|
||||
|
||||
unlockv([]).
|
||||
unlockv([T|R]) :- del_attr( T, locked), unlockv(R).
|
||||
|
||||
'chr none_locked'( []).
|
||||
'chr none_locked'( [V|Vs]) :-
|
||||
not_locked( V),
|
||||
'chr none_locked'( Vs).
|
||||
|
||||
not_locked( V) :-
|
||||
( var( V) ->
|
||||
( get_attr( V, locked, _) ->
|
||||
fail
|
||||
;
|
||||
true
|
||||
)
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%
|
||||
% Eager removal from all chains.
|
||||
%
|
||||
'chr remove_constraint_internal'( Susp, Agenda) :-
|
||||
arg( 2, Susp, Mref),
|
||||
Mref = mutable(State), % get_mutable( State, Mref), % XXX Inlined
|
||||
update_mutable( removed, Mref), % mark in any case
|
||||
( 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]
|
||||
).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
'chr via_1'(X,V) :-
|
||||
( var(X) ->
|
||||
X = V
|
||||
; atomic(X) ->
|
||||
global_term_ref_1(V)
|
||||
; nonground(X,V) ->
|
||||
true
|
||||
;
|
||||
global_term_ref_1(V)
|
||||
).
|
||||
% 'chr via_1'( X, V) :- var(X), !, X=V.
|
||||
% 'chr via_1'( T, V) :- compound(T), nonground( T, V), ! .
|
||||
% 'chr via_1'( _, V) :- global_term_ref_1( V).
|
||||
|
||||
'chr via_2'(X,Y,V) :-
|
||||
( var(X) ->
|
||||
X = V
|
||||
; var(Y) ->
|
||||
Y = V
|
||||
; compound(X), nonground(X,V) ->
|
||||
true
|
||||
; compound(Y), nonground(Y,V) ->
|
||||
true
|
||||
;
|
||||
global_term_ref_1(V)
|
||||
).
|
||||
% 'chr via_2'( X, _, V) :- var(X), !, X=V.
|
||||
% 'chr via_2'( _, Y, V) :- var(Y), !, Y=V.
|
||||
% 'chr via_2'( T, _, V) :- compound(T), nonground( T, V), ! .
|
||||
% 'chr via_2'( _, T, V) :- compound(T), nonground( T, V), ! .
|
||||
% 'chr via_2'( _, _, V) :- global_term_ref_1( V).
|
||||
|
||||
%
|
||||
% The second arg is a witness.
|
||||
% The formulation with term_variables/2 is
|
||||
% cycle safe, but it finds a list of all vars.
|
||||
% We need only one, and no list in particular.
|
||||
%
|
||||
'chr via'(L,V) :-
|
||||
( nonground(L,V) ->
|
||||
true
|
||||
;
|
||||
global_term_ref_1(V)
|
||||
).
|
||||
|
||||
nonground( Term, V) :-
|
||||
term_variables( Term, Vs),
|
||||
Vs = [V|_].
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
'chr novel_production'( Self, Tuple) :-
|
||||
arg( 5, Self, Ref),
|
||||
Ref = mutable(History), % get_mutable( History, Ref), % XXX Inlined
|
||||
( get_assoc( Tuple, History, _) ->
|
||||
fail
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
%
|
||||
% Not folded with novel_production/2 because guard checking
|
||||
% goes in between the two calls.
|
||||
%
|
||||
'chr extend_history'( Self, Tuple) :-
|
||||
arg( 5, Self, Ref),
|
||||
Ref = mutable(History), % get_mutable( History, Ref), % XXX Inlined
|
||||
put_assoc( Tuple, History, x, NewHistory),
|
||||
update_mutable( NewHistory, Ref).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
constraint_generation( Susp, State, Generation) :-
|
||||
arg( 2, Susp, Mref),
|
||||
Mref = mutable(State), % get_mutable( State, Mref), % XXX Inlined
|
||||
arg( 4, Susp, Gref),
|
||||
Gref = mutable(Generation). % get_mutable( Generation, Gref). % not incremented meanwhile % XXX Inlined
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
'chr allocate_constraint'( Closure, Self, F, Args) :-
|
||||
'chr empty_history'( History),
|
||||
create_mutable( passive(Args), Mref),
|
||||
create_mutable( 0, Gref),
|
||||
create_mutable( History, Href),
|
||||
'chr gen_id'( Id),
|
||||
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
|
||||
|
||||
%
|
||||
% 'chr activate_constraint'( -, +, -).
|
||||
%
|
||||
% The transition gc->active should be rare
|
||||
%
|
||||
'chr activate_constraint'( Vars, Susp, Generation) :-
|
||||
arg( 2, Susp, Mref),
|
||||
Mref = mutable(State), % get_mutable( State, Mref), % XXX Inlined
|
||||
update_mutable( active, Mref),
|
||||
( nonvar(Generation) -> % aih
|
||||
true
|
||||
;
|
||||
arg( 4, Susp, Gref),
|
||||
Gref = mutable(Gen), % get_mutable( Gen, Gref), % XXX Inlined
|
||||
Generation is Gen+1,
|
||||
update_mutable( Generation, Gref)
|
||||
),
|
||||
( compound(State) -> % passive/1
|
||||
term_variables( State, Vs),
|
||||
'chr none_locked'( Vs),
|
||||
global_term_ref_1( Global),
|
||||
Vars = [Global|Vs]
|
||||
; State==removed -> % the price for eager removal ...
|
||||
Susp =.. [_,_,_,_,_,_,_|Args],
|
||||
term_variables( Args, Vs),
|
||||
global_term_ref_1( Global),
|
||||
Vars = [Global|Vs]
|
||||
;
|
||||
Vars = []
|
||||
).
|
||||
|
||||
'chr insert_constraint_internal'( [Global|Vars], Self, Closure, F, Args) :-
|
||||
term_variables( Args, Vars),
|
||||
'chr none_locked'( Vars),
|
||||
global_term_ref_1( Global),
|
||||
'chr empty_history'( History),
|
||||
create_mutable( active, Mref),
|
||||
create_mutable( 0, Gref),
|
||||
create_mutable( History, Href),
|
||||
'chr gen_id'( Id),
|
||||
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
|
||||
|
||||
insert_constraint_internal( [Global|Vars], Self, Term, Closure, F, Args) :-
|
||||
term_variables( Term, Vars),
|
||||
'chr none_locked'( Vars),
|
||||
global_term_ref_1( Global),
|
||||
'chr empty_history'( History),
|
||||
create_mutable( active, Mref),
|
||||
create_mutable( 0, Gref),
|
||||
create_mutable( History, Href),
|
||||
'chr gen_id'( Id),
|
||||
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
change_state( Susp, State) :-
|
||||
arg( 2, Susp, Mref),
|
||||
update_mutable( State, Mref).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
'chr empty_history'( E) :- empty_assoc( E).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
'chr gen_id'( Id) :-
|
||||
incval( id, Id).
|
||||
|
||||
incval(id,Id) :-
|
||||
nb_getval(id,Id),
|
||||
NextId is Id + 1,
|
||||
nb_setval(id,NextId).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
create_mutable(V,mutable(V)).
|
||||
|
||||
'chr get_mutable'(V, mutable(V)).
|
||||
|
||||
'chr update_mutable'(V,M) :-
|
||||
setarg(1,M,V).
|
||||
|
||||
get_mutable(V, mutable(V)).
|
||||
|
||||
update_mutable(V,M) :-
|
||||
setarg(1,M,V).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
'chr global_term_ref_1'(X) :-
|
||||
global_term_ref_1(X).
|
||||
|
||||
global_term_ref_1(X) :-
|
||||
nb_getval(chr_global,X).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
'chr 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).
|
||||
|
||||
'chr sbag_del_element'( [], _, []).
|
||||
'chr sbag_del_element'( [X|Xs], Elem, Set2) :-
|
||||
( X==Elem ->
|
||||
Set2 = Xs
|
||||
;
|
||||
Set2 = [X|Xss],
|
||||
'chr sbag_del_element'( Xs, Elem, Xss)
|
||||
).
|
||||
|
||||
sbag_union( A, B, C) :-
|
||||
sbag_merge( A, B, C).
|
||||
|
||||
sbag_merge([],Ys,Ys).
|
||||
sbag_merge([X | Xs],YL,R) :-
|
||||
( YL = [Y | Ys] ->
|
||||
arg(1,X,XId),
|
||||
arg(1,Y,YId),
|
||||
( XId < YId ->
|
||||
R = [X | T],
|
||||
sbag_merge(Xs,YL,T)
|
||||
; XId > YId ->
|
||||
R = [Y | T],
|
||||
sbag_merge([X|Xs],Ys,T)
|
||||
;
|
||||
R = [X | T],
|
||||
sbag_merge(Xs,Ys,T)
|
||||
)
|
||||
;
|
||||
R = [X | Xs]
|
||||
).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
:- multifile
|
||||
chr:debug_event/2, % +State, +Event
|
||||
chr:debug_interact/3. % +Event, +Depth, -Command
|
||||
|
||||
'chr debug_event'(Event) :-
|
||||
nb_getval(chr_debug,mutable(State)),
|
||||
( State == off ->
|
||||
true
|
||||
; chr:debug_event(State, Event) ->
|
||||
true
|
||||
; debug_event(State,Event)
|
||||
).
|
||||
|
||||
chr_trace :-
|
||||
nb_setval(chr_debug,mutable(trace)).
|
||||
chr_notrace :-
|
||||
nb_setval(chr_debug,mutable(off)).
|
||||
|
||||
% chr_leash(+Spec)
|
||||
%
|
||||
% Define the set of ports at which we prompt for user interaction
|
||||
|
||||
chr_leash(Spec) :-
|
||||
leashed_ports(Spec, Ports),
|
||||
nb_setval(chr_leash,mutable(Ports)).
|
||||
|
||||
leashed_ports(none, []).
|
||||
leashed_ports(off, []).
|
||||
leashed_ports(all, [call, exit, redo, fail, wake, try, apply, insert, remove]).
|
||||
leashed_ports(default, [call,exit,fail,wake,apply]).
|
||||
leashed_ports(One, Ports) :-
|
||||
atom(One), One \== [], !,
|
||||
leashed_ports([One], Ports).
|
||||
leashed_ports(Set, Ports) :-
|
||||
sort(Set, Ports), % make unique
|
||||
leashed_ports(all, All),
|
||||
valid_ports(Ports, All).
|
||||
|
||||
valid_ports([], _).
|
||||
valid_ports([H|T], Valid) :-
|
||||
( memberchk(H, Valid)
|
||||
-> true
|
||||
; throw(error(domain_error(chr_port, H), _))
|
||||
),
|
||||
valid_ports(T, Valid).
|
||||
|
||||
|
||||
:- initialization
|
||||
leashed_ports(default, Ports),
|
||||
nb_setval(chr_leash, mutable(Ports)).
|
||||
|
||||
% debug_event(+State, +Event)
|
||||
|
||||
|
||||
%debug_event(trace, Event) :-
|
||||
% functor(Event, Name, Arity),
|
||||
% writeln(Name/Arity), fail.
|
||||
debug_event(trace,Event) :-
|
||||
Event = call(_), !,
|
||||
get_debug_history(History,Depth),
|
||||
NDepth is Depth + 1,
|
||||
chr_debug_interact(Event,NDepth),
|
||||
set_debug_history([Event|History],NDepth).
|
||||
debug_event(trace,Event) :-
|
||||
Event = wake(_), !,
|
||||
get_debug_history(History,Depth),
|
||||
NDepth is Depth + 1,
|
||||
chr_debug_interact(Event,NDepth),
|
||||
set_debug_history([Event|History],NDepth).
|
||||
debug_event(trace,Event) :-
|
||||
Event = redo(_), !,
|
||||
get_debug_history(_History, Depth),
|
||||
chr_debug_interact(Event, Depth).
|
||||
debug_event(trace,Event) :-
|
||||
Event = exit(_),!,
|
||||
get_debug_history([_|History],Depth),
|
||||
chr_debug_interact(Event,Depth),
|
||||
NDepth is Depth - 1,
|
||||
set_debug_history(History,NDepth).
|
||||
debug_event(trace,Event) :-
|
||||
Event = fail(_),!,
|
||||
get_debug_history(_,Depth),
|
||||
chr_debug_interact(Event,Depth).
|
||||
debug_event(trace, Event) :-
|
||||
Event = remove(_), !,
|
||||
get_debug_history(_,Depth),
|
||||
chr_debug_interact(Event, Depth).
|
||||
debug_event(trace, Event) :-
|
||||
Event = insert(_), !,
|
||||
get_debug_history(_,Depth),
|
||||
chr_debug_interact(Event, Depth).
|
||||
debug_event(trace, Event) :-
|
||||
Event = try(_,_,_,_), !,
|
||||
get_debug_history(_,Depth),
|
||||
chr_debug_interact(Event, Depth).
|
||||
debug_event(trace, Event) :-
|
||||
Event = apply(_,_,_,_), !,
|
||||
get_debug_history(_,Depth),
|
||||
chr_debug_interact(Event,Depth).
|
||||
|
||||
debug_event(skip(_,_),Event) :-
|
||||
Event = call(_), !,
|
||||
get_debug_history(History,Depth),
|
||||
NDepth is Depth + 1,
|
||||
set_debug_history([Event|History],NDepth).
|
||||
debug_event(skip(_,_),Event) :-
|
||||
Event = wake(_), !,
|
||||
get_debug_history(History,Depth),
|
||||
NDepth is Depth + 1,
|
||||
set_debug_history([Event|History],NDepth).
|
||||
debug_event(skip(SkipSusp,SkipDepth),Event) :-
|
||||
Event = exit(Susp),!,
|
||||
get_debug_history([_|History],Depth),
|
||||
( SkipDepth == Depth,
|
||||
SkipSusp == Susp ->
|
||||
set_chr_debug(trace),
|
||||
chr_debug_interact(Event,Depth)
|
||||
;
|
||||
true
|
||||
),
|
||||
NDepth is Depth - 1,
|
||||
set_debug_history(History,NDepth).
|
||||
debug_event(skip(_,_),_) :- !,
|
||||
true.
|
||||
|
||||
% chr_debug_interact(+Event, +Depth)
|
||||
%
|
||||
% Interact with the user on Event that took place at Depth. First
|
||||
% calls chr:debug_interact(+Event, +Depth, -Command) hook. If this
|
||||
% fails the event is printed and the system prompts for a command.
|
||||
|
||||
chr_debug_interact(Event, Depth) :-
|
||||
chr:debug_interact(Event, Depth, Command), !,
|
||||
handle_debug_command(Command,Event,Depth).
|
||||
chr_debug_interact(Event, Depth) :-
|
||||
print_event(Event, Depth),
|
||||
( leashed(Event)
|
||||
-> ask_continue(Command)
|
||||
; Command = creep
|
||||
),
|
||||
handle_debug_command(Command,Event,Depth).
|
||||
|
||||
leashed(Event) :-
|
||||
functor(Event, Port, _),
|
||||
nb_getval(chr_leash, mutable(Ports)),
|
||||
memberchk(Port, Ports).
|
||||
|
||||
ask_continue(Command) :-
|
||||
print_message(debug, chr(prompt)),
|
||||
get_single_char(CharCode),
|
||||
( CharCode == -1
|
||||
-> Char = end_of_file
|
||||
; char_code(Char, CharCode)
|
||||
),
|
||||
( debug_command(Char, Command)
|
||||
-> print_message(debug, chr(command(Command)))
|
||||
; print_message(help, chr(invalid_command)),
|
||||
ask_continue(Command)
|
||||
).
|
||||
|
||||
|
||||
'chr debug command'(Char, Command) :-
|
||||
debug_command(Char, Command).
|
||||
|
||||
debug_command(c, creep).
|
||||
debug_command(' ', creep).
|
||||
debug_command('\r', creep).
|
||||
debug_command(s, skip).
|
||||
debug_command(g, ancestors).
|
||||
debug_command(n, nodebug).
|
||||
debug_command(a, abort).
|
||||
debug_command(f, fail).
|
||||
debug_command(b, break).
|
||||
debug_command(?, help).
|
||||
debug_command(h, help).
|
||||
debug_command(end_of_file, exit).
|
||||
|
||||
|
||||
handle_debug_command(creep,_,_) :- !.
|
||||
handle_debug_command(skip, Event, Depth) :- !,
|
||||
Event =.. [Type|Rest],
|
||||
( Type \== call,
|
||||
Type \== wake ->
|
||||
handle_debug_command('c',Event,Depth)
|
||||
;
|
||||
Rest = [Susp],
|
||||
set_chr_debug(skip(Susp,Depth))
|
||||
).
|
||||
|
||||
handle_debug_command(ancestors,Event,Depth) :- !,
|
||||
print_chr_debug_history,
|
||||
chr_debug_interact(Event,Depth).
|
||||
handle_debug_command(nodebug,_,_) :- !,
|
||||
chr_notrace.
|
||||
handle_debug_command(abort,_,_) :- !,
|
||||
abort.
|
||||
handle_debug_command(exit,_,_) :- !,
|
||||
halt.
|
||||
handle_debug_command(fail,_,_) :- !,
|
||||
fail.
|
||||
handle_debug_command(break,Event,Depth) :- !,
|
||||
break,
|
||||
chr_debug_interact(Event,Depth).
|
||||
handle_debug_command(help,Event,Depth) :- !,
|
||||
print_message(help, chr(debug_options)),
|
||||
chr_debug_interact(Event,Depth).
|
||||
handle_debug_command(Cmd, _, _) :-
|
||||
throw(error(domain_error(chr_debug_command, Cmd), _)).
|
||||
|
||||
print_chr_debug_history :-
|
||||
get_debug_history(History,Depth),
|
||||
print_message(debug, chr(ancestors(History, Depth))).
|
||||
|
||||
print_event(Event, Depth) :-
|
||||
print_message(debug, chr(event(Event, Depth))).
|
||||
|
||||
% {set,get}_debug_history(Ancestors, Depth)
|
||||
%
|
||||
% Set/get the list of ancestors and the depth of the current goal.
|
||||
|
||||
get_debug_history(History,Depth) :-
|
||||
nb_getval(chr_debug_history,mutable(History,Depth)).
|
||||
|
||||
set_debug_history(History,Depth) :-
|
||||
nb_getval(chr_debug_history,Mutable),
|
||||
setarg(1,Mutable,History),
|
||||
setarg(2,Mutable,Depth).
|
||||
|
||||
set_chr_debug(State) :-
|
||||
nb_getval(chr_debug,Mutable),
|
||||
setarg(1,Mutable,State).
|
||||
|
||||
'chr chr_indexed_variables'(Susp,Vars) :-
|
||||
Susp =.. [_,_,_,_,_,_,_|Args],
|
||||
term_variables(Args,Vars).
|
||||
281
LGPL/chr/chr_swi.pl
Normal file
281
LGPL/chr/chr_swi.pl
Normal file
@ -0,0 +1,281 @@
|
||||
/* $Id: chr_swi.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers and Jan Wielemaker
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, K.U. Leuven
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(chr,
|
||||
[ op( 700, xfx, ::),
|
||||
op(1180, xfx, ==>),
|
||||
op(1180, xfx, <=>),
|
||||
op(1150, fx, constraints),
|
||||
op(1150, fx, handler),
|
||||
op(1150, fx, rules),
|
||||
op(1100, xfx, \),
|
||||
op(1200, xfx, @),
|
||||
op(1190, xfx, pragma),
|
||||
op( 500, yfx, #),
|
||||
op(1150, fx, chr_type),
|
||||
op(1130, xfx, --->),
|
||||
op(1150, fx, (?)),
|
||||
chr_show_store/1, % +Module
|
||||
find_chr_constraint/1, % +Pattern
|
||||
chr_trace/0,
|
||||
chr_notrace/0,
|
||||
chr_leash/1 % +Ports
|
||||
]).
|
||||
:- set_prolog_flag(generate_debug_info, false).
|
||||
|
||||
:- multifile user:file_search_path/2.
|
||||
:- dynamic user:file_search_path/2.
|
||||
:- dynamic chr_translated_program/1.
|
||||
|
||||
user:file_search_path(chr, library(chr)).
|
||||
|
||||
:- use_module(chr(chr_translate)).
|
||||
:- use_module(chr(chr_runtime)).
|
||||
:- use_module(chr(chr_debug)).
|
||||
:- use_module(chr(chr_messages)).
|
||||
:- use_module(library(gensym)).
|
||||
:- use_module(chr(chr_hashtable_store)).
|
||||
|
||||
:- dynamic
|
||||
chr_term/2. % File, Term
|
||||
|
||||
% chr_expandable(+Term)
|
||||
%
|
||||
% Succeeds if Term is a rule that must be handled by the CHR
|
||||
% compiler. Ideally CHR definitions should be between
|
||||
%
|
||||
% :- constraints ...
|
||||
% ...
|
||||
% :- end_constraints.
|
||||
%
|
||||
% As they are not we have to use some heuristics. We assume any
|
||||
% file is a CHR after we've seen :- constraints ... or if the file
|
||||
% is named *.chr
|
||||
|
||||
chr_expandable((:- constraints _)).
|
||||
chr_expandable((constraints _)).
|
||||
chr_expandable((:- chr_type _)).
|
||||
chr_expandable((chr_type _)).
|
||||
chr_expandable((handler _)) :-
|
||||
is_chr_file.
|
||||
chr_expandable((rules _)) :-
|
||||
is_chr_file.
|
||||
chr_expandable((_ <=> _)) :-
|
||||
is_chr_file.
|
||||
chr_expandable((_ @ _)) :-
|
||||
is_chr_file.
|
||||
chr_expandable((_ ==> _)) :-
|
||||
is_chr_file.
|
||||
chr_expandable((_ pragma _)) :-
|
||||
is_chr_file.
|
||||
chr_expandable(option(_, _)) :-
|
||||
is_chr_file.
|
||||
|
||||
is_chr_file :- true.
|
||||
/*
|
||||
source_location(File, _Line),
|
||||
( chr_term(File, _)
|
||||
-> true
|
||||
; file_name_extension(_, chr, File)
|
||||
).
|
||||
*/
|
||||
|
||||
% chr_expand(+Term, -Expansion)
|
||||
%
|
||||
% Extract CHR declarations and rules from the file and run the
|
||||
% CHR compiler when reaching end-of-file.
|
||||
|
||||
chr_expand(Term, []) :-
|
||||
chr_expandable(Term), !,
|
||||
source_location(File, _Line),
|
||||
assert(chr_term(File, Term)).
|
||||
chr_expand(end_of_file,
|
||||
[ (:- use_module(chr(chr_runtime))),
|
||||
(:- style_check(-(discontiguous))), % no need to restore; file ends
|
||||
(:- set_prolog_flag(generate_debug_info, false))
|
||||
| Program
|
||||
]) :-
|
||||
is_chr_file,
|
||||
source_location(File, _Line),
|
||||
findall(T, retract(chr_term(File, T)), CHR0),
|
||||
CHR0 \== [],
|
||||
% length(CHR0, NDecls),
|
||||
% format('Translating ~w declarations~n', [NDecls]),
|
||||
prolog_load_context(module, Module),
|
||||
( Module == user
|
||||
-> ( memberchk(handler(Handler), CHR0)
|
||||
-> true
|
||||
; gensym(chr_handler, Handler)
|
||||
)
|
||||
; Handler = Module
|
||||
),
|
||||
add_debug_decl(CHR0, CHR1),
|
||||
add_optimise_decl(CHR1, CHR),
|
||||
call_chr_translate(File,
|
||||
[ (:- module(Handler, []))
|
||||
| CHR
|
||||
],
|
||||
Program0),
|
||||
delete_header(Program0, Program).
|
||||
|
||||
|
||||
delete_header([(:- module(_,_))|T0], T) :- !,
|
||||
delete_header(T0, T).
|
||||
delete_header(L, L).
|
||||
|
||||
add_debug_decl(CHR, CHR) :-
|
||||
memberchk(option(debug, _), CHR), !.
|
||||
add_debug_decl(CHR, [option(debug, Debug)|CHR]) :-
|
||||
( current_prolog_flag(generate_debug_info, true)
|
||||
-> Debug = on
|
||||
; Debug = off
|
||||
).
|
||||
|
||||
add_optimise_decl(CHR, CHR) :-
|
||||
memberchk(option(optimize, _), CHR), !.
|
||||
add_optimise_decl(CHR, [option(optimize, full)|CHR]) :-
|
||||
current_prolog_flag(optimize, true), !.
|
||||
add_optimise_decl(CHR, CHR).
|
||||
|
||||
|
||||
% call_chr_translate(+File, +In, -Out)
|
||||
%
|
||||
% The entire chr_translate/2 translation may fail, in which we'd
|
||||
% better issue a warning rather than simply ignoring the CHR
|
||||
% declarations.
|
||||
|
||||
call_chr_translate(_, In, _Out) :-
|
||||
( chr_translate(In, Out0) ->
|
||||
nb_setval(chr_translated_program,Out0),
|
||||
fail
|
||||
).
|
||||
call_chr_translate(_, _In, Out) :-
|
||||
nb_current(chr_translated_program,Out),!,nb_delete(chr_translated_program).
|
||||
|
||||
call_chr_translate(File, _, []) :-
|
||||
print_message(error, chr(compilation_failed(File))).
|
||||
|
||||
|
||||
/*******************************
|
||||
* SYNCHRONISE TRACER *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
user:message_hook/3,
|
||||
chr:debug_event/2,
|
||||
chr:debug_interact/3.
|
||||
:- dynamic
|
||||
user:message_hook/3.
|
||||
|
||||
user:message_hook(trace_mode(OnOff), _, _) :-
|
||||
( OnOff == on
|
||||
-> chr_trace
|
||||
; chr_notrace
|
||||
),
|
||||
fail. % backtrack to other handlers
|
||||
|
||||
% chr:debug_event(+State, +Event)
|
||||
%
|
||||
% Hook into the CHR debugger. At this moment we will discard CHR
|
||||
% events if we are in a Prolog `skip' and we ignore the
|
||||
|
||||
chr:debug_event(_State, _Event) :-
|
||||
tracing, % are we tracing?
|
||||
prolog_skip_level(Skip, Skip),
|
||||
Skip \== very_deep,
|
||||
prolog_current_frame(Me),
|
||||
prolog_frame_attribute(Me, level, Level),
|
||||
Level > Skip, !.
|
||||
|
||||
% chr:debug_interact(+Event, +Depth, -Command)
|
||||
%
|
||||
% Hook into the CHR debugger to display Event and ask for the next
|
||||
% command to execute. This definition causes the normal Prolog
|
||||
% debugger to be used for the standard ports.
|
||||
|
||||
chr:debug_interact(Event, _Depth, creep) :-
|
||||
prolog_event(Event),
|
||||
tracing, !.
|
||||
|
||||
prolog_event(call(_)).
|
||||
prolog_event(exit(_)).
|
||||
prolog_event(fail(_)).
|
||||
|
||||
|
||||
|
||||
|
||||
/*******************************
|
||||
* MESSAGES *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
prolog:message/3.
|
||||
|
||||
prolog:message(chr(CHR)) -->
|
||||
chr_message(CHR).
|
||||
|
||||
/*******************************
|
||||
* TOPLEVEL PRINTING *
|
||||
*******************************/
|
||||
|
||||
:- set_prolog_flag(chr_toplevel_show_store,true).
|
||||
|
||||
:- multifile chr:'$chr_module'/1.
|
||||
|
||||
prolog:message(query(YesNo)) --> !,
|
||||
['~@'-[chr:print_all_stores]],
|
||||
'$messages':prolog_message(query(YesNo)).
|
||||
|
||||
prolog:message(query(YesNo,Bindings)) --> !,
|
||||
['~@'-[chr:print_all_stores]],
|
||||
'$messages':prolog_message(query(YesNo,Bindings)).
|
||||
|
||||
print_all_stores :-
|
||||
( current_prolog_flag(chr_toplevel_show_store,true),
|
||||
catch(nb_getval(chr_global, _), _, fail),
|
||||
chr:'$chr_module'(Mod),
|
||||
chr_show_store(Mod),
|
||||
fail
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
/*******************************
|
||||
* MUST BE LAST! *
|
||||
*******************************/
|
||||
|
||||
:- multifile user:term_expansion/2.
|
||||
:- dynamic user:term_expansion/2.
|
||||
|
||||
user:term_expansion(In, Out) :-
|
||||
chr_expand(In, Out).
|
||||
|
||||
|
||||
159
LGPL/chr/chr_swi_bootstrap.pl
Normal file
159
LGPL/chr/chr_swi_bootstrap.pl
Normal file
@ -0,0 +1,159 @@
|
||||
/* $Id: chr_swi_bootstrap.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, K.U. Leuven
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
|
||||
|
||||
:- module(chr,
|
||||
[ chr_compile_step1/2 % +CHRFile, -PlFile
|
||||
, chr_compile_step2/2 % +CHRFile, -PlFile
|
||||
, chr_compile_step3/2 % +CHRFile, -PlFile
|
||||
, chr_compile_step4/2 % +CHRFile, -PlFile
|
||||
]).
|
||||
|
||||
:- use_module(library(listing)). % portray_clause/2
|
||||
|
||||
:- include('chr_op').
|
||||
|
||||
/*******************************
|
||||
* FILE-TO-FILE COMPILER *
|
||||
*******************************/
|
||||
|
||||
% chr_compile(+CHRFile, -PlFile)
|
||||
%
|
||||
% Compile a CHR specification into a Prolog file
|
||||
|
||||
chr_compile_step1(From, To) :-
|
||||
use_module('chr_translate_bootstrap.pl'),
|
||||
chr_compile(From, To, informational).
|
||||
chr_compile_step2(From, To) :-
|
||||
use_module('chr_translate_bootstrap1.pl'),
|
||||
chr_compile(From, To, informational).
|
||||
chr_compile_step3(From, To) :-
|
||||
use_module('chr_translate_bootstrap2.pl'),
|
||||
chr_compile(From, To, informational).
|
||||
chr_compile_step4(From, To) :-
|
||||
use_module('chr_translate.pl'),
|
||||
chr_compile(From, To, informational).
|
||||
|
||||
chr_compile(From, To, MsgLevel) :-
|
||||
print_message(MsgLevel, chr(start(From))),
|
||||
read_chr_file_to_terms(From,Declarations),
|
||||
% read_file_to_terms(From, Declarations,
|
||||
% [ module(chr) % get operators from here
|
||||
% ]),
|
||||
print_message(silent, chr(translate(From))),
|
||||
chr_translate(Declarations, Declarations1),
|
||||
insert_declarations(Declarations1, NewDeclarations),
|
||||
print_message(silent, chr(write(To))),
|
||||
writefile(To, From, NewDeclarations),
|
||||
print_message(MsgLevel, chr(end(From, To))).
|
||||
|
||||
|
||||
insert_declarations(Clauses0, Clauses) :- %vsc
|
||||
( Clauses0 = [(:- module(M,E))|FileBody]
|
||||
-> Clauses = [ (:- module(M,E)),
|
||||
(:- use_module('chr_runtime')),
|
||||
(:- style_check(-singleton)),
|
||||
(:- style_check(-discontiguous))
|
||||
| FileBody
|
||||
]
|
||||
; Clauses = [ (:- use_module('chr_runtime')),
|
||||
(:- style_check(-singleton)),
|
||||
(:- style_check(-discontiguous))
|
||||
| Clauses0
|
||||
]
|
||||
).
|
||||
|
||||
% writefile(+File, +From, +Desclarations)
|
||||
%
|
||||
% Write translated CHR declarations to a File.
|
||||
|
||||
writefile(File, From, Declarations) :-
|
||||
open(File, write, Out),
|
||||
writeheader(From, Out),
|
||||
writecontent(Declarations, Out),
|
||||
close(Out).
|
||||
|
||||
writecontent([], _).
|
||||
writecontent([D|Ds], Out) :-
|
||||
portray_clause(Out, D), % SWI-Prolog
|
||||
writecontent(Ds, Out).
|
||||
|
||||
|
||||
writeheader(File, Out) :-
|
||||
get_time(Now),
|
||||
convert_time(Now, Date),
|
||||
format(Out, '/* Generated by CHR bootstrap compiler~n', []),
|
||||
format(Out, ' From: ~w~n', [File]),
|
||||
format(Out, ' Date: ~w~n~n', [Date]),
|
||||
format(Out, ' DO NOT EDIT. EDIT THE CHR FILE INSTEAD~n', []),
|
||||
format(Out, '*/~n~n', []).
|
||||
|
||||
|
||||
/*******************************
|
||||
* MESSAGES *
|
||||
*******************************/
|
||||
|
||||
|
||||
:- multifile
|
||||
prolog:message/3.
|
||||
|
||||
prolog:message(chr(start(File))) -->
|
||||
{ file_base_name(File, Base)
|
||||
},
|
||||
[ 'Translating CHR file ~w'-[Base] ].
|
||||
prolog:message(chr(end(_From, To))) -->
|
||||
{ file_base_name(To, Base)
|
||||
},
|
||||
[ 'Written translation to ~w'-[Base] ].
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
read_chr_file_to_terms(Spec, Terms) :-
|
||||
absolute_file_name(Spec, [ access(read) ],
|
||||
Path),
|
||||
open(Path, read, Fd, []),
|
||||
read_chr_stream_to_terms(Fd, Terms),
|
||||
close(Fd).
|
||||
|
||||
read_chr_stream_to_terms(Fd, Terms) :-
|
||||
read_term(Fd, C0, [ module(chr) ]),
|
||||
read_chr_stream_to_terms(C0, Fd, Terms).
|
||||
|
||||
read_chr_stream_to_terms(end_of_file, _, []) :- !.
|
||||
read_chr_stream_to_terms(C, Fd, [C|T]) :-
|
||||
( ground(C),
|
||||
C = (:- op(Priority,Type,Name)) ->
|
||||
op(Priority,Type,Name)
|
||||
;
|
||||
true
|
||||
),
|
||||
read_term(Fd, C2, [module(chr)]),
|
||||
read_chr_stream_to_terms(C2, Fd, T).
|
||||
10
LGPL/chr/chr_swi_bootstrap.yap
Normal file
10
LGPL/chr/chr_swi_bootstrap.yap
Normal file
@ -0,0 +1,10 @@
|
||||
|
||||
:- use_module(library(swi)).
|
||||
|
||||
:- yap_flag(unknown,error).
|
||||
|
||||
library_directory('yap_extras').
|
||||
|
||||
:- include('chr_swi_bootstrap.pl').
|
||||
|
||||
|
||||
13
LGPL/chr/chr_swi_bootstrap.yap.in
Normal file
13
LGPL/chr/chr_swi_bootstrap.yap.in
Normal file
@ -0,0 +1,13 @@
|
||||
|
||||
|
||||
:- multifile user:file_search_path/2.
|
||||
|
||||
:- add_to_path('@srcdir@').
|
||||
|
||||
:- use_module(library(swi)).
|
||||
|
||||
:- yap_flag(unknown,error).
|
||||
|
||||
:- include('chr_swi_bootstrap.pl').
|
||||
|
||||
|
||||
151
LGPL/chr/chr_test.pl
Normal file
151
LGPL/chr/chr_test.pl
Normal file
@ -0,0 +1,151 @@
|
||||
/* $Id: chr_test.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
|
||||
|
||||
E-mail: jan@swi.psy.uva.nl
|
||||
|
||||
Copyright (C) 1996 University of Amsterdam. All rights reserved.
|
||||
*/
|
||||
|
||||
:- asserta(user:file_search_path(chr, '.')).
|
||||
:- asserta(user:file_search_path(library, '.')).
|
||||
:- use_module(chr). % == library(chr)
|
||||
|
||||
:- set_prolog_flag(optimise, true).
|
||||
%:- set_prolog_flag(trace_gc, true).
|
||||
|
||||
:- format('CHR test suite. To run all tests run ?- test.~n~n', []).
|
||||
|
||||
% Required to get this always running regardless of user LANG setting.
|
||||
% Without this the tests won't run on machines with -for example- LANG=ja
|
||||
% according to NIDE Naoyuki, nide@ics.nara-wu.ac.jp. Thanks!
|
||||
|
||||
:- getenv('LANG', _) -> setenv('LANG', 'C'); true.
|
||||
|
||||
|
||||
/*******************************
|
||||
* SCRIPTS *
|
||||
*******************************/
|
||||
|
||||
|
||||
:- dynamic
|
||||
script_dir/1.
|
||||
|
||||
set_script_dir :-
|
||||
script_dir(_), !.
|
||||
set_script_dir :-
|
||||
find_script_dir(Dir),
|
||||
assert(script_dir(Dir)).
|
||||
|
||||
find_script_dir(Dir) :-
|
||||
prolog_load_context(file, File),
|
||||
follow_links(File, RealFile),
|
||||
file_directory_name(RealFile, Dir).
|
||||
|
||||
follow_links(File, RealFile) :-
|
||||
read_link(File, _, RealFile), !.
|
||||
follow_links(File, File).
|
||||
|
||||
|
||||
:- set_script_dir.
|
||||
|
||||
run_test_script(Script) :-
|
||||
file_base_name(Script, Base),
|
||||
file_name_extension(Pred, _, Base),
|
||||
load_files(Script, []), %[silent(true)]),
|
||||
Pred.
|
||||
|
||||
run_test_scripts(Directory) :-
|
||||
( script_dir(ScriptDir),
|
||||
concat_atom([ScriptDir, /, Directory], Dir),
|
||||
exists_directory(Dir)
|
||||
-> true
|
||||
; Dir = Directory
|
||||
),
|
||||
atom_concat(Dir, '/*.chr', Pattern),
|
||||
expand_file_name(Pattern, Files),
|
||||
file_base_name(Dir, BaseDir),
|
||||
format('Running scripts from ~w ', [BaseDir]), flush,
|
||||
run_scripts(Files),
|
||||
format(' done~n').
|
||||
|
||||
run_scripts([]).
|
||||
run_scripts([H|T]) :-
|
||||
( catch(run_test_script(H), Except, true)
|
||||
-> ( var(Except)
|
||||
-> put(.), flush
|
||||
; Except = blocked(Reason)
|
||||
-> assert(blocked(H, Reason)),
|
||||
put(!), flush
|
||||
; script_failed(H, Except)
|
||||
)
|
||||
; script_failed(H, fail)
|
||||
),
|
||||
run_scripts(T).
|
||||
|
||||
script_failed(File, fail) :-
|
||||
format('~NScript ~w failed~n', [File]),
|
||||
assert(failed(script(File))).
|
||||
script_failed(File, Except) :-
|
||||
message_to_string(Except, Error),
|
||||
format('~NScript ~w failed: ~w~n', [File, Error]),
|
||||
assert(failed(script(File))).
|
||||
|
||||
|
||||
/*******************************
|
||||
* TEST MAIN-LOOP *
|
||||
*******************************/
|
||||
|
||||
testdir('Tests').
|
||||
|
||||
:- dynamic
|
||||
failed/1,
|
||||
blocked/2.
|
||||
|
||||
test :-
|
||||
retractall(failed(_)),
|
||||
retractall(blocked(_,_)),
|
||||
scripts,
|
||||
report_blocked,
|
||||
report_failed.
|
||||
|
||||
scripts :-
|
||||
forall(testdir(Dir), run_test_scripts(Dir)).
|
||||
|
||||
|
||||
report_blocked :-
|
||||
findall(Head-Reason, blocked(Head, Reason), L),
|
||||
( L \== []
|
||||
-> format('~nThe following tests are blocked:~n', []),
|
||||
( member(Head-Reason, L),
|
||||
format(' ~p~t~40|~w~n', [Head, Reason]),
|
||||
fail
|
||||
; true
|
||||
)
|
||||
; true
|
||||
).
|
||||
report_failed :-
|
||||
findall(X, failed(X), L),
|
||||
length(L, Len),
|
||||
( Len > 0
|
||||
-> format('~n*** ~w tests failed ***~n', [Len]),
|
||||
fail
|
||||
; format('~nAll tests passed~n', [])
|
||||
).
|
||||
|
||||
test_failed(R, Except) :-
|
||||
clause(Head, _, R),
|
||||
functor(Head, Name, 1),
|
||||
arg(1, Head, TestName),
|
||||
clause_property(R, line_count(Line)),
|
||||
clause_property(R, file(File)),
|
||||
( Except == fail
|
||||
-> format('~N~w:~d: Test ~w(~w) failed~n',
|
||||
[File, Line, Name, TestName])
|
||||
; message_to_string(Except, Error),
|
||||
format('~N~w:~d: Test ~w(~w):~n~t~8|ERROR: ~w~n',
|
||||
[File, Line, Name, TestName, Error])
|
||||
),
|
||||
assert(failed(Head)).
|
||||
|
||||
blocked(Reason) :-
|
||||
throw(blocked(Reason)).
|
||||
|
||||
5187
LGPL/chr/chr_translate.chr
Normal file
5187
LGPL/chr/chr_translate.chr
Normal file
File diff suppressed because it is too large
Load Diff
9228
LGPL/chr/chr_translate.pl
Normal file
9228
LGPL/chr/chr_translate.pl
Normal file
File diff suppressed because it is too large
Load Diff
2488
LGPL/chr/chr_translate_bootstrap.pl
Normal file
2488
LGPL/chr/chr_translate_bootstrap.pl
Normal file
File diff suppressed because it is too large
Load Diff
2816
LGPL/chr/chr_translate_bootstrap1.chr
Normal file
2816
LGPL/chr/chr_translate_bootstrap1.chr
Normal file
File diff suppressed because it is too large
Load Diff
3659
LGPL/chr/chr_translate_bootstrap2.chr
Normal file
3659
LGPL/chr/chr_translate_bootstrap2.chr
Normal file
File diff suppressed because it is too large
Load Diff
163
LGPL/chr/clean_code.pl
Normal file
163
LGPL/chr/clean_code.pl
Normal file
@ -0,0 +1,163 @@
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
% Author: Tom Schrijvers
|
||||
% Email: Tom.Schrijvers@cs.kuleuven.ac.be
|
||||
% Copyright: K.U.Leuven 2004
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%% ____ _ ____ _ _
|
||||
%% / ___|___ __| | ___ / ___| | ___ __ _ _ __ (_)_ __ __ _
|
||||
%% | | / _ \ / _` |/ _ \ | | | |/ _ \/ _` | '_ \| | '_ \ / _` |
|
||||
%% | |__| (_) | (_| | __/ | |___| | __/ (_| | | | | | | | | (_| |
|
||||
%% \____\___/ \__,_|\___| \____|_|\___|\__,_|_| |_|_|_| |_|\__, |
|
||||
%% |___/
|
||||
%%
|
||||
%% removes redundant 'true's and other trivial but potentially non-free constructs
|
||||
|
||||
% TODO
|
||||
% Remove last clause with Body = fail
|
||||
|
||||
:- module(clean_code,
|
||||
[
|
||||
clean_clauses/2
|
||||
]).
|
||||
|
||||
:- use_module(hprolog, [memberchk_eq/2]).
|
||||
|
||||
clean_clauses([],[]).
|
||||
clean_clauses([C|Cs],[NC|NCs]) :-
|
||||
clean_clause(C,NC),
|
||||
clean_clauses(Cs,NCs).
|
||||
|
||||
clean_clause(Clause,NClause) :-
|
||||
( Clause = (Head :- Body) ->
|
||||
clean_goal(Body,Body1),
|
||||
move_unification_into_head(Head,Body1,NHead,NBody),
|
||||
( NBody == true ->
|
||||
NClause = NHead
|
||||
;
|
||||
NClause = (NHead :- NBody)
|
||||
)
|
||||
;
|
||||
NClause = Clause
|
||||
).
|
||||
|
||||
clean_goal(Goal,NGoal) :-
|
||||
var(Goal), !,
|
||||
NGoal = Goal.
|
||||
clean_goal((G1,G2),NGoal) :-
|
||||
!,
|
||||
clean_goal(G1,NG1),
|
||||
clean_goal(G2,NG2),
|
||||
( NG1 == true ->
|
||||
NGoal = NG2
|
||||
; NG2 == true ->
|
||||
NGoal = NG1
|
||||
;
|
||||
NGoal = (NG1,NG2)
|
||||
).
|
||||
clean_goal((If -> Then ; Else),NGoal) :-
|
||||
!,
|
||||
clean_goal(If,NIf),
|
||||
( NIf == true ->
|
||||
clean_goal(Then,NThen),
|
||||
NGoal = NThen
|
||||
; NIf == fail ->
|
||||
clean_goal(Else,NElse),
|
||||
NGoal = NElse
|
||||
;
|
||||
clean_goal(Then,NThen),
|
||||
clean_goal(Else,NElse),
|
||||
NGoal = (NIf -> NThen; NElse)
|
||||
).
|
||||
clean_goal((G1 ; G2),NGoal) :-
|
||||
!,
|
||||
clean_goal(G1,NG1),
|
||||
clean_goal(G2,NG2),
|
||||
( NG1 == fail ->
|
||||
NGoal = NG2
|
||||
; NG2 == fail ->
|
||||
NGoal = NG1
|
||||
;
|
||||
NGoal = (NG1 ; NG2)
|
||||
).
|
||||
clean_goal(once(G),NGoal) :-
|
||||
!,
|
||||
clean_goal(G,NG),
|
||||
( NG == true ->
|
||||
NGoal = true
|
||||
; NG == fail ->
|
||||
NGoal = fail
|
||||
;
|
||||
NGoal = once(NG)
|
||||
).
|
||||
clean_goal((G1 -> G2),NGoal) :-
|
||||
!,
|
||||
clean_goal(G1,NG1),
|
||||
( NG1 == true ->
|
||||
clean_goal(G2,NGoal)
|
||||
; NG1 == fail ->
|
||||
NGoal = fail
|
||||
;
|
||||
clean_goal(G2,NG2),
|
||||
NGoal = (NG1 -> NG2)
|
||||
).
|
||||
clean_goal(Goal,Goal).
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
move_unification_into_head(Head,Body,NHead,NBody) :-
|
||||
conj2list(Body,BodyList),
|
||||
move_unification_into_head_(BodyList,Head,NHead,NBody).
|
||||
|
||||
move_unification_into_head_([],Head,Head,true).
|
||||
move_unification_into_head_([G|Gs],Head,NHead,NBody) :-
|
||||
( nonvar(G), G = (X = Y) ->
|
||||
term_variables(Gs,GsVars),
|
||||
( var(X), ( \+ memberchk_eq(X,GsVars) ; atomic(Y)) ->
|
||||
X = Y,
|
||||
move_unification_into_head_(Gs,Head,NHead,NBody)
|
||||
; var(Y), (\+ memberchk_eq(Y,GsVars) ; atomic(X)) ->
|
||||
X = Y,
|
||||
move_unification_into_head_(Gs,Head,NHead,NBody)
|
||||
;
|
||||
Head = NHead,
|
||||
list2conj([G|Gs],NBody)
|
||||
)
|
||||
;
|
||||
Head = NHead,
|
||||
list2conj([G|Gs],NBody)
|
||||
).
|
||||
|
||||
% move_unification_into_head(Head,Body,NHead,NBody) :-
|
||||
% ( Body = (X = Y, More) ; Body = (X = Y), More = true), !,
|
||||
% ( var(X), term_variables(More,MoreVars), \+ memberchk_eq(X,MoreVars) ->
|
||||
% X = Y,
|
||||
% move_unification_into_head(Head,More,NHead,NBody)
|
||||
% ; var(Y) ->
|
||||
% move_unification_into_head(Head,(Y = X,More),NHead,NBody)
|
||||
% ;
|
||||
% NHead = Head,
|
||||
% NBody = Body
|
||||
% ).
|
||||
%
|
||||
% move_unification_into_head(Head,Body,Head,Body).
|
||||
|
||||
|
||||
conj2list(Conj,L) :- %% transform conjunctions to list
|
||||
conj2list(Conj,L,[]).
|
||||
|
||||
conj2list(Conj,L,T) :-
|
||||
Conj = (true,G2), !,
|
||||
conj2list(G2,L,T).
|
||||
conj2list(Conj,L,T) :-
|
||||
Conj = (G1,G2), !,
|
||||
conj2list(G1,L,T1),
|
||||
conj2list(G2,T1,T).
|
||||
conj2list(G,[G | T],T).
|
||||
|
||||
list2conj([],true).
|
||||
list2conj([G],X) :- !, X = G.
|
||||
list2conj([G|Gs],C) :-
|
||||
( G == true -> %% remove some redundant trues
|
||||
list2conj(Gs,C)
|
||||
;
|
||||
C = (G,R),
|
||||
list2conj(Gs,R)
|
||||
).
|
||||
62
LGPL/chr/find.pl
Normal file
62
LGPL/chr/find.pl
Normal file
@ -0,0 +1,62 @@
|
||||
/* $Id: find.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Bart Demoen, Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, K.U. Leuven
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(chr_find,
|
||||
[
|
||||
find_with_var_identity/4,
|
||||
forall/3,
|
||||
forsome/3
|
||||
]).
|
||||
|
||||
:- use_module(library(lists)).
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
:- meta_predicate
|
||||
find_with_var_identity(?, +, :, -),
|
||||
forall(-, +, :),
|
||||
forsome(-, +, :).
|
||||
|
||||
find_with_var_identity(Template, IdVars, Goal, Answers) :-
|
||||
Key = foo(IdVars),
|
||||
findall(Key - Template, Goal, As),
|
||||
smash(As,Key,Answers).
|
||||
|
||||
smash([],_,[]).
|
||||
smash([Key-T|R],Key,[T|NR]) :- smash(R,Key,NR).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
forall(X,L,G) :-
|
||||
\+ (member(X,L), \+ call(G)).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
forsome(X,L,G) :-
|
||||
member(X,L),
|
||||
call(G), !.
|
||||
459
LGPL/chr/guard_entailment.chr
Normal file
459
LGPL/chr/guard_entailment.chr
Normal file
@ -0,0 +1,459 @@
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
% Author: Jon Sneyers
|
||||
% Email: jon@cs.kuleuven.ac.be
|
||||
% Copyright: K.U.Leuven 2004
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
:- module(guard_entailment,
|
||||
[
|
||||
entails_guard/2,
|
||||
simplify_guards/5
|
||||
]).
|
||||
|
||||
%:- use_module(library(chr)).
|
||||
:- use_module(library(lists)).
|
||||
:- use_module(hprolog).
|
||||
:- use_module(builtins).
|
||||
|
||||
option(debug,off).
|
||||
option(optimize,full).
|
||||
|
||||
|
||||
:- constraints known/1,test/1,cleanup/0,variables/1.
|
||||
|
||||
% knowing the same thing twice is redundant
|
||||
idempotence @ known(G) \ known(G) <=> true.
|
||||
|
||||
|
||||
%--------------------------------------
|
||||
% Rules to check if the argument of
|
||||
% test/1 is entailed by known stuff
|
||||
%--------------------------------------
|
||||
|
||||
% everything follows from an inconsistent theory
|
||||
fail_implies_everything @ known(fail) \ test(X) <=> true.
|
||||
|
||||
% if it's known, it's entailed
|
||||
trivial_entailment @ known(G) \ test(G) <=> true.
|
||||
|
||||
varfirst_nmatch @ test(X\==A) <=> nonvar(X) | test(A\==X).
|
||||
distribute_nmatch @ test(X\==A) <=> nonvar(A),functor(A,Fu,Ar) |
|
||||
A =.. [F|AArgs],
|
||||
length(XArgs,Ar), B =.. [Fu|XArgs],
|
||||
add_args_nmatch(XArgs,AArgs,ArgCond),
|
||||
C = (\+ functor(X,Fu,Ar) ; (functor(X,Fu,Ar),X=B,ArgCond)),
|
||||
test(C).
|
||||
|
||||
% eq implies leq
|
||||
eq_implies_leq1 @ known(X=:=Y) \ test(X=<Y) <=> true.
|
||||
eq_implies_leq2 @ known(X=:=Z) \ test(X=<Y) <=> number(Y), number(Z), Z=<Y |true.
|
||||
eq_implies_leq3 @ known(X=:=Z) \ test(Y=<X) <=> number(Y), number(Z), Y=<Z |true.
|
||||
|
||||
% stronger inequality implies a weaker one
|
||||
leq_implies_leq1 @ known(X=<Z) \ test(X=<Y) <=> number(Y), number(Z), Z=<Y |true.
|
||||
leq_implies_leq2 @ known(X=<Y) \ test(Z=<Y) <=> number(X), number(Z), Z=<X | true.
|
||||
|
||||
% X =< Z implies X =\= Y for all Y > Z
|
||||
leq_implies_neq1 @ known(X=<Z) \ test(X=\=Y) <=> number(Y), number(Z), Y>Z | true.
|
||||
leq_implies_neq2 @ known(X=<Y) \ test(Y=\=Z) <=> number(X), number(Z), Z<X | true.
|
||||
|
||||
|
||||
%--------------------------------------
|
||||
% Rules to translate some stuff
|
||||
%--------------------------------------
|
||||
|
||||
% we only want =<, =:= and =\=
|
||||
known_g2l @ known(X>Y) <=> known(Y<X).
|
||||
known_geq2leq @ known(X>=Y) <=> known(Y=<X).
|
||||
known_l2leq_neq @ known(X<Y) <=> known(X=<Y), known(X=\=Y).
|
||||
known_is2eq @ known(X is Y) <=> known(X=:=Y).
|
||||
test_g2l @ test(X>Y) <=> test(Y<X).
|
||||
test_geq2leq @test(X>=Y) <=> test(Y=<X).
|
||||
test_l2leq_neq @test(X<Y) <=> test(((X=<Y),(X=\=Y))).
|
||||
test_is2eq @ test(X is Y) <=> test(X=:=Y).
|
||||
|
||||
% propagate == and \== to =:= and =\= (which is a weaker statement)
|
||||
match2eq1 @ known(X==Y) ==> number(X) | known(X=:=Y).
|
||||
match2eq2 @known(X==Y) ==> number(Y) | known(X=:=Y).
|
||||
nmatch2neq1 @ known(X\==Y) ==> number(X) | known(X=\=Y).
|
||||
nmatch2neq2 @ known(X\==Y) ==> number(Y) | known(X=\=Y).
|
||||
|
||||
|
||||
%--------------------------------------
|
||||
% Rules to extend the known stuff
|
||||
%--------------------------------------
|
||||
|
||||
% if we derived inconsistency, all other knowledge is redundant
|
||||
fail_is_better_than_anything_else @ known(fail) \ known(_) <=> true.
|
||||
|
||||
% conjunctions
|
||||
conj @ known((A,B)) <=> known(A), known(B).
|
||||
|
||||
% no need to remember trivial stuff
|
||||
forget_trivial01 @ known(X=:=X) <=> true.
|
||||
forget_trivial02 @ known(X==X) <=> true.
|
||||
forget_trivial03 @ known(X=<X) <=> true.
|
||||
forget_trivial04 @ known(X=X) <=> true.
|
||||
|
||||
|
||||
%--------------------------------------
|
||||
% Rules for = and \= (and functor)
|
||||
%--------------------------------------
|
||||
unify_vars1 @ known(X=Y) <=> var(X) | X=Y.
|
||||
unify_vars2 @ known(X=Y) <=> var(Y) | X=Y.
|
||||
%functor @ known(functor(X,F,A)) <=> var(X),ground(F),ground(A) | functor(X,F,A).
|
||||
inconsistency4 @ known(X\=Y) <=> var(X),var(Y),X=Y | known(fail).
|
||||
inconsistency4 @ known(X\=Y) <=> ground(X),ground(Y),X=Y | known(fail).
|
||||
|
||||
functor @ variables(V),known(functor(X,F,A)) <=>
|
||||
var(X), ground(F), ground(A) |
|
||||
functor(X,F,A),
|
||||
X =.. [_|Args],
|
||||
append(Args,V,NewV),
|
||||
variables(NewV).
|
||||
|
||||
functor_inconsistency1 @ known(functor(X,F1,A1)) <=> nonvar(X), \+ functor(X,F1,A1) | known(fail).
|
||||
negfunctor_trivial @ known(\+ functor(X,F1,A1)) <=> nonvar(X), functor(X,F1,A1) | known(fail).
|
||||
functor_inconsistency2 @ known(functor(X,F1,A1)), known(functor(X,F2,A2)) <=>
|
||||
nonvar(F1),nonvar(A1),nonvar(F2),nonvar(A2)
|
||||
% (F1 \= F2 ; A1 \= A2) is entailed by idempotence
|
||||
| known(fail).
|
||||
nunify_inconsistency @ known(X\=X) <=> known(fail).
|
||||
nonvar_unification @ known(X=Y) <=> nonvar(X), nonvar(Y),functor(X,F,A) |
|
||||
( functor(Y,F,A),X=Y ->
|
||||
true
|
||||
;
|
||||
known(fail)
|
||||
).
|
||||
nunify_expand @ known(X\=Y) <=> var(X),nonvar(Y), functor(Y,F,A), A>0 |
|
||||
length(Args,A),
|
||||
Y =.. [F|YArgs],
|
||||
Y1 =.. [F|Args],
|
||||
add_args_nunif(YArgs,Args,Nunif),
|
||||
C = (\+ functor(X,F,A) ; (X = Y1, Nunif )),
|
||||
known(C).
|
||||
nunify_expand2 @ known(X\=Y) <=> nonvar(X),nonvar(Y), functor(X,F,A) |
|
||||
(functor(Y,F,A) ->
|
||||
X =.. [F|XArgs],
|
||||
Y =.. [F|YArgs],
|
||||
add_args_nunif(XArgs,YArgs,Nunif),
|
||||
known(Nunif)
|
||||
;
|
||||
true
|
||||
).
|
||||
nunify_symmetry @ known(X\=Y) ==> known(Y\=X).
|
||||
|
||||
|
||||
%--------------------------------------
|
||||
% Rules for =<
|
||||
%--------------------------------------
|
||||
|
||||
groundleq2 @ known(X=<Y) <=> number(X), number(Y), X>Y | known(fail).
|
||||
|
||||
% only keep the strictest inequality
|
||||
remove_redundant_leq1 @ known(X=<Y) \ known(X=<Z) <=> number(Y), number(Z), Y=<Z | true.
|
||||
remove_redundant_leq1 @ known(Z=<Y) \ known(X=<Y) <=> number(X), number(Z), X=<Z | true.
|
||||
|
||||
leq_antisymmetry @ known(X=<Y), known(Y=<X) <=> known(X=:=Y).
|
||||
leq_transitivity @ known(X=<Y), known(Y=<Z) ==> known(X=<Z).
|
||||
|
||||
strict_leq_transitivity @ known(X=<Y),known(X=\=Y),known(Y=<Z),known(Y=\=Z) ==> known(X=\=Z).
|
||||
|
||||
|
||||
%--------------------------------------
|
||||
% Rules for =:= (and =\=)
|
||||
%--------------------------------------
|
||||
|
||||
groundeq2 @ known(X=:=Y) <=> number(X), number(Y), X=\=Y | known(fail).
|
||||
groundneq2 @ known(X=\=Y) <=> number(X), number(Y), X=:=Y | known(fail).
|
||||
|
||||
neq_inconsistency @ known(X=\=X) <=> known(fail).
|
||||
inconsistency @ known(X=:=Y), known(X=\=Y) <=> known(fail).
|
||||
|
||||
eq_transitivity @ known(X=:=Y), known(Y=:=Z) ==> X \== Z | known(X=:=Z).
|
||||
|
||||
eq_symmetry @ known(X=:=Y) ==> known(Y=:=X).
|
||||
neq_symmetry @ known(X=\=Y) ==> known(Y=\=X).
|
||||
|
||||
%--------------------------------------
|
||||
% Rules for number/1, float/1, integer/1
|
||||
%--------------------------------------
|
||||
|
||||
notnumber @ known(number(X)) <=> nonvar(X), \+ number(X) | known(fail).
|
||||
notfloat @ known(float(X)) <=> nonvar(X), \+ float(X)| known(fail).
|
||||
notinteger @ known(integer(X)) <=> nonvar(X), \+ integer(X) | known(fail).
|
||||
int2number @ known(integer(X)) ==> known(number(X)).
|
||||
float2number @ known(float(X)) ==> known(number(X)).
|
||||
|
||||
|
||||
%--------------------------------------
|
||||
% Rules for \+
|
||||
%--------------------------------------
|
||||
|
||||
inconsistency2 @ known(X), known(\+ X) <=> known(fail).
|
||||
|
||||
|
||||
%--------------------------------------
|
||||
% Rules for == and \==
|
||||
%--------------------------------------
|
||||
|
||||
inconsistency3 @ known(X\==Y), known(X==Y) <=> known(fail).
|
||||
eq_transitivity2 @ known(X==Y), known(Y==Z) ==> known(X==Z).
|
||||
neq_substitution @ known(X==Y), known(Y\==Z) ==> known(X\==Z).
|
||||
eq_symmetry2 @ known(X==Y) ==> known(Y==X).
|
||||
neq_symmetry2 @ known(X\==Y) ==> known(Y\==X).
|
||||
neq_inconsistency @ known(X\==X) ==> known(fail).
|
||||
functorsmatch@ known(X\==Y) <=> nonvar(X), nonvar(Y), functor(X,F,A) |
|
||||
(functor(Y,F,A) ->
|
||||
X =.. [F|XArgs],
|
||||
Y =.. [F|YArgs],
|
||||
add_args_nmatch(XArgs,YArgs,ArgCond),
|
||||
known(ArgCond)
|
||||
;
|
||||
true
|
||||
).
|
||||
eq_implies_unif @ known(X==Y) ==> known(X=Y).
|
||||
|
||||
|
||||
%--------------------------------------
|
||||
% Rules for var/1 and nonvar/1
|
||||
%--------------------------------------
|
||||
|
||||
ground2nonvar @ known(ground(X)) ==> known(nonvar(X)).
|
||||
compound2nonvar @ known(compound(X)) ==> known(nonvar(X)).
|
||||
atomic2nonvar @ known(atomic(X)) ==> known(nonvar(X)).
|
||||
number2nonvar @ known(number(X)) ==> known(nonvar(X)).
|
||||
atom2nonvar @ known(atom(X)) ==> known(nonvar(X)).
|
||||
|
||||
var_inconsistency @ known(var(X)), known(nonvar(X)) <=> known(fail).
|
||||
|
||||
|
||||
%--------------------------------------
|
||||
% Rules for disjunctions
|
||||
%--------------------------------------
|
||||
|
||||
%ad-hoc disjunction optimization:
|
||||
simplify_disj1 @ known(A) \ known((\+ A; B)) <=> known(B).
|
||||
simplify_disj1b @ known(A) \ known((\+ A, C; B)) <=> known(B).
|
||||
simplify_disj1c @ known(\+ A) \ known((A; B)) <=> known(B).
|
||||
simplify_disj1d @ known(\+ A) \ known((A, C; B)) <=> known(B).
|
||||
|
||||
simplify_disj2 @ known((fail; B)) <=> known(B).
|
||||
simplify_disj3 @ known((B ; fail)) <=> known(B).
|
||||
|
||||
simplify_disj4 @ known(functor(X,F1,A1)) \ known((\+ functor(X,F,A); B)) <=>
|
||||
% F1 \== F or A1 \== A
|
||||
true. % the disjunction does not provide any additional information
|
||||
|
||||
simplify_disj5 @ known((\+ functor(X,F,A); B)) <=>
|
||||
nonvar(X), functor(X,F,A) |
|
||||
known(B).
|
||||
simplify_disj6 @ known((\+ functor(X,F,A); B)) <=>
|
||||
nonvar(X), \+ functor(X,F,A) |
|
||||
true. % the disjunction does not provide any additional information
|
||||
|
||||
test_simplify_disj1 @test((fail;B)) <=> test(B).
|
||||
test_simplify_disj2 @test((B;fail)) <=> test(B).
|
||||
|
||||
|
||||
%--------------------------------------
|
||||
% Rules to test unifications
|
||||
%--------------------------------------
|
||||
|
||||
trivial_unif @ test(X=Y) <=> X=Y | X=Y.
|
||||
testgroundunif @ test(X=A) <=> ground(X),ground(A) | X=A.
|
||||
varfirst @ test(X=A) <=> nonvar(X),var(A) | test(A=X).
|
||||
distribute_unif @ variables(V) \ test(X=A) <=> var(X),nonvar(A),
|
||||
functor(A,F,Arit),Arit>0,
|
||||
A =.. [F|AArgs],\+ all_unique_vars(AArgs,V) |
|
||||
C=(functor(X,F,Arit),X=A),
|
||||
test(C).
|
||||
distribute_unif2 @ test(X=A) <=> var(X),nonvar(A),
|
||||
functor(A,F,Arit),%Arit>0,
|
||||
A =.. [F|AArgs] % , all_unique_vars(AArgs)
|
||||
|
|
||||
C=functor(X,F,Arit),
|
||||
test(C).
|
||||
distribute_unif3 @ test(X=A) <=> nonvar(X),nonvar(A),functor(A,F,Arit),
|
||||
A =.. [F|AArgs] |
|
||||
functor(X,F,Arit),
|
||||
X =.. [F|XArgs],
|
||||
add_args_unif(XArgs,AArgs,ArgCond),
|
||||
test(ArgCond).
|
||||
|
||||
testvarunif @ variables(V) \ test(X=A) <=> \+ (memberchk_eq(A,V),memberchk_eq(X,V)) | X=A.
|
||||
testvarunif @ variables(V) \ test(functor(X,F,A)) <=>
|
||||
var(X),ground(F),ground(A),\+ memberchk_eq(X,V) |
|
||||
functor(X,F,A). % X is a singleton variable
|
||||
|
||||
% trivial truths
|
||||
true_is_true @ test(true) <=> true.
|
||||
trivial01 @ test(X==Y) <=> X==Y | true.
|
||||
trivial02 @ test(X=:=Y) <=> X==Y | true.
|
||||
trivial03 @ test(X=<Y) <=> X==Y | true.
|
||||
trivial04 @ test(X=<Y) <=> ground(X), ground(Y), X=<Y | true.
|
||||
trivial05 @ test(X=<Y) <=> ground(X), ground(Y), X>Y | fail.
|
||||
trivial06 @ test(X=:=Y) <=> ground(X), ground(Y), X=:=Y | true.
|
||||
trivial07 @ test(X=:=Y) <=> ground(X), ground(Y), X=\=Y | fail.
|
||||
trivial08 @ test(X=\=Y) <=> ground(X), ground(Y), X=\=Y | true.
|
||||
trivial09 @ test(X=\=Y) <=> ground(X), ground(Y), X=:=Y | fail.
|
||||
trivial10 @ test(functor(X,F1,A1)) <=> nonvar(X), functor(X,F1,A1) | true.
|
||||
trivial11 @ test(functor(X,F1,A1)) <=> nonvar(X) | fail.
|
||||
trivial12 @ test(ground(X)) <=> ground(X) | true.
|
||||
trivial13 @ test(number(X)) <=> number(X) | true.
|
||||
trivial14 @ test(float(X)) <=> float(X) | true.
|
||||
trivial15 @ test(integer(X)) <=> integer(X) | true.
|
||||
trivial16 @ test(number(X)) <=> nonvar(X) | fail.
|
||||
trivial17 @ test(float(X)) <=> nonvar(X) | fail.
|
||||
trivial18 @ test(integer(X)) <=> nonvar(X) | fail.
|
||||
trivial19 @ test(\+ functor(X,F1,A1)) <=> nonvar(X), functor(X,F1,A1) | fail.
|
||||
trivial20 @ test(\+ functor(X,F1,A1)) <=> nonvar(X) | true.
|
||||
trivial21 @ test(\+ ground(X)) <=> ground(X) | fail.
|
||||
trivial22 @ test(\+ number(X)) <=> number(X) | fail.
|
||||
trivial23 @ test(\+ float(X)) <=> float(X) | fail.
|
||||
trivial24 @ test(\+ integer(X)) <=> integer(X) | fail.
|
||||
trivial25 @ test(\+ number(X)) <=> nonvar(X) | true.
|
||||
trivial26 @ test(\+ float(X)) <=> nonvar(X) | true.
|
||||
trivial27 @ test(\+ integer(X)) <=> nonvar(X) | true.
|
||||
|
||||
test_conjunction @ test((A,B)) <=> test(A), known(A), test(B).
|
||||
test_disjunction @ test((A;B)) <=> true | negate_b(A,NotA),negate_b(B,NotB),
|
||||
(known(NotB),test(A) ; known(NotA),test(B)).
|
||||
|
||||
% disjunctions in the known stuff --> both options should entail the goals
|
||||
% delay disjunction unfolding until everything is added, perhaps we can
|
||||
% find entailed things without using the disjunctions
|
||||
disjunction @ test(X), known((A;B)) <=>
|
||||
true |
|
||||
\+ try(A,X),!,
|
||||
negate_b(A,NotA),
|
||||
known(NotA),
|
||||
\+ try(B,X).
|
||||
|
||||
|
||||
% not entailed or entailment not detected
|
||||
could_not_prove_entailment @ test(_) <=> fail.
|
||||
|
||||
|
||||
clean_store1 @ cleanup \ known(_) <=> true.
|
||||
clean_store2 @ cleanup \ variables(_) <=> true.
|
||||
clean_store3 @ cleanup <=> true.
|
||||
|
||||
|
||||
%--------------------------------------
|
||||
% End of CHR part
|
||||
%--------------------------------------
|
||||
|
||||
|
||||
entails_guard(List,Guard) :-
|
||||
copy_term_nat((List,Guard),(CopyList,CopyGuard)),
|
||||
term_variables(CopyList,CLVars),
|
||||
variables(CLVars),
|
||||
entails_guard2(CopyList),
|
||||
!,test(CopyGuard),!,
|
||||
cleanup.
|
||||
|
||||
entails_guard2([]).
|
||||
entails_guard2([A|R]) :-
|
||||
known(A), entails_guard2(R).
|
||||
|
||||
simplify_guards(List,Body,GuardList,SimplifiedGuards,NewBody) :-
|
||||
% write(starting),nl,
|
||||
copy_term_nat((List,GuardList),(CopyList,CopyGuard)),
|
||||
term_variables(CopyList,CLVars),
|
||||
% write(variables(CLVars)),nl,
|
||||
variables(CLVars),
|
||||
% write(gonna_add(CopyList)),nl,
|
||||
entails_guard2(CopyList),
|
||||
% write(ok_gonna_add),nl,
|
||||
!,
|
||||
% write(gonna_simplify(CopyGuard)),nl,
|
||||
simplify(CopyGuard,L),
|
||||
% write(ok_gonna_simplify(CopyGuard,L)),nl,
|
||||
simplified(GuardList,L,SimplifiedGuards,Body,NewBody),
|
||||
% write(ok_done),nl,
|
||||
!,
|
||||
cleanup.
|
||||
|
||||
simplified([],[],[],B,B).
|
||||
simplified([G|RG],[keep|RL],[G|RSG],B,NB) :- simplified(RG,RL,RSG,B,NB).
|
||||
simplified([G|RG],[fail|RL],fail,B,B).
|
||||
simplified([G|RG],[true|RL],[X|RSG],B,NB) :-
|
||||
builtins:binds_b(G,GVars), term_variables(RG,RGVars),
|
||||
intersect_eq(GVars,RGVars,SharedWithRestOfGuard),!,
|
||||
( SharedWithRestOfGuard = [] ->
|
||||
term_variables(B,BVars),
|
||||
intersect_eq(GVars,BVars,SharedWithBody),!,
|
||||
( SharedWithBody = [] ->
|
||||
X=true, % e.g. c(X) <=> Y=X | true.
|
||||
NB=NB2
|
||||
;
|
||||
X=true, % e.g. c(X) <=> Y=X | writeln(Y).
|
||||
NB=(G,NB2)
|
||||
)
|
||||
;
|
||||
X=G, % e.g. c(X) <=> Y=X,p(Y) | true.
|
||||
NB=NB2
|
||||
),
|
||||
simplified(RG,RL,RSG,B,NB2).
|
||||
|
||||
simplify([],[]).
|
||||
simplify([G|R],[SG|RS]) :-
|
||||
( \+ try(true,G) ->
|
||||
SG = true
|
||||
;
|
||||
builtins:negate_b(G,NotG),
|
||||
(\+ try(true,NotG) ->
|
||||
SG = fail
|
||||
;
|
||||
SG = keep
|
||||
)
|
||||
),
|
||||
known(G),
|
||||
simplify(R,RS).
|
||||
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%% AUXILIARY PREDICATES
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
try(A,X) :- (known(A) ->
|
||||
true
|
||||
;
|
||||
format(' ERROR: entailment checker: this is not supposed to happen.\n',[])
|
||||
),
|
||||
(test(X) ->
|
||||
fail
|
||||
;
|
||||
true).
|
||||
|
||||
|
||||
lookup([],[],_,_) :- fail.
|
||||
lookup([K|R],[V|R2],X,Y) :-
|
||||
(X == K ->
|
||||
Y=V
|
||||
;
|
||||
lookup(R,R2,X,Y)
|
||||
).
|
||||
|
||||
|
||||
add_args_unif([],[],true).
|
||||
add_args_unif([X|RX],[Y|RY],(X=Y,RC)) :-
|
||||
add_args_unif(RX,RY,RC).
|
||||
|
||||
add_args_nunif([],[],fail).
|
||||
add_args_nunif([X|RX],[Y|RY],(X\=Y;RC)) :-
|
||||
add_args_nunif(RX,RY,RC).
|
||||
|
||||
add_args_nmatch([],[],fail).
|
||||
add_args_nmatch([X|RX],[Y|RY],(X\==Y;RC)) :-
|
||||
add_args_nmatch(RX,RY,RC).
|
||||
|
||||
all_unique_vars(T,V) :- all_unique_vars(T,V,[]).
|
||||
|
||||
all_unique_vars([],V,C).
|
||||
all_unique_vars([V|R],Vars,C) :-
|
||||
var(V),
|
||||
\+ memberchk_eq(V,Vars),
|
||||
\+ memberchk_eq(V,C),
|
||||
all_unique_vars(R,[V|C]).
|
||||
3530
LGPL/chr/guard_entailment.pl
Normal file
3530
LGPL/chr/guard_entailment.pl
Normal file
File diff suppressed because it is too large
Load Diff
194
LGPL/chr/hprolog.pl
Normal file
194
LGPL/chr/hprolog.pl
Normal file
@ -0,0 +1,194 @@
|
||||
:- module(hprolog,
|
||||
[ prolog_flag/3, % +Flag, -Old, +New
|
||||
append_lists/2, % +ListOfLists, -List
|
||||
nth/3, % ?Index, ?List, ?Element
|
||||
substitute/4, % +OldVal, +OldList, +NewVal, -NewList
|
||||
memberchk_eq/2, % +Val, +List
|
||||
intersect_eq/3, % +List1, +List2, -Intersection
|
||||
list_difference_eq/3, % +List, -Subtract, -Rest
|
||||
take/3, % +N, +List, -FirstElements
|
||||
max_go_list/2, % +List, -Max
|
||||
or_list/2, % +ListOfInts, -BitwiseOr
|
||||
sublist/2,
|
||||
min_list/2,
|
||||
chr_delete/3,
|
||||
strip_attributes/2,
|
||||
restore_attributes/2
|
||||
]).
|
||||
:- use_module(library(lists)).
|
||||
|
||||
% prolog_flag(+Flag, -Old, +New)
|
||||
%
|
||||
% Combine ISO prolog flag reading and writing
|
||||
|
||||
prolog_flag(Flag, Old, New) :-
|
||||
current_prolog_flag(Flag, Old),
|
||||
( Old == New
|
||||
-> true
|
||||
; set_prolog_flag(Flag, New)
|
||||
).
|
||||
|
||||
/*******************************
|
||||
* MORE LIST OPERATIONS *
|
||||
*******************************/
|
||||
|
||||
% append_lists(+ListOfLists, -List)
|
||||
%
|
||||
% Convert a one-level nested list into a flat one. E.g.
|
||||
% append_lists([[a,b], [c]], X) --> X = [a,b,c]. See also
|
||||
% flatten/3.
|
||||
|
||||
append_lists([],[]).
|
||||
append_lists([X|Xs],L) :-
|
||||
append(X,T,L),
|
||||
append_lists(Xs,T).
|
||||
|
||||
|
||||
% nth(?Index, ?List, ?Element)
|
||||
%
|
||||
% Same as nth1/3
|
||||
|
||||
nth(Index, List, Element) :-
|
||||
nth1(Index, List, Element).
|
||||
|
||||
|
||||
% substitute(+OldVal, +OldList, +NewVal, -NewList)
|
||||
%
|
||||
% Substitute OldVal by NewVal in OldList and unify the result
|
||||
% with NewList. JW: Shouldn't this be called substitute_eq/4?
|
||||
|
||||
substitute(_, [], _, []) :- ! .
|
||||
substitute(X, [U|Us], Y, [V|Vs]) :-
|
||||
( X == U
|
||||
-> V = Y,
|
||||
substitute(X, Us, Y, Vs)
|
||||
; V = U,
|
||||
substitute(X, Us, Y, Vs)
|
||||
).
|
||||
|
||||
% memberchk_eq(+Val, +List)
|
||||
%
|
||||
% Deterministic check of membership using == rather than
|
||||
% unification.
|
||||
|
||||
memberchk_eq(X, [Y|Ys]) :-
|
||||
( X == Y
|
||||
-> true
|
||||
; memberchk_eq(X, Ys)
|
||||
).
|
||||
|
||||
|
||||
% list_difference_eq(+List, -Subtract, -Rest)
|
||||
%
|
||||
% Delete all elements of Subtract from List and unify the result
|
||||
% with Rest. Element comparision is done using ==/2.
|
||||
|
||||
list_difference_eq([],_,[]).
|
||||
list_difference_eq([X|Xs],Ys,L) :-
|
||||
( memberchk_eq(X,Ys)
|
||||
-> list_difference_eq(Xs,Ys,L)
|
||||
; L = [X|T],
|
||||
list_difference_eq(Xs,Ys,T)
|
||||
).
|
||||
|
||||
% intersect_eq(+List1, +List2, -Intersection)
|
||||
%
|
||||
% Determine the intersection of two lists without unifying values.
|
||||
|
||||
intersect_eq([], _, []).
|
||||
intersect_eq([X|Xs], Ys, L) :-
|
||||
( memberchk_eq(X, Ys)
|
||||
-> L = [X|T],
|
||||
intersect_eq(Xs, Ys, T)
|
||||
; intersect_eq(Xs, Ys, L)
|
||||
).
|
||||
|
||||
|
||||
% take(+N, +List, -FirstElements)
|
||||
%
|
||||
% Take the first N elements from List and unify this with
|
||||
% FirstElements. The definition is based on the GNU-Prolog lists
|
||||
% library. Implementation by Jan Wielemaker.
|
||||
|
||||
take(0, _, []) :- !.
|
||||
take(N, [H|TA], [H|TB]) :-
|
||||
N > 0,
|
||||
N2 is N - 1,
|
||||
take(N2, TA, TB).
|
||||
|
||||
|
||||
% max_go_list(+List, -Max)
|
||||
%
|
||||
% Return the maximum of List in the standard order of terms.
|
||||
|
||||
max_go_list([H|T], Max) :-
|
||||
max_go_list(T, H, Max).
|
||||
|
||||
max_go_list([], Max, Max).
|
||||
max_go_list([H|T], X, Max) :-
|
||||
( H @=< X
|
||||
-> max_go_list(T, X, Max)
|
||||
; max_go_list(T, H, Max)
|
||||
).
|
||||
|
||||
% or_list(+ListOfInts, -BitwiseOr)
|
||||
%
|
||||
% Do a bitwise disjuction over all integer members of ListOfInts.
|
||||
|
||||
or_list(L, Or) :-
|
||||
or_list(L, 0, Or).
|
||||
|
||||
or_list([], Or, Or).
|
||||
or_list([H|T], Or0, Or) :-
|
||||
Or1 is H \/ Or0,
|
||||
or_list(T, Or1, Or).
|
||||
|
||||
|
||||
sublist(L, L).
|
||||
sublist(Sub, [H|T]) :-
|
||||
'$sublist1'(T, H, Sub).
|
||||
|
||||
'$sublist1'(Sub, _, Sub).
|
||||
'$sublist1'([H|T], _, Sub) :-
|
||||
'$sublist1'(T, H, Sub).
|
||||
'$sublist1'([H|T], X, [X|Sub]) :-
|
||||
'$sublist1'(T, H, Sub).
|
||||
|
||||
min_list([H|T], Min) :-
|
||||
'$min_list1'(T, H, Min).
|
||||
|
||||
'$min_list1'([], Min, Min).
|
||||
'$min_list1'([H|T], X, Min) :-
|
||||
( H>=X ->
|
||||
'$min_list1'(T, X, Min)
|
||||
; '$min_list1'(T, H, Min)
|
||||
).
|
||||
|
||||
chr_delete([], _, []).
|
||||
chr_delete([H|T], X, L) :-
|
||||
( H==X ->
|
||||
chr_delete(T, X, L)
|
||||
; L=[H|RT],
|
||||
chr_delete(T, X, RT)
|
||||
).
|
||||
|
||||
strip_attributes([],[]).
|
||||
strip_attributes([V|R],[V2|R2]) :-
|
||||
( attvar(V) ->
|
||||
get_attrs(V,VAttrs),
|
||||
remove_attrs(V,VAttrs,V2)
|
||||
; V2 = []
|
||||
),
|
||||
strip_attributes(R,R2).
|
||||
|
||||
remove_attrs(_V,[],[]).
|
||||
remove_attrs(V,att(X,Y,OtherAttrs),[(X,Y)|R]) :-
|
||||
del_attr(V,X),
|
||||
remove_attrs(V,OtherAttrs,R).
|
||||
|
||||
restore_attributes([],[]).
|
||||
restore_attributes([_V|R],[[]|R2]) :-
|
||||
restore_attributes(R,R2).
|
||||
restore_attributes([V|R],[[(X,Y)|RVAttr]|R2]) :-
|
||||
put_attr(V,X,Y),
|
||||
restore_attributes([V|R],[RVAttr|R2]).
|
||||
196
LGPL/chr/hprolog.yap
Normal file
196
LGPL/chr/hprolog.yap
Normal file
@ -0,0 +1,196 @@
|
||||
:- module(hprolog,
|
||||
[ %prolog_flag/3, % +Flag, -Old, +New
|
||||
append_lists/2, % +ListOfLists, -List
|
||||
%nth/3, % ?Index, ?List, ?Element
|
||||
%substitute/4, % +OldVal, +OldList, +NewVal, -NewList
|
||||
memberchk_eq/2, % +Val, +List
|
||||
intersect_eq/3, % +List1, +List2, -Intersection
|
||||
list_difference_eq/3, % +List, -Subtract, -Rest
|
||||
take/3, % +N, +List, -FirstElements
|
||||
max_go_list/2, % +List, -Max
|
||||
or_list/2, % +ListOfInts, -BitwiseOr
|
||||
%sublist/2,
|
||||
%min_list/2,
|
||||
chr_delete/3,
|
||||
strip_attributes/2,
|
||||
restore_attributes/2
|
||||
]).
|
||||
:- use_module(library(lists)).
|
||||
|
||||
% prolog_flag(+Flag, -Old, +New)
|
||||
%
|
||||
% Combine ISO prolog flag reading and writing
|
||||
|
||||
/*
|
||||
prolog_flag(Flag, Old, New) :-
|
||||
current_prolog_flag(Flag, Old),
|
||||
( Old == New
|
||||
-> true
|
||||
; set_prolog_flag(Flag, New)
|
||||
).
|
||||
|
||||
*/
|
||||
/*******************************
|
||||
* MORE LIST OPERATIONS *
|
||||
*******************************/
|
||||
|
||||
% append_lists(+ListOfLists, -List)
|
||||
%
|
||||
% Convert a one-level nested list into a flat one. E.g.
|
||||
% append_lists([[a,b], [c]], X) --> X = [a,b,c]. See also
|
||||
% flatten/3.
|
||||
|
||||
append_lists([],[]).
|
||||
append_lists([X|Xs],L) :-
|
||||
append(X,T,L),
|
||||
append_lists(Xs,T).
|
||||
|
||||
|
||||
% nth(?Index, ?List, ?Element)
|
||||
%
|
||||
% Same as nth1/3
|
||||
|
||||
nth(Index, List, Element) :-
|
||||
nth1(Index, List, Element).
|
||||
|
||||
|
||||
% substitute(+OldVal, +OldList, +NewVal, -NewList)
|
||||
%
|
||||
% Substitute OldVal by NewVal in OldList and unify the result
|
||||
% with NewList. JW: Shouldn't this be called substitute_eq/4?
|
||||
|
||||
substitute(_, [], _, []) :- ! .
|
||||
substitute(X, [U|Us], Y, [V|Vs]) :-
|
||||
( X == U
|
||||
-> V = Y,
|
||||
substitute(X, Us, Y, Vs)
|
||||
; V = U,
|
||||
substitute(X, Us, Y, Vs)
|
||||
).
|
||||
|
||||
% memberchk_eq(+Val, +List)
|
||||
%
|
||||
% Deterministic check of membership using == rather than
|
||||
% unification.
|
||||
|
||||
memberchk_eq(X, [Y|Ys]) :-
|
||||
( X == Y
|
||||
-> true
|
||||
; memberchk_eq(X, Ys)
|
||||
).
|
||||
|
||||
|
||||
% list_difference_eq(+List, -Subtract, -Rest)
|
||||
%
|
||||
% Delete all elements of Subtract from List and unify the result
|
||||
% with Rest. Element comparision is done using ==/2.
|
||||
|
||||
list_difference_eq([],_,[]).
|
||||
list_difference_eq([X|Xs],Ys,L) :-
|
||||
( memberchk_eq(X,Ys)
|
||||
-> list_difference_eq(Xs,Ys,L)
|
||||
; L = [X|T],
|
||||
list_difference_eq(Xs,Ys,T)
|
||||
).
|
||||
|
||||
% intersect_eq(+List1, +List2, -Intersection)
|
||||
%
|
||||
% Determine the intersection of two lists without unifying values.
|
||||
|
||||
intersect_eq([], _, []).
|
||||
intersect_eq([X|Xs], Ys, L) :-
|
||||
( memberchk_eq(X, Ys)
|
||||
-> L = [X|T],
|
||||
intersect_eq(Xs, Ys, T)
|
||||
; intersect_eq(Xs, Ys, L)
|
||||
).
|
||||
|
||||
|
||||
% take(+N, +List, -FirstElements)
|
||||
%
|
||||
% Take the first N elements from List and unify this with
|
||||
% FirstElements. The definition is based on the GNU-Prolog lists
|
||||
% library. Implementation by Jan Wielemaker.
|
||||
|
||||
take(0, _, []) :- !.
|
||||
take(N, [H|TA], [H|TB]) :-
|
||||
N > 0,
|
||||
N2 is N - 1,
|
||||
take(N2, TA, TB).
|
||||
|
||||
|
||||
% max_go_list(+List, -Max)
|
||||
%
|
||||
% Return the maximum of List in the standard order of terms.
|
||||
|
||||
max_go_list([H|T], Max) :-
|
||||
max_go_list(T, H, Max).
|
||||
|
||||
max_go_list([], Max, Max).
|
||||
max_go_list([H|T], X, Max) :-
|
||||
( H @=< X
|
||||
-> max_go_list(T, X, Max)
|
||||
; max_go_list(T, H, Max)
|
||||
).
|
||||
|
||||
% or_list(+ListOfInts, -BitwiseOr)
|
||||
%
|
||||
% Do a bitwise disjuction over all integer members of ListOfInts.
|
||||
|
||||
or_list(L, Or) :-
|
||||
or_list(L, 0, Or).
|
||||
|
||||
or_list([], Or, Or).
|
||||
or_list([H|T], Or0, Or) :-
|
||||
Or1 is H \/ Or0,
|
||||
or_list(T, Or1, Or).
|
||||
|
||||
|
||||
sublist(L, L).
|
||||
sublist(Sub, [H|T]) :-
|
||||
'$sublist1'(T, H, Sub).
|
||||
|
||||
'$sublist1'(Sub, _, Sub).
|
||||
'$sublist1'([H|T], _, Sub) :-
|
||||
'$sublist1'(T, H, Sub).
|
||||
'$sublist1'([H|T], X, [X|Sub]) :-
|
||||
'$sublist1'(T, H, Sub).
|
||||
|
||||
min_list([H|T], Min) :-
|
||||
'$min_list1'(T, H, Min).
|
||||
|
||||
'$min_list1'([], Min, Min).
|
||||
'$min_list1'([H|T], X, Min) :-
|
||||
( H>=X ->
|
||||
'$min_list1'(T, X, Min)
|
||||
; '$min_list1'(T, H, Min)
|
||||
).
|
||||
|
||||
chr_delete([], _, []).
|
||||
chr_delete([H|T], X, L) :-
|
||||
( H==X ->
|
||||
chr_delete(T, X, L)
|
||||
; L=[H|RT],
|
||||
chr_delete(T, X, RT)
|
||||
).
|
||||
|
||||
strip_attributes([],[]).
|
||||
strip_attributes([V|R],[V2|R2]) :-
|
||||
( attvar(V) ->
|
||||
get_attrs(V,VAttrs),
|
||||
remove_attrs(V,VAttrs,V2)
|
||||
; V2 = []
|
||||
),
|
||||
strip_attributes(R,R2).
|
||||
|
||||
remove_attrs(_V,[],[]).
|
||||
remove_attrs(V,att(X,Y,OtherAttrs),[(X,Y)|R]) :-
|
||||
del_attr(V,X),
|
||||
remove_attrs(V,OtherAttrs,R).
|
||||
|
||||
restore_attributes([],[]).
|
||||
restore_attributes([_V|R],[[]|R2]) :-
|
||||
restore_attributes(R,R2).
|
||||
restore_attributes([V|R],[[(X,Y)|RVAttr]|R2]) :-
|
||||
put_attr(V,X,Y),
|
||||
restore_attributes([V|R],[RVAttr|R2]).
|
||||
105
LGPL/chr/listmap.pl
Normal file
105
LGPL/chr/listmap.pl
Normal file
@ -0,0 +1,105 @@
|
||||
/* $Id: listmap.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, K.U. Leuven
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(listmap,
|
||||
[
|
||||
listmap_empty/1,
|
||||
listmap_lookup/3,
|
||||
listmap_insert/4,
|
||||
listmap_remove/3,
|
||||
listmap_merge/5
|
||||
]).
|
||||
|
||||
listmap_empty([]).
|
||||
|
||||
listmap_lookup([K-V|R],Key,Q) :-
|
||||
( Key == K ->
|
||||
Q = V
|
||||
;
|
||||
Key @> K,
|
||||
listmap_lookup(R,Key,Q)
|
||||
).
|
||||
|
||||
listmap_insert([],Key,Value,[Key-Value]).
|
||||
listmap_insert([P|R],Key,Value,ML) :-
|
||||
P = K-_,
|
||||
compare(C,Key,K),
|
||||
( C == (=) ->
|
||||
ML = [K-Value|R]
|
||||
; C == (<) ->
|
||||
ML = [Key-Value,P|R]
|
||||
;
|
||||
ML = [P|Tail],
|
||||
listmap_insert(R,Key,Value,Tail)
|
||||
).
|
||||
|
||||
listmap_merge(ML1,ML2,F,G,ML) :-
|
||||
( ML1 == [] ->
|
||||
ML = ML2
|
||||
; ML2 == [] ->
|
||||
ML = ML1
|
||||
;
|
||||
ML1 = [P1|R1], P1 = K1-V1,
|
||||
ML2 = [P2|R2], P2 = K2-V2,
|
||||
compare(C,K1,K2),
|
||||
( C == (=) ->
|
||||
Call =.. [F,V1,V2,NV],
|
||||
call(Call),
|
||||
ML = [K1-NV|Tail],
|
||||
listmap_merge(R1,R2,F,G,Tail)
|
||||
; C == (<) ->
|
||||
Call =.. [G,V1,NV],
|
||||
call(Call),
|
||||
ML = [K1-NV|Tail],
|
||||
listmap_merge(R1,ML2,F,G,Tail)
|
||||
;
|
||||
Call =.. [G,V2,NV],
|
||||
call(Call),
|
||||
ML = [K2-NV|Tail],
|
||||
listmap_merge(ML1,R2,F,G,Tail)
|
||||
)
|
||||
).
|
||||
|
||||
|
||||
listmap_remove([],_,[]).
|
||||
listmap_remove([P|R],Key,NLM) :-
|
||||
P = K-_,
|
||||
compare(C,Key,K),
|
||||
( C == (=) ->
|
||||
NLM = R
|
||||
; C == (<) ->
|
||||
NLM = [P|R]
|
||||
;
|
||||
NLM = [P|Tail],
|
||||
listmap_remove(R,Key,Tail)
|
||||
).
|
||||
|
||||
|
||||
106
LGPL/chr/pairlist.pl
Normal file
106
LGPL/chr/pairlist.pl
Normal file
@ -0,0 +1,106 @@
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%% _ _ _ _
|
||||
%% _ __ __ _(_)_ __| (_)___| |_
|
||||
%% | '_ \ / _` | | '__| | / __| __|
|
||||
%% | |_) | (_| | | | | | \__ \ |_
|
||||
%% | .__/ \__,_|_|_| |_|_|___/\__|
|
||||
%% |_|
|
||||
%%
|
||||
%% * author: Tom Schrijvers
|
||||
|
||||
:- module(pairlist,[
|
||||
fst_of_pairs/2,
|
||||
lookup/3,
|
||||
lookup_any/3,
|
||||
lookup_eq/3,
|
||||
lookup_any_eq/3,
|
||||
pairup/3,
|
||||
snd_of_pairs/2,
|
||||
translate/3,
|
||||
pairlist_delete_eq/3
|
||||
]).
|
||||
|
||||
fst_of_pairs([],[]).
|
||||
fst_of_pairs([X-_|XYs],[X|Xs]) :-
|
||||
fst_of_pairs(XYs,Xs).
|
||||
|
||||
snd_of_pairs([],[]).
|
||||
snd_of_pairs([_-Y|XYs],[Y|Ys]) :-
|
||||
snd_of_pairs(XYs,Ys).
|
||||
|
||||
pairup([],[],[]).
|
||||
pairup([X|Xs],[Y|Ys],[X-Y|XYs]) :-
|
||||
pairup(Xs,Ys,XYs).
|
||||
|
||||
lookup([K - V | KVs],Key,Value) :-
|
||||
( K = Key ->
|
||||
V = Value
|
||||
;
|
||||
lookup(KVs,Key,Value)
|
||||
).
|
||||
|
||||
lookup_any([K - V | KVs],Key,Value) :-
|
||||
(
|
||||
K = Key,
|
||||
V = Value
|
||||
;
|
||||
lookup_any(KVs,Key,Value)
|
||||
).
|
||||
|
||||
lookup_eq([K - V | KVs],Key,Value) :-
|
||||
( K == Key ->
|
||||
V = Value
|
||||
;
|
||||
lookup_eq(KVs,Key,Value)
|
||||
).
|
||||
|
||||
lookup_any_eq([K - V | KVs],Key,Value) :-
|
||||
(
|
||||
K == Key,
|
||||
V = Value
|
||||
;
|
||||
lookup_any_eq(KVs,Key,Value)
|
||||
).
|
||||
|
||||
translate([],_,[]).
|
||||
translate([X|Xs],Dict,[Y|Ys]) :-
|
||||
lookup_eq(Dict,X,Y),
|
||||
translate(Xs,Dict,Ys).
|
||||
|
||||
pairlist_delete([], _, []).
|
||||
pairlist_delete([K - V| KVs], Key, PL) :-
|
||||
( Key = K ->
|
||||
PL = KVs
|
||||
;
|
||||
PL = [ K - V | T ],
|
||||
pairlist_delete(KVs, Key, T)
|
||||
).
|
||||
|
||||
pairlist_delete_all([], _, []).
|
||||
pairlist_delete_all([K - V| KVs], Key, PL) :-
|
||||
( Key = K ->
|
||||
pairlist_delete_all(KVs, Key, PL)
|
||||
|
||||
;
|
||||
PL = [ K - V | T ],
|
||||
pairlist_delete_all(KVs, Key, T)
|
||||
).
|
||||
|
||||
pairlist_delete_eq([], _, []).
|
||||
pairlist_delete_eq([K - V| KVs], Key, PL) :-
|
||||
( Key == K ->
|
||||
PL = KVs
|
||||
;
|
||||
PL = [ K - V | T ],
|
||||
pairlist_delete_eq(KVs, Key, T)
|
||||
).
|
||||
|
||||
pairlist_delete_all_eq([], _, []).
|
||||
pairlist_delete_all_eq([K - V| KVs], Key, PL) :-
|
||||
( Key == K ->
|
||||
pairlist_delete_all_eq(KVs, Key, PL)
|
||||
;
|
||||
PL = [ K - V | T ],
|
||||
pairlist_delete_all_eq(KVs, Key, T)
|
||||
).
|
||||
|
||||
Reference in New Issue
Block a user