├── Examples ├── chrfreeze.chr ├── fib.chr ├── gcd.chr ├── fibonacci.chr ├── leq.chr ├── primes.chr ├── family.chr ├── chrdif.chr ├── listdom.chr ├── deadcode.pl └── bool.chr ├── .gitignore ├── Tests ├── passive_check.chr ├── passive_check2.chr ├── trigger_no_active_occurrence.chr ├── dense_int.chr ├── leq.chr ├── primes.chr ├── fibonacci.chr └── zebra.chr ├── Benchmarks ├── benches.pl ├── primes.chr ├── fib.chr ├── leq.chr ├── fibonacci.chr ├── fulladder.chr ├── zebra.chr ├── wfs.chr ├── bool.chr └── ta.chr ├── README ├── .fileheader ├── pairlist.pl ├── chr_op.pl ├── chr_op2.pl ├── chr_debug.pl ├── chr_support.c ├── find.pl ├── a_star.pl ├── listmap.pl ├── CMakeLists.txt ├── binomialheap.pl ├── chr_integertable_store.pl ├── chr_messages.pl ├── test_chr.pl ├── chr_compiler_errors.pl ├── chr_swi_bootstrap.pl ├── clean_code.pl ├── chr_compiler_utility.pl ├── chr_hashtable_store.pl ├── chr_compiler_options.pl └── chr_swi.pl /Examples/chrfreeze.chr: -------------------------------------------------------------------------------- 1 | :- module(chrfreeze,[chrfreeze/2]). 2 | :- use_module(library(chr)). 3 | 4 | :- constraints chrfreeze/2. 5 | 6 | chrfreeze(V,G) <=> nonvar(V) | call(G). 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.o 3 | *.so 4 | *.obj 5 | *.dll 6 | Makefile 7 | chr.pl 8 | chr_translate.pl 9 | chr_translate_bootstrap1.pl 10 | chr_translate_bootstrap2.pl 11 | guard_entailment.pl 12 | config.h 13 | config.h.in 14 | config.log 15 | config.status 16 | configure 17 | autom4te.cache 18 | -------------------------------------------------------------------------------- /Tests/passive_check.chr: -------------------------------------------------------------------------------- 1 | :- module(passive_check,[passive_check/0]). 2 | :- use_module(library(chr)). 3 | 4 | :- chr_constraint a/1, b/1. 5 | 6 | :- chr_option(debug,off). 7 | :- chr_option(optimize,full). 8 | 9 | a(X) # ID, b(X) <=> true pragma passive(ID). 10 | 11 | passive_check :- 12 | a(_). 13 | -------------------------------------------------------------------------------- /Tests/passive_check2.chr: -------------------------------------------------------------------------------- 1 | :- module(passive_check2,[passive_check2/0]). 2 | :- use_module(library(chr)). 3 | 4 | :- chr_constraint a/1, b/2. 5 | 6 | :- chr_option(debug,off). 7 | :- chr_option(optimize,full). 8 | 9 | a(X) # ID, b(X,R) <=> R = 1 pragma passive(ID). 10 | 11 | passive_check2 :- 12 | a(X), b(X,R), R == 1. 13 | -------------------------------------------------------------------------------- /Tests/trigger_no_active_occurrence.chr: -------------------------------------------------------------------------------- 1 | :- module(trigger_no_active_occurrence,[trigger_no_active_occurrence/0]). 2 | 3 | :- use_module(library(chr)). 4 | 5 | :- chr_constraint a/1, b/2. 6 | 7 | a(X) # ID , b(X,R) <=> R = 1 pragma passive(ID). 8 | 9 | trigger_no_active_occurrence :- 10 | a(X), 11 | X = 1, 12 | b(1,R), 13 | R == 1. 14 | -------------------------------------------------------------------------------- /Tests/dense_int.chr: -------------------------------------------------------------------------------- 1 | :- module(dense_int,[dense_int/0]). 2 | 3 | :-use_module(library(chr)). 4 | 5 | :-chr_type 'Arity' == dense_int. 6 | 7 | :-chr_constraint c1(+'Arity'). 8 | 9 | :-chr_option(line_numbers, on). 10 | :-chr_option(check_guard_bindings, on). 11 | :-chr_option(debug, off). 12 | :-chr_option(optimize, full). 13 | 14 | dense_int :- 15 | c1(1), 16 | c1(1). 17 | 18 | 19 | no_duplicates @ 20 | c1(X) 21 | \ 22 | c1(X) 23 | <=> 24 | true. 25 | 26 | 27 | -------------------------------------------------------------------------------- /Benchmarks/benches.pl: -------------------------------------------------------------------------------- 1 | :- prolog_load_context(directory, Dir), 2 | working_directory(_, Dir). 3 | 4 | benches :- 5 | bench(B), 6 | atom_concat(B, '.chr', File), 7 | style_check(-singleton), 8 | abolish(main,0), 9 | abolish(main,1), 10 | [File], 11 | % (main;main;main;main), 12 | main, 13 | fail. 14 | benches. 15 | 16 | bench(bool). 17 | bench(fib). 18 | bench(fibonacci). 19 | bench(leq). 20 | bench(primes). 21 | bench(ta). 22 | bench(wfs). 23 | bench(zebra). 24 | 25 | cputime(Time) :- 26 | statistics(runtime, [_,Time]). 27 | -------------------------------------------------------------------------------- /Examples/fib.chr: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | %% 3 | %% 991202 Slim Abdennadher, LMU 4 | %% 5 | %% ported to hProlog by Tom Schrijvers 6 | 7 | :- module(fib,[]). 8 | 9 | :- use_module(library(chr)). 10 | 11 | :- constraints fib/2. 12 | 13 | %% fib(N,M) is true if M is the Nth Fibonacci number. 14 | 15 | %% Top-down Evaluation with Tabulation 16 | 17 | fib(N,M1), fib(N,M2) <=> M1 = M2, fib(N,M1). 18 | 19 | fib(0,M) ==> M = 1. 20 | 21 | fib(1,M) ==> M = 1. 22 | 23 | fib(N,M) ==> N > 1 | N1 is N-1, fib(N1,M1), N2 is N-2, fib(N2,M2), M is M1 + M2. 24 | 25 | -------------------------------------------------------------------------------- /Examples/gcd.chr: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | %% 3 | %% 980202, 980311 Thom Fruehwirth, LMU 4 | %% computes greatest common divisor of positive numbers written each as gcd(N) 5 | %% 6 | %% ported to hProlog by Tom Schrijvers 7 | 8 | :- module(gcd,[]). 9 | 10 | :- use_module( library(chr)). 11 | 12 | :- constraints gcd/1. 13 | 14 | gcd(0) <=> true. 15 | %%gcd(N) \ gcd(M) <=> N= N= true. 14 | antisymmetry @ leq(X,Y), leq(Y,X) <=> X = Y. 15 | idempotence @ leq(X,Y) \ leq(X,Y) <=> true. 16 | transitivity @ leq(X,Y), leq(Y,Z) ==> leq(X,Z). 17 | 18 | leq :- 19 | circle(X, Y, Z), 20 | \+ attvar(X), 21 | X == Y, 22 | Y == Z. 23 | 24 | circle(X, Y, Z) :- 25 | leq(X, Y), 26 | leq(Y, Z), 27 | leq(Z, X). 28 | -------------------------------------------------------------------------------- /Benchmarks/primes.chr: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | %% 3 | %% Sieve of eratosthenes to compute primes 4 | %% thom fruehwirth 920218-20, 980311 5 | %% christian holzbaur 980207 for Sicstus CHR 6 | %% 7 | %% ported to hProlog by Tom Schrijvers 8 | 9 | :- module(primes,[main/0,main/1]). 10 | :- use_module(library(chr)). 11 | 12 | :- chr_constraint candidate/1. 13 | :- chr_constraint prime/1. 14 | 15 | candidate(1) <=> true. 16 | candidate(N) <=> primes:prime(N), N1 is N - 1, primes:candidate(N1). 17 | 18 | absorb @ prime(Y) \ prime(X) <=> 0 =:= X mod Y | true. 19 | 20 | main :- 21 | main(2500). 22 | 23 | main(N):- 24 | cputime(X), 25 | candidate(N), 26 | cputime( Now), 27 | Time is Now-X, 28 | write(bench(primes ,N,Time,0,hprolog)), write('.'),nl. 29 | 30 | -------------------------------------------------------------------------------- /Benchmarks/fib.chr: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | %% 3 | %% 991202 Slim Abdennadher, LMU 4 | %% 5 | %% ported to hProlog by Tom Schrijvers 6 | 7 | :- module(fib,[main/0,main/1]). 8 | 9 | :- use_module(library(chr)). 10 | 11 | :- chr_constraint fib/2. 12 | 13 | %% fib(N,M) is true if M is the Nth Fibonacci number. 14 | 15 | %% Top-down Evaluation with Tabulation 16 | 17 | fib(N,M1), fib(N,M2) <=> M1 = M2, fib(N,M1). 18 | 19 | fib(0,M) ==> M = 1. 20 | 21 | fib(1,M) ==> M = 1. 22 | 23 | fib(N,M) ==> N > 1 | N1 is N-1, fib(N1,M1), N2 is N-2, fib(N2,M2), M is M1 + M2. 24 | 25 | main :- 26 | main(22). 27 | 28 | main(N):- 29 | cputime(X), 30 | fib(N,_), 31 | cputime( Now), 32 | Time is Now-X, 33 | write(bench(fib ,N,Time, 0, hprolog)),write('.'), nl. 34 | 35 | -------------------------------------------------------------------------------- /Examples/fibonacci.chr: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | %% 3 | %% 16 June 2003 Bart Demoen, Tom Schrijvers, K.U.Leuven 4 | %% 5 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 6 | 7 | :- module(fibonacci,[]). 8 | 9 | :- use_module(library(chr)). 10 | 11 | :- constraints fibonacci/2. 12 | 13 | %% fibonacci(N,M) is true iff M is the Nth Fibonacci number. 14 | 15 | %% Top-down Evaluation with effective Tabulation 16 | %% Contrary to the version in the SICStus manual, this one does "true" 17 | %% tabulation 18 | 19 | fibonacci(N,M1) # Id \ fibonacci(N,M2) <=> var(M2) | M1 = M2 pragma passive(Id). 20 | 21 | fibonacci(0,M) ==> M = 1. 22 | 23 | fibonacci(1,M) ==> M = 1. 24 | 25 | fibonacci(N,M) ==> 26 | N > 1 | 27 | N1 is N-1, 28 | fibonacci(N1,M1), 29 | N2 is N-2, 30 | fibonacci(N2,M2), 31 | M is M1 + M2. 32 | -------------------------------------------------------------------------------- /Examples/leq.chr: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | %% 3 | %% simple constraint solver for inequalities between variables 4 | %% thom fruehwirth ECRC 950519, LMU 980207, 980311 5 | %% 6 | %% ported to hProlog by Tom Schrijvers 7 | 8 | :- module(leq,[]). 9 | :- use_module(library(chr)). 10 | 11 | :- constraints leq/2. 12 | reflexivity @ leq(X,X) <=> true. 13 | antisymmetry @ leq(X,Y), leq(Y,X) <=> X = Y. 14 | idempotence @ leq(X,Y) \ leq(X,Y) <=> true. 15 | transitivity @ leq(X,Y), leq(Y,Z) ==> leq(X,Z). 16 | 17 | time(N):- 18 | cputime(X), 19 | length(L,N), 20 | genleq(L,Last), 21 | L=[First|_], 22 | leq(Last,First), 23 | cputime( Now), 24 | Time is Now-X, 25 | write(N-Time), nl. 26 | 27 | genleq([Last],Last) :- ! . 28 | genleq([X,Y|Xs],Last):- 29 | leq(X,Y), 30 | genleq([Y|Xs],Last). 31 | 32 | cputime( Ts) :- 33 | statistics( runtime, [Tm,_]), 34 | Ts is Tm/1000. 35 | -------------------------------------------------------------------------------- /Benchmarks/leq.chr: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | %% 3 | %% simple constraint solver for inequalities between variables 4 | %% thom fruehwirth ECRC 950519, LMU 980207, 980311 5 | %% 6 | %% ported to hProlog by Tom Schrijvers 7 | 8 | :- module(leq,[main/0,main/1]). 9 | :- use_module(library(chr)). 10 | 11 | :- chr_constraint leq/2. 12 | 13 | reflexivity @ leq(X,X) <=> true. 14 | antisymmetry @ leq(X,Y), leq(Y,X) <=> X = Y. 15 | idempotence @ leq(X,Y) \ leq(X,Y) <=> true. 16 | transitivity @ leq(X,Y), leq(Y,Z) ==> leq(X,Z). 17 | 18 | main :- 19 | main(60). 20 | 21 | main(N):- 22 | cputime(X), 23 | length(L,N), 24 | genleq(L,Last), 25 | L=[First|_], 26 | leq(Last,First), 27 | cputime( Now), 28 | Time is Now-X, 29 | write(bench(leq ,N,Time,0,hprolog)), write('.'),nl. 30 | 31 | genleq([Last],Last) :- ! . 32 | genleq([X,Y|Xs],Last):- 33 | leq(X,Y), 34 | genleq([Y|Xs],Last). 35 | -------------------------------------------------------------------------------- /Examples/primes.chr: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | %% 3 | %% Sieve of eratosthenes to compute primes 4 | %% thom fruehwirth 920218-20, 980311 5 | %% christian holzbaur 980207 for Sicstus CHR 6 | %% 7 | %% ported to hProlog by Tom Schrijvers 8 | %% Updated to current CHR and added how to extract the primes by 9 | %% Jan Wielemaker. 10 | 11 | :- module(primes, 12 | [ candidate/1, % +Max 13 | primes/2 % +Max, -ListOfPrimes 14 | ]). 15 | :- use_module(library(chr)). 16 | 17 | :- chr_constraint candidate/1. 18 | :- chr_constraint prime/1. 19 | 20 | candidate(1) <=> true. 21 | candidate(N) <=> prime(N), N1 is N - 1, candidate(N1). 22 | 23 | absorb @ prime(Y) \ prime(X) <=> 0 is X mod Y | true. 24 | 25 | primes(Max, Primes) :- 26 | findall(P, 27 | ( candidate(Max), 28 | current_chr_constraint(prime(P))), 29 | Primes). 30 | -------------------------------------------------------------------------------- /Tests/primes.chr: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | %% 3 | %% Sieve of eratosthenes to compute primes 4 | %% thom fruehwirth 920218-20, 980311 5 | %% christian holzbaur 980207 for Sicstus CHR 6 | %% 7 | %% ported to hProlog by Tom Schrijvers 8 | 9 | :- module(primes,[primes/0]). 10 | :- use_module(library(chr)). 11 | 12 | :- chr_constraint candidate/1. 13 | :- chr_constraint prime/1. 14 | :- chr_constraint cleanup/1. 15 | 16 | :- chr_option(debug,off). 17 | :- chr_option(optimize,full). 18 | 19 | candidate(1) <=> true. 20 | candidate(N) <=> prime(N), N1 is N - 1, candidate(N1). 21 | 22 | absorb @ prime(Y) \ prime(X) <=> 0 =:= X mod Y | true. 23 | 24 | cleanup(_L), candidate(_X) <=> fail. 25 | cleanup(L), prime(N) <=> L = [N|T], cleanup(T). 26 | cleanup(L) <=> L = []. 27 | 28 | primes :- 29 | candidate(100), 30 | cleanup(L), 31 | sort(L,SL), 32 | SL == [2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97]. 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | -------------------------------------------------------------------------------- /Benchmarks/fibonacci.chr: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | %% 3 | %% 16 June 2003 Bart Demoen, Tom Schrijvers, K.U.Leuven 4 | %% 5 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 6 | 7 | :- module(fibonacci,[main/0,main/1]). 8 | 9 | :- use_module(library(chr)). 10 | 11 | :- chr_constraint fibonacci/2. 12 | 13 | %% fibonacci(N,M) is true iff M is the Nth Fibonacci number. 14 | 15 | %% Top-down Evaluation with effective Tabulation 16 | %% Contrary to the version in the SICStus manual, this one does "true" 17 | %% tabulation 18 | 19 | fibonacci(N,M1) # ID \ fibonacci(N,M2) <=> var(M2) | M1 = M2 pragma passive(ID). 20 | 21 | fibonacci(0,M) ==> M = 1. 22 | 23 | fibonacci(1,M) ==> M = 1. 24 | 25 | fibonacci(N,M) ==> 26 | N > 1 | 27 | N1 is N-1, 28 | fibonacci(N1,M1), 29 | N2 is N-2, 30 | fibonacci(N2,M2), 31 | M is M1 + M2. 32 | 33 | main :- 34 | main(2000). 35 | 36 | main(N):- 37 | cputime(X), 38 | fibonacci(N,_), 39 | cputime( Now), 40 | Time is Now-X, 41 | write(bench(fibonacci ,N,Time, 0, hprolog)),write('.'), nl. 42 | 43 | -------------------------------------------------------------------------------- /Tests/fibonacci.chr: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | %% 3 | %% 16 June 2003 Bart Demoen, Tom Schrijvers, K.U.Leuven 4 | %% 5 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 6 | 7 | :- module(fibonacci,[fibonacci/0]). 8 | :- use_module(library(chr)). 9 | 10 | :- chr_constraint fibonacci/2, cleanup/1. 11 | 12 | %% fibonacci(N,M) is true iff M is the Nth Fibonacci number. 13 | 14 | %% Top-down Evaluation with effective Tabulation 15 | %% Contrary to the version in the SICStus manual, this one does "true" 16 | %% tabulation 17 | 18 | fibonacci(N,M1) # ID \ fibonacci(N,M2) <=> var(M2) | M1 = M2 pragma passive(ID). 19 | 20 | fibonacci(0,M) ==> M = 1. 21 | 22 | fibonacci(1,M) ==> M = 1. 23 | 24 | fibonacci(N,M) ==> 25 | N > 1 | 26 | N1 is N-1, 27 | fibonacci(N1,M1), 28 | N2 is N-2, 29 | fibonacci(N2,M2), 30 | M is M1 + M2. 31 | 32 | cleanup(L), fibonacci(N,F) <=> L = [N-F|T], cleanup(T). 33 | cleanup(L) <=> L = []. 34 | 35 | fibonacci :- 36 | fibonacci(15,F), 37 | F == 987, 38 | cleanup(L), 39 | sort(L,SL), 40 | SL == [0 - 1,1 - 1,2 - 2,3 - 3,4 - 5,5 - 8,6 - 13,7 - 21,8 - 34,9 - 55,10 - 89,11 - 144,12 - 233,13 - 377,14 - 610,15 - 987]. 41 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | CHR for SWI-Prolog 2 | ================== 3 | 4 | Authors and license 5 | ==================== 6 | 7 | This package contains code from the following authors. All code is 8 | distributed under the SWI-Prolog conditions with permission from the 9 | authors. 10 | 11 | 12 | * Tom Schrijvers, K.U.Leuven Tom.Schrijvers@cs.kuleuven.be 13 | * Christian Holzbaur christian@ai.univie.ac.at 14 | * Jan Wielemaker jan@swi-prolog.org 15 | 16 | 17 | Files and their roles: 18 | ====================== 19 | 20 | # library(chr) chr_swi.pl 21 | Make user-predicates and hooks for loading CHR files available 22 | to the user. 23 | 24 | # library(chr/chr_op) 25 | Include file containing the operator declaractions 26 | 27 | # library(chr/chr_translate) 28 | Core translation module. Defines chr_translate/2. 29 | 30 | # library(chr/chr_debug) 31 | Debugging routines, made available to the user through 32 | library(chr). Very incomplete. 33 | 34 | # library(chr/hprolog) 35 | Compatibility to hProlog. Should be abstracted. 36 | 37 | # library(chr/pairlist) 38 | Deal with lists of Name-Value. Used by chr_translate.pl 39 | 40 | 41 | Status 42 | ====== 43 | 44 | Work in progress. The compiler source (chr_translate.pl) contains 45 | various `todo' issues. The debugger is almost non existent. Future work 46 | should improve on the compatibility with the reference CHR 47 | documentation. Details on loading CHR files are subject to change. 48 | -------------------------------------------------------------------------------- /.fileheader: -------------------------------------------------------------------------------- 1 | /* Part of CHR (Constraint Handling Rules) 2 | 3 | Author: Tom Schrijvers 4 | E-mail: VU University Amsterdam 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) %Y, K.U. Leuven 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | 2. Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in 18 | the documentation and/or other materials provided with the 19 | distribution. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | */ 34 | 35 | -------------------------------------------------------------------------------- /pairlist.pl: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | %% _ _ _ _ 3 | %% _ __ __ _(_)_ __| (_)___| |_ 4 | %% | '_ \ / _` | | '__| | / __| __| 5 | %% | |_) | (_| | | | | | \__ \ |_ 6 | %% | .__/ \__,_|_|_| |_|_|___/\__| 7 | %% |_| 8 | %% 9 | %% * author: Tom Schrijvers 10 | 11 | :- module(pairlist,[ 12 | fst_of_pairs/2, 13 | lookup/3, 14 | lookup_any/3, 15 | lookup_eq/3, 16 | lookup_any_eq/3, 17 | pairup/3, 18 | snd_of_pairs/2, 19 | translate/3, 20 | pairlist_delete_eq/3 21 | ]). 22 | 23 | fst_of_pairs([],[]). 24 | fst_of_pairs([X-_|XYs],[X|Xs]) :- 25 | fst_of_pairs(XYs,Xs). 26 | 27 | snd_of_pairs([],[]). 28 | snd_of_pairs([_-Y|XYs],[Y|Ys]) :- 29 | snd_of_pairs(XYs,Ys). 30 | 31 | pairup([],[],[]). 32 | pairup([X|Xs],[Y|Ys],[X-Y|XYs]) :- 33 | pairup(Xs,Ys,XYs). 34 | 35 | lookup([K - V | KVs],Key,Value) :- 36 | ( K = Key -> 37 | V = Value 38 | ; 39 | lookup(KVs,Key,Value) 40 | ). 41 | 42 | lookup_any([K - V | KVs],Key,Value) :- 43 | ( 44 | K = Key, 45 | V = Value 46 | ; 47 | lookup_any(KVs,Key,Value) 48 | ). 49 | 50 | lookup_eq([K - V | KVs],Key,Value) :- 51 | ( K == Key -> 52 | V = Value 53 | ; 54 | lookup_eq(KVs,Key,Value) 55 | ). 56 | 57 | lookup_any_eq([K - V | KVs],Key,Value) :- 58 | ( 59 | K == Key, 60 | V = Value 61 | ; 62 | lookup_any_eq(KVs,Key,Value) 63 | ). 64 | 65 | translate([],_,[]). 66 | translate([X|Xs],Dict,[Y|Ys]) :- 67 | lookup_eq(Dict,X,Y), 68 | translate(Xs,Dict,Ys). 69 | 70 | pairlist_delete_eq([], _, []). 71 | pairlist_delete_eq([K - V| KVs], Key, PL) :- 72 | ( Key == K -> 73 | PL = KVs 74 | ; 75 | PL = [ K - V | T ], 76 | pairlist_delete_eq(KVs, Key, T) 77 | ). 78 | 79 | -------------------------------------------------------------------------------- /chr_op.pl: -------------------------------------------------------------------------------- 1 | /* Part of CHR (Constraint Handling Rules) 2 | 3 | Author: Tom Schrijvers 4 | E-mail: Tom.Schrijvers@cs.kuleuven.be 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2004-2011, K.U. Leuven 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | 2. Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in 18 | the documentation and/or other materials provided with the 19 | distribution. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | */ 34 | 35 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 36 | %% 37 | %% Operator Priorities 38 | 39 | :- op(1180, xfx, ==>). 40 | :- op(1180, xfx, <=>). 41 | :- op(1150, fx, constraints). 42 | :- op(1150, fx, chr_constraint). 43 | :- op(1150, fx, handler). 44 | :- op(1150, fx, rules). 45 | :- op(1100, xfx, \). 46 | :- op(1200, xfx, @). % values from hProlog 47 | :- op(1190, xfx, pragma). % values from hProlog 48 | :- op( 500, yfx, #). % values from hProlog 49 | %:- op(1100, xfx, '|'). 50 | :- op(1150, fx, chr_type). 51 | :- op(1130, xfx, --->). 52 | :- op(1150, fx, (?)). 53 | :- op(1150, fx, chr_declaration). 54 | -------------------------------------------------------------------------------- /chr_op2.pl: -------------------------------------------------------------------------------- 1 | /* Part of CHR (Constraint Handling Rules) 2 | 3 | Author: Tom Schrijvers 4 | E-mail: Tom.Schrijvers@cs.kuleuven.be 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2005-2011, K.U. Leuven 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | 2. Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in 18 | the documentation and/or other materials provided with the 19 | distribution. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | */ 34 | 35 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 36 | %% 37 | %% Operator Priorities 38 | 39 | 40 | % old version, without the type/mode operators 41 | 42 | :- op(1180, xfx, ==>). 43 | :- op(1180, xfx, <=>). 44 | :- op(1150, fx, constraints). 45 | :- op(1150, fx, chr_constraint). 46 | :- op(1150, fx, handler). 47 | :- op(1150, fx, rules). 48 | :- op(1100, xfx, \). 49 | :- op(1200, xfx, @). % values from hProlog 50 | :- op(1190, xfx, pragma). % values from hProlog 51 | :- op( 500, yfx, #). % values from hProlog 52 | %:- op(1100, xfx, '|'). 53 | %:- op(1150, fx, chr_type). 54 | %:- op(1130, xfx, --->). 55 | -------------------------------------------------------------------------------- /chr_debug.pl: -------------------------------------------------------------------------------- 1 | /* Part of CHR (Constraint Handling Rules) 2 | 3 | Author: Tom Schrijvers 4 | E-mail: Tom.Schrijvers@cs.kuleuven.ac.be 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2004-2015, K.U. Leuven 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | 2. Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in 18 | the documentation and/or other materials provided with the 19 | distribution. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | */ 34 | 35 | :- module(chr_debug, 36 | [ chr_show_store/1, % +Module 37 | find_chr_constraint/1 38 | ]). 39 | :- set_prolog_flag(generate_debug_info, false). 40 | 41 | %% chr_show_store(+Module) 42 | % 43 | % Prints all suspended constraints of module Mod to the standard 44 | % output. 45 | 46 | chr_show_store(Mod) :- 47 | ( Mod:'$enumerate_suspensions'(Susp), 48 | Susp =.. [_,_,_,_,_,_,F|Arg], 49 | functor(F,Fun,_), 50 | C =.. [Fun|Arg], 51 | print(C),nl, % allows use of portray to control printing 52 | fail 53 | ; true 54 | ). 55 | 56 | find_chr_constraint(C) :- 57 | chr:chr_module(Mod), 58 | Mod:'$enumerate_suspensions'(Susp), 59 | arg(6,Susp,C). 60 | -------------------------------------------------------------------------------- /chr_support.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | 6 | /* 7 | lookup_ht(HT,Key,Values) :- 8 | term_hash(Key,Hash), 9 | HT = ht(Capacity,_,Table), 10 | Index is (Hash mod Capacity) + 1, 11 | arg(Index,Table,Bucket), 12 | nonvar(Bucket), 13 | ( Bucket = K-Vs -> 14 | K == Key, 15 | Values = Vs 16 | ; 17 | lookup(Bucket,Key,Values) 18 | ). 19 | 20 | lookup([K - V | KVs],Key,Value) :- 21 | ( K = Key -> 22 | V = Value 23 | ; 24 | lookup(KVs,Key,Value) 25 | ). 26 | */ 27 | static foreign_t 28 | pl_lookup_ht1(term_t ht, term_t pl_hash, term_t key, term_t values) 29 | { 30 | int capacity; 31 | int hash; 32 | int index; 33 | 34 | term_t pl_capacity = PL_new_term_ref(); 35 | term_t table = PL_new_term_ref(); 36 | term_t bucket = PL_new_term_ref(); 37 | 38 | /* HT = ht(Capacity,_,Table) */ 39 | PL_get_arg(1, ht, pl_capacity); 40 | PL_get_integer(pl_capacity, &capacity); 41 | PL_get_arg(3, ht, table); 42 | 43 | /* Index is (Hash mod Capacity) + 1 */ 44 | PL_get_integer(pl_hash, &hash); 45 | index = (hash % capacity) + 1; 46 | 47 | /* arg(Index,Table,Bucket) */ 48 | PL_get_arg(index, table, bucket); 49 | 50 | /* nonvar(Bucket) */ 51 | if (PL_is_variable(bucket)) PL_fail; 52 | 53 | if (PL_is_list(bucket)) { 54 | term_t pair = PL_new_term_ref(); 55 | term_t k = PL_new_term_ref(); 56 | term_t vs = PL_new_term_ref(); 57 | while (PL_get_list(bucket, pair,bucket)) { 58 | PL_get_arg(1, pair, k); 59 | if ( PL_compare(k,key) == 0 ) { 60 | /* Values = Vs */ 61 | PL_get_arg(2, pair, vs); 62 | return PL_unify(values,vs); 63 | } 64 | } 65 | PL_fail; 66 | } else { 67 | term_t k = PL_new_term_ref(); 68 | term_t vs = PL_new_term_ref(); 69 | PL_get_arg(1, bucket, k); 70 | /* K == Key */ 71 | if ( PL_compare(k,key) == 0 ) { 72 | /* Values = Vs */ 73 | PL_get_arg(2, bucket, vs); 74 | return PL_unify(values,vs); 75 | } else { 76 | PL_fail; 77 | } 78 | } 79 | } 80 | 81 | static foreign_t 82 | pl_memberchk_eq(term_t element, term_t maybe_list) 83 | { 84 | 85 | term_t head = PL_new_term_ref(); /* variable for the elements */ 86 | term_t list = PL_copy_term_ref(maybe_list); /* copy as we need to write */ 87 | 88 | while( PL_get_list(list, head, list) ) 89 | { if ( PL_compare(element,head) == 0 ) 90 | PL_succeed ; 91 | } 92 | 93 | PL_fail; 94 | 95 | } 96 | 97 | /* INSTALL */ 98 | 99 | install_t 100 | install_chr_support() 101 | { 102 | PL_register_foreign("memberchk_eq",2, pl_memberchk_eq, 0); 103 | PL_register_foreign("lookup_ht1",4, pl_lookup_ht1, 0); 104 | } 105 | 106 | -------------------------------------------------------------------------------- /Examples/family.chr: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | %% 3 | %% 000401 Slim Abdennadher and Henning Christiansen 4 | %% 5 | %% ported to hProlog by Tom Schrijvers 6 | 7 | :- module(family,[]). 8 | 9 | :- use_module(library(chr)). 10 | 11 | :- constraints 12 | % extensional predicates: 13 | person/2, father/2, mother/2, 14 | orphan/1, 15 | % intensional predicates: 16 | parent/2, sibling/2, 17 | % predefined: 18 | diff/2, 19 | % a little helper: 20 | start/0. 21 | 22 | % Representing the test for failed state, i.e., 23 | % that the 'predefined' are satisfiable 24 | 25 | diff(X,X) ==> false. 26 | 27 | 28 | 29 | % Definition rules: 30 | 31 | parent_def @ 32 | parent(P,C) <=> (true | (father(P,C) ; mother(P,C))). 33 | 34 | sibling_def @ 35 | sibling(C1,C2) <=> 36 | diff(C1,C2), 37 | parent(P,C1), parent(P,C2). 38 | 39 | ext_intro @ 40 | start <=> father(john,mary), father(john,peter), 41 | mother(jane,mary), 42 | person(john,male), person(peter,male), 43 | person(jane,female), person(mary,female), 44 | person(paul,male). 45 | 46 | 47 | 48 | % Closing rules 49 | father_close @ 50 | father(X,Y) ==> ( true | ((X=john, Y=mary) ; (X=john, Y=peter))). 51 | 52 | % mother close @ 53 | mother(X,Y) ==> X=jane, Y=mary. 54 | 55 | % person_close @ 56 | person(X,Y) ==> ( true | ( (X=john, Y=male) ; 57 | (X=peter, Y=male) ; 58 | (X=jane, Y=female) ; 59 | (X=mary, Y=female) ; 60 | (X=paul, Y=male) 61 | ) 62 | ). 63 | 64 | 65 | 66 | % ICs 67 | 68 | ic_father_unique @ 69 | father(F1,C),father(F2,C) ==> F1=F2. 70 | 71 | 72 | ic_mother_unique @ 73 | mother(M1,C),mother(M2,C) ==> M1=M2. 74 | 75 | ic_gender_unique @ 76 | person(P,G1), person(P,G2) ==> G1=G2. 77 | 78 | ic_father_persons @ 79 | father(F,C) ==> person(F,male), person(C,S). 80 | 81 | ic_mother_persons @ 82 | mother(M,C) ==> person(M,female), person(C,G). 83 | 84 | % Indirect def. 85 | 86 | orphan1 @ 87 | orphan(C) ==> person(C,G). 88 | 89 | orphan2 @ 90 | orphan(C), /* person(F,male),*/ father(F,C) ==> false. 91 | 92 | orphan3 @ 93 | orphan(C), /* person(M,female),*/ mother(M,C) ==> false. 94 | 95 | 96 | 97 | %%%% The following just to simplify output; 98 | 99 | 100 | father(F,C) \ father(F,C)<=> true. 101 | mother(M,C) \ mother(M,C)<=> true. 102 | person(M,C) \ person(M,C)<=> true. 103 | orphan(C) \ orphan(C)<=> true. 104 | 105 | 106 | /************************************************* 107 | Sample goals 108 | 109 | :- start, sibling(peter,mary). 110 | 111 | :- start, sibling(paul,mary). 112 | 113 | :- father(X,Y), mother(X,Y). 114 | 115 | **************************************************/ 116 | 117 | -------------------------------------------------------------------------------- /find.pl: -------------------------------------------------------------------------------- 1 | /* Part of CHR (Constraint Handling Rules) 2 | 3 | Author: Bart Demoen, Tom Schrijvers 4 | E-mail: Tom.Schrijvers@cs.kuleuven.be 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2004-2011, K.U. Leuven 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | 2. Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in 18 | the documentation and/or other materials provided with the 19 | distribution. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | */ 34 | 35 | :- module(chr_find, 36 | [ 37 | find_with_var_identity/4, 38 | forall/3, 39 | forsome/3 40 | ]). 41 | 42 | :- use_module(library(lists)). 43 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 44 | 45 | :- meta_predicate 46 | find_with_var_identity(?, +, :, -), 47 | forall(-, +, :), 48 | forsome(-, +, :). 49 | 50 | find_with_var_identity(Template, IdVars, Goal, Answers) :- 51 | Key = foo(IdVars), 52 | copy_term_nat(Template-Key-Goal,TemplateC-KeyC-GoalC), 53 | findall(KeyC - TemplateC, GoalC, As), 54 | smash(As,Key,Answers). 55 | 56 | smash([],_,[]). 57 | smash([Key-T|R],Key,[T|NR]) :- smash(R,Key,NR). 58 | 59 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 60 | forall(X,L,G) :- 61 | \+ (member(X,L), \+ call(G)). 62 | 63 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 64 | forsome(X,L,G) :- 65 | member(X,L), 66 | call(G), !. 67 | 68 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 69 | :- dynamic 70 | user:goal_expansion/2. 71 | :- multifile 72 | user:goal_expansion/2. 73 | 74 | user:goal_expansion(forall(Element,List,Test), GoalOut) :- 75 | nonvar(Test), 76 | Test =.. [Functor,Arg], 77 | Arg == Element, 78 | GoalOut = once(maplist(Functor,List)). 79 | -------------------------------------------------------------------------------- /Examples/chrdif.chr: -------------------------------------------------------------------------------- 1 | /* Part of CHR (Constraint Handling Rules) 2 | 3 | Author: Tom Schrijvers 4 | E-mail: Tom.Schrijvers@cs.kuleuven.be 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2004-2011, K.U. Leuven 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | 2. Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in 18 | the documentation and/or other materials provided with the 19 | distribution. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | */ 34 | 35 | :- module(chrdif,[chrdif/2]). 36 | :- use_module(library(chr)). 37 | 38 | :- constraints dif/2, dif2/3, or/2, or_seq/2, del_or/1. 39 | 40 | chrdif(X,Y) :- dif(X,Y). 41 | 42 | dif(X,Y) <=> compound(X), compound(Y) | dif1(X,Y). 43 | dif(X,X) <=> fail. 44 | dif(X,Y) <=> nonvar(X), nonvar(Y) /* X \== Y holds */ | true. 45 | 46 | dif1(X,Y) :- 47 | ( functor(X,F,A), 48 | functor(Y,F,A) -> 49 | X =.. [_|XL], 50 | Y =.. [_|YL], 51 | dif1l(XL,YL,A) 52 | ; 53 | true 54 | ). 55 | 56 | dif1l(Xs,Ys,N) :- 57 | or(Or,N), 58 | dif1l_2(Xs,Ys,Or). 59 | 60 | dif1l_2([],[],_). 61 | dif1l_2([X|Xs],[Y|Ys],Or) :- 62 | dif2(X,Y,Or), 63 | dif1l_2(Xs,Ys,Or). 64 | 65 | or_seq(OrP,Or) \ or(Or,0), or(OrP,N) <=> M is N - 1, or_seq(OrP,M). 66 | or(_,0) <=> fail. 67 | 68 | dif2(X,Y,Or) <=> compound(X), compound(Y) | dif3(X,Y,Or). 69 | dif2(X,X,Or), or(Or,N) <=> M is N - 1, or(Or,M). 70 | dif2(X,Y,Or) <=> nonvar(X), nonvar(Y) /* X \== Y holds */ | del_or(Or). 71 | 72 | del_or(Or) \ or_seq(OrP,Or) <=> del_or(OrP). 73 | del_or(Or) \ or_seq(Or,OrC) <=> del_or(OrC). 74 | del_or(Or) \ or(Or,_) <=> true. 75 | del_or(Or) \ dif2(_,_,Or) <=> true. 76 | del_or(Or) <=> true. 77 | 78 | dif3(X,Y,Or) :- 79 | ( functor(X,F,A), 80 | functor(Y,F,A) -> 81 | X =.. [_|XL], 82 | Y =.. [_|YL], 83 | or_seq(Or,Or2), 84 | dif1l(XL,YL,A) 85 | ; 86 | del_or(Or) 87 | ). 88 | -------------------------------------------------------------------------------- /a_star.pl: -------------------------------------------------------------------------------- 1 | /* Part of CHR (Constraint Handling Rules) 2 | 3 | Author: Tom Schrijvers 4 | E-mail: Tom.Schrijvers@cs.kuleuven.be 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2004-2011, K.U. Leuven 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | 2. Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in 18 | the documentation and/or other materials provided with the 19 | distribution. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | */ 34 | 35 | :- module(a_star, 36 | [ 37 | a_star/4 38 | ]). 39 | 40 | :- use_module(binomialheap). 41 | 42 | :- use_module(find). 43 | 44 | :- use_module(library(dialect/hprolog)). 45 | 46 | a_star(DataIn,FinalData,ExpandData,DataOut) :- 47 | a_star_node(DataIn,0,InitialNode), 48 | empty_q(NewQueue), 49 | insert_q(NewQueue,InitialNode,Queue), 50 | a_star_aux(Queue,FinalData,ExpandData,EndNode), 51 | a_star_node(DataOut,_,EndNode). 52 | 53 | a_star_aux(Queue,FinalData,ExpandData,EndNode) :- 54 | delete_min_q(Queue,Queue1,Node), 55 | ( final_node(FinalData,Node) -> 56 | Node = EndNode 57 | ; 58 | expand_node(ExpandData,Node,Nodes), 59 | insert_list_q(Nodes,Queue1,NQueue), 60 | a_star_aux(NQueue,FinalData,ExpandData,EndNode) 61 | ). 62 | 63 | final_node(D^Call,Node) :- 64 | a_star_node(Data,_,Node), 65 | term_variables(Call,Vars), 66 | chr_delete(Vars,D,DVars), 67 | copy_term(D^Call-DVars,Data^NCall-DVars), 68 | call(NCall). 69 | 70 | expand_node(D^Ds^C^Call,Node,Nodes) :- 71 | a_star_node(Data,Score,Node), 72 | term_variables(Call,Vars), 73 | chr_delete(Vars,D,DVars0), 74 | chr_delete(DVars0,Ds,DVars1), 75 | chr_delete(DVars1,C,DVars), 76 | copy_term(D^Ds^C^Call-DVars,Data^EData^Cost^NCall-DVars), 77 | term_variables(Node,NVars,DVars), 78 | find_with_var_identity(ENode,NVars,(NCall,EScore is Cost + Score,a_star:a_star_node(EData,EScore,ENode)),Nodes). 79 | 80 | a_star_node(Data,Score,Data-Score). 81 | -------------------------------------------------------------------------------- /listmap.pl: -------------------------------------------------------------------------------- 1 | /* Part of CHR (Constraint Handling Rules) 2 | 3 | Author: Tom Schrijvers 4 | E-mail: Tom.Schrijvers@cs.kuleuven.be 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2005-2011, K.U. Leuven 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | 2. Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in 18 | the documentation and/or other materials provided with the 19 | distribution. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | */ 34 | 35 | :- module(listmap, 36 | [ 37 | listmap_empty/1, 38 | listmap_lookup/3, 39 | listmap_insert/4, 40 | listmap_remove/3, 41 | listmap_merge/5 42 | ]). 43 | 44 | listmap_empty([]). 45 | 46 | listmap_lookup([K-V|R],Key,Q) :- 47 | ( Key == K -> 48 | Q = V 49 | ; 50 | Key @> K, 51 | listmap_lookup(R,Key,Q) 52 | ). 53 | 54 | listmap_insert([],Key,Value,[Key-Value]). 55 | listmap_insert([P|R],Key,Value,ML) :- 56 | P = K-_, 57 | compare(C,Key,K), 58 | ( C == (=) -> 59 | ML = [K-Value|R] 60 | ; C == (<) -> 61 | ML = [Key-Value,P|R] 62 | ; 63 | ML = [P|Tail], 64 | listmap_insert(R,Key,Value,Tail) 65 | ). 66 | 67 | listmap_merge(ML1,ML2,F,G,ML) :- 68 | ( ML1 == [] -> 69 | ML = ML2 70 | ; ML2 == [] -> 71 | ML = ML1 72 | ; 73 | ML1 = [P1|R1], P1 = K1-V1, 74 | ML2 = [P2|R2], P2 = K2-V2, 75 | compare(C,K1,K2), 76 | ( C == (=) -> 77 | Call =.. [F,V1,V2,NV], 78 | call(Call), 79 | ML = [K1-NV|Tail], 80 | listmap_merge(R1,R2,F,G,Tail) 81 | ; C == (<) -> 82 | Call =.. [G,V1,NV], 83 | call(Call), 84 | ML = [K1-NV|Tail], 85 | listmap_merge(R1,ML2,F,G,Tail) 86 | ; 87 | Call =.. [G,V2,NV], 88 | call(Call), 89 | ML = [K2-NV|Tail], 90 | listmap_merge(ML1,R2,F,G,Tail) 91 | ) 92 | ). 93 | 94 | 95 | listmap_remove([],_,[]). 96 | listmap_remove([P|R],Key,NLM) :- 97 | P = K-_, 98 | compare(C,Key,K), 99 | ( C == (=) -> 100 | NLM = R 101 | ; C == (<) -> 102 | NLM = [P|R] 103 | ; 104 | NLM = [P|Tail], 105 | listmap_remove(R,Key,Tail) 106 | ). 107 | 108 | 109 | -------------------------------------------------------------------------------- /Benchmarks/fulladder.chr: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | %% 3 | %% Thom Fruehwirth ECRC 1991-1993 4 | %% 910528 started boolean,and,or constraints 5 | %% 910904 added xor,neg constraints 6 | %% 911120 added imp constraint 7 | %% 931110 ported to new release 8 | %% 931111 added card constraint 9 | %% 961107 Christian Holzbaur, SICStus mods 10 | %% 11 | %% ported to hProlog by Tom Schrijvers June 2003 12 | 13 | 14 | :- module(fulladder,[main/0,main/1]). 15 | :- use_module(library(chr)). 16 | 17 | :- chr_constraint and/3, or/3, xor/3, neg/2. 18 | 19 | :- use_module(library(lists)). 20 | 21 | %% and/3 specification 22 | %%and(0,0,0). 23 | %%and(0,1,0). 24 | %%and(1,0,0). 25 | %%and(1,1,1). 26 | 27 | and(0,X,Y) <=> Y=0. 28 | and(X,0,Y) <=> Y=0. 29 | and(1,X,Y) <=> Y=X. 30 | and(X,1,Y) <=> Y=X. 31 | and(X,Y,1) <=> X=1,Y=1. 32 | and(X,X,Z) <=> X=Z. 33 | and(X,Y,A) \ and(X,Y,B) <=> A=B, chr_dummy. 34 | and(X,Y,A) \ and(Y,X,B) <=> A=B, chr_dummy. 35 | 36 | %% or/3 specification 37 | %%or(0,0,0). 38 | %%or(0,1,1). 39 | %%or(1,0,1). 40 | %%or(1,1,1). 41 | 42 | or(0,X,Y) <=> Y=X. 43 | or(X,0,Y) <=> Y=X. 44 | or(X,Y,0) <=> X=0,Y=0. 45 | or(1,X,Y) <=> Y=1. 46 | or(X,1,Y) <=> Y=1. 47 | or(X,X,Z) <=> X=Z. 48 | or(X,Y,A) \ or(X,Y,B) <=> A=B, chr_dummy. 49 | or(X,Y,A) \ or(Y,X,B) <=> A=B, chr_dummy. 50 | 51 | %% xor/3 specification 52 | %%xor(0,0,0). 53 | %%xor(0,1,1). 54 | %%xor(1,0,1). 55 | %%xor(1,1,0). 56 | 57 | xor(0,X,Y) <=> X=Y. 58 | xor(X,0,Y) <=> X=Y. 59 | xor(X,Y,0) <=> X=Y. 60 | xor(1,X,Y) <=> neg(X,Y). 61 | xor(X,1,Y) <=> neg(X,Y). 62 | xor(X,Y,1) <=> neg(X,Y). 63 | xor(X,X,Y) <=> Y=0. 64 | xor(X,Y,X) <=> Y=0. 65 | xor(Y,X,X) <=> Y=0. 66 | xor(X,Y,A) \ xor(X,Y,B) <=> A=B, chr_dummy. 67 | xor(X,Y,A) \ xor(Y,X,B) <=> A=B, chr_dummy. 68 | 69 | %% neg/2 specification 70 | %%neg(0,1). 71 | %%neg(1,0). 72 | 73 | neg(0,X) <=> X=1. 74 | neg(X,0) <=> X=1. 75 | neg(1,X) <=> X=0. 76 | neg(X,1) <=> X=0. 77 | neg(X,X) <=> fail. 78 | neg(X,Y) \ neg(Y,Z) <=> X=Z, chr_dummy. 79 | neg(X,Y) \ neg(Z,Y) <=> X=Z, chr_dummy. 80 | neg(Y,X) \ neg(Y,Z) <=> X=Z, chr_dummy. 81 | %% Interaction with other boolean constraints 82 | neg(X,Y) \ and(X,Y,Z) <=> Z=0, chr_dummy. 83 | neg(Y,X) \ and(X,Y,Z) <=> Z=0, chr_dummy. 84 | neg(X,Z) , and(X,Y,Z) <=> X=1,Y=0,Z=0. 85 | neg(Z,X) , and(X,Y,Z) <=> X=1,Y=0,Z=0. 86 | neg(Y,Z) , and(X,Y,Z) <=> X=0,Y=1,Z=0. 87 | neg(Z,Y) , and(X,Y,Z) <=> X=0,Y=1,Z=0. 88 | neg(X,Y) \ or(X,Y,Z) <=> Z=1, chr_dummy. 89 | neg(Y,X) \ or(X,Y,Z) <=> Z=1, chr_dummy. 90 | neg(X,Z) , or(X,Y,Z) <=> X=0,Y=1,Z=1. 91 | neg(Z,X) , or(X,Y,Z) <=> X=0,Y=1,Z=1. 92 | neg(Y,Z) , or(X,Y,Z) <=> X=1,Y=0,Z=1. 93 | neg(Z,Y) , or(X,Y,Z) <=> X=1,Y=0,Z=1. 94 | neg(X,Y) \ xor(X,Y,Z) <=> Z=1, chr_dummy. 95 | neg(Y,X) \ xor(X,Y,Z) <=> Z=1, chr_dummy. 96 | neg(X,Z) \ xor(X,Y,Z) <=> Y=1, chr_dummy. 97 | neg(Z,X) \ xor(X,Y,Z) <=> Y=1, chr_dummy. 98 | neg(Y,Z) \ xor(X,Y,Z) <=> X=1, chr_dummy. 99 | neg(Z,Y) \ xor(X,Y,Z) <=> X=1, chr_dummy. 100 | 101 | /* end of handler bool */ 102 | 103 | half_adder(X,Y,S,C) :- 104 | xor(X,Y,S), 105 | and(X,Y,C). 106 | 107 | full_adder(X,Y,Ci,S,Co) :- 108 | half_adder(X,Y,S1,Co1), 109 | half_adder(Ci,S1,S,Co2), 110 | or(Co1,Co2,Co). 111 | 112 | main :- 113 | main(6000). 114 | 115 | main(N) :- 116 | cputime(X), 117 | adder(N), 118 | cputime(Now), 119 | Time is Now - X, 120 | write(bench(bool ,N,Time,0,hprolog)),write('.'),nl. 121 | 122 | adder(N) :- 123 | length(Ys,N), 124 | add(N,Ys). 125 | 126 | add(N,[Y|Ys]) :- 127 | half_adder(1,Y,0,C), 128 | add0(Ys,C). 129 | 130 | add0([],1). 131 | add0([Y|Ys],C) :- 132 | full_adder(0,Y,C,1,NC), 133 | add1(Ys,NC). 134 | 135 | add1([],0). 136 | add1([Y|Ys],C) :- 137 | full_adder(1,Y,C,0,NC), 138 | add0(Ys,NC). 139 | 140 | -------------------------------------------------------------------------------- /CMakeLists.txt: -------------------------------------------------------------------------------- 1 | cmake_minimum_required(VERSION 3.10) 2 | project(swipl-chr) 3 | 4 | include("../cmake/PrologPackage.cmake") 5 | 6 | set(CHR_SOURCES chr_runtime.pl chr_op.pl chr_debug.pl 7 | chr_messages.pl pairlist.pl clean_code.pl find.pl a_star.pl 8 | binomialheap.pl builtins.pl chr_hashtable_store.pl listmap.pl 9 | chr_compiler_options.pl chr_compiler_utility.pl 10 | chr_compiler_errors.pl chr_integertable_store.pl) 11 | set(CHR_SOURCES_GENERATED guard_entailment.pl chr_translate.pl) 12 | 13 | set(CHR_EXAMPLES chrfreeze.chr fib.chr gcd.chr primes.chr bool.chr 14 | family.chr fibonacci.chr leq.chr listdom.chr chrdif.chr) 15 | prepend(CHR_EXAMPLES Examples/ ${CHR_EXAMPLES}) 16 | 17 | function(chr_bootstrap step file cmd) 18 | set(from ${CMAKE_CURRENT_SOURCE_DIR}/${file}.chr) 19 | set(to ${file}.pl) 20 | set(${cmd} -f none --no-packs --nopce -q 21 | -s ${CMAKE_CURRENT_SOURCE_DIR}/chr_swi_bootstrap.pl 22 | -p "chr=${CMAKE_CURRENT_BINARY_DIR}${SWIPL_PATH_SEP}${CMAKE_CURRENT_SOURCE_DIR}" 23 | -g "chr_compile_step${step}('${from}','${to}')" 24 | -t halt 25 | PARENT_SCOPE) 26 | endfunction() 27 | 28 | # Generate chr_translate_bootstrap1.pl 29 | chr_bootstrap(1 30 | chr_translate_bootstrap1 31 | CMD_1a) 32 | chr_bootstrap(2 33 | chr_translate_bootstrap1 34 | CMD_1b) 35 | # Generate chr_translate_bootstrap2.pl 36 | chr_bootstrap(2 37 | chr_translate_bootstrap2 38 | CMD_2a) 39 | chr_bootstrap(3 40 | chr_translate_bootstrap2 41 | CMD_2b) 42 | # Generate guard_entailment.pl 43 | chr_bootstrap(3 44 | guard_entailment 45 | CMD_3) 46 | # Generate chr_translate.pl 47 | chr_bootstrap(3 48 | chr_translate 49 | CMD_4a) 50 | chr_bootstrap(4 51 | guard_entailment 52 | CMD_4b) 53 | chr_bootstrap(4 54 | chr_translate 55 | CMD_4c) 56 | 57 | add_custom_command( 58 | OUTPUT chr_translate_bootstrap1.pl 59 | COMMAND ${PROG_SWIPL} ${CMD_1a} 60 | COMMAND ${PROG_SWIPL} ${CMD_1b} 61 | COMMENT "-- CHR bootstrap compilation step 1" 62 | DEPENDS core prolog_home 63 | chr_translate_bootstrap1.chr 64 | chr_translate_bootstrap.pl 65 | VERBATIM) 66 | add_custom_command( 67 | OUTPUT chr_translate_bootstrap2.pl 68 | COMMAND ${PROG_SWIPL} ${CMD_2a} 69 | COMMAND ${PROG_SWIPL} ${CMD_2b} 70 | COMMENT "-- CHR bootstrap compilation step 2" 71 | DEPENDS core prolog_home 72 | chr_translate_bootstrap2.chr 73 | ${CMAKE_CURRENT_BINARY_DIR}/chr_translate_bootstrap1.pl 74 | VERBATIM) 75 | add_custom_command( 76 | OUTPUT guard_entailment.pl 77 | COMMAND ${PROG_SWIPL} ${CMD_3} 78 | COMMENT "-- CHR bootstrap compilation step 3" 79 | DEPENDS core prolog_home 80 | guard_entailment.chr 81 | ${CMAKE_CURRENT_BINARY_DIR}/chr_translate_bootstrap2.pl 82 | VERBATIM) 83 | add_custom_command( 84 | OUTPUT chr_translate.pl 85 | COMMAND ${PROG_SWIPL} ${CMD_4a} 86 | COMMAND ${PROG_SWIPL} ${CMD_4b} 87 | COMMAND ${PROG_SWIPL} ${CMD_4c} 88 | COMMENT "-- CHR bootstrap compilation step 4" 89 | DEPENDS core prolog_home 90 | chr_translate.chr 91 | ${CMAKE_CURRENT_BINARY_DIR}/chr_translate_bootstrap2.pl 92 | ${CMAKE_CURRENT_BINARY_DIR}/guard_entailment.pl 93 | VERBATIM) 94 | add_custom_command( 95 | OUTPUT chr.pl 96 | COMMAND ${CMAKE_COMMAND} -E copy_if_different 97 | ${CMAKE_CURRENT_SOURCE_DIR}/chr_swi.pl chr.pl 98 | DEPENDS chr_swi.pl 99 | VERBATIM) 100 | 101 | add_custom_target( 102 | chr_compile ALL 103 | DEPENDS ${CHR_SOURCES_GENERATED} chr.pl 104 | VERBATIM) 105 | 106 | swipl_plugin(chr 107 | NOINDEX 108 | PL_GENERATED_LIBRARIES chr.pl 109 | PL_LIB_SUBDIR chr 110 | PL_LIBS ${CHR_SOURCES} 111 | PL_GENERATED_LIBRARIES ${CHR_SOURCES_GENERATED}) 112 | add_dependencies(chr chr_compile) 113 | 114 | swipl_examples(${CHR_EXAMPLES}) 115 | 116 | test_libs(chr) 117 | 118 | if(EMSCRIPTEN) 119 | install_in_wasm_preload(library chr.pl) 120 | install_in_wasm_preload(library/chr chr_translate.pl) 121 | install_in_wasm_preload(library/chr guard_entailment.pl) 122 | endif() 123 | -------------------------------------------------------------------------------- /binomialheap.pl: -------------------------------------------------------------------------------- 1 | /* Part of CHR (Constraint Handling Rules) 2 | 3 | Author: Tom Schrijvers 4 | E-mail: Tom.Schrijvers@cs.kuleuven.be 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2004-2011, K.U. Leuven 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | 2. Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in 18 | the documentation and/or other materials provided with the 19 | distribution. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | */ 34 | 35 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 36 | % Binomial Heap imlementation based on 37 | % 38 | % Functional Binomial Queues 39 | % James F. King 40 | % University of Glasgow 41 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 42 | 43 | :- module(binomialheap, 44 | [ 45 | empty_q/1, 46 | insert_q/3, 47 | insert_list_q/3, 48 | delete_min_q/3, 49 | find_min_q/2 50 | ]). 51 | 52 | :- use_module(library(lists),[reverse/2]). 53 | 54 | % data Tree a = Node a [Tree a] 55 | % type BinQueue a = [Maybe (Tree a)] 56 | % data Maybe a = Zero | One a 57 | % type Item = (Entry,Key) 58 | 59 | key(_-Key,Key). 60 | 61 | empty_q([]). 62 | 63 | meld_q(P,Q,R) :- 64 | meld_qc(P,Q,zero,R). 65 | 66 | meld_qc([],Q,zero,Q) :- !. 67 | meld_qc([],Q,C,R) :- !, 68 | meld_q(Q,[C],R). 69 | meld_qc(P,[],C,R) :- !, 70 | meld_qc([],P,C,R). 71 | meld_qc([zero|Ps],[zero|Qs],C,R) :- !, 72 | R = [C | Rs], 73 | meld_q(Ps,Qs,Rs). 74 | meld_qc([one(node(X,Xs))|Ps],[one(node(Y,Ys))|Qs],C,R) :- !, 75 | key(X,KX), 76 | key(Y,KY), 77 | ( KX < KY -> 78 | T = node(X,[node(Y,Ys)|Xs]) 79 | ; 80 | T = node(Y,[node(X,Xs)|Ys]) 81 | ), 82 | R = [C|Rs], 83 | meld_qc(Ps,Qs,one(T),Rs). 84 | meld_qc([P|Ps],[Q|Qs],C,Rs) :- 85 | meld_qc([Q|Ps],[C|Qs],P,Rs). 86 | 87 | insert_q(Q,I,NQ) :- 88 | meld_q([one(node(I,[]))],Q,NQ). 89 | 90 | insert_list_q([],Q,Q). 91 | insert_list_q([I|Is],Q,NQ) :- 92 | insert_q(Q,I,Q1), 93 | insert_list_q(Is,Q1,NQ). 94 | 95 | min_tree([T|Ts],MT) :- 96 | min_tree_acc(Ts,T,MT). 97 | 98 | min_tree_acc([],MT,MT). 99 | min_tree_acc([T|Ts],Acc,MT) :- 100 | least(T,Acc,NAcc), 101 | min_tree_acc(Ts,NAcc,MT). 102 | 103 | least(zero,T,T) :- !. 104 | least(T,zero,T) :- !. 105 | least(one(node(X,Xs)),one(node(Y,Ys)),T) :- 106 | key(X,KX), 107 | key(Y,KY), 108 | ( KX < KY -> 109 | T = one(node(X,Xs)) 110 | ; 111 | T = one(node(Y,Ys)) 112 | ). 113 | 114 | remove_tree([],_,[]). 115 | remove_tree([T|Ts],I,[NT|NTs]) :- 116 | ( T == zero -> 117 | NT = T 118 | ; 119 | T = one(node(X,_)), 120 | ( X == I -> 121 | NT = zero 122 | ; 123 | NT = T 124 | ) 125 | ), 126 | remove_tree(Ts,I,NTs). 127 | 128 | delete_min_q(Q,NQ,Min) :- 129 | min_tree(Q,one(node(Min,Ts))), 130 | remove_tree(Q,Min,Q1), 131 | reverse(Ts,RTs), 132 | make_ones(RTs,Q2), 133 | meld_q(Q2,Q1,NQ). 134 | 135 | make_ones([],[]). 136 | make_ones([N|Ns],[one(N)|RQ]) :- 137 | make_ones(Ns,RQ). 138 | 139 | find_min_q(Q,I) :- 140 | min_tree(Q,one(node(I,_))). 141 | 142 | 143 | -------------------------------------------------------------------------------- /Examples/listdom.chr: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | %% 3 | %% Slim Abdennadher, Thom Fruehwirth, LMU, July 1998 4 | %% Finite (enumeration, list) domain solver over integers 5 | %% 6 | %% * ported to hProlog by Tom Schrijvers, K.U.Leuven 7 | 8 | % :- module(listdom,[]). 9 | 10 | :- use_module( library(chr)). 11 | 12 | :- use_module( library(lists)). 13 | 14 | 15 | %% for domain constraints 16 | :- op( 700,xfx,'::'). 17 | :- op( 600,xfx,'..'). 18 | 19 | %% for inequality constraints 20 | :- op( 700,xfx,lt). 21 | :- op( 700,xfx,le). 22 | :- op( 700,xfx,ne). 23 | 24 | %% for domain constraints 25 | ?- op( 700,xfx,'::'). 26 | ?- op( 600,xfx,'..'). 27 | 28 | %% for inequality constraints 29 | ?- op( 700,xfx,lt). 30 | ?- op( 700,xfx,le). 31 | ?- op( 700,xfx,ne). 32 | 33 | :- constraints (::)/2, (le)/2, (lt)/2, (ne)/2, add/3, mult/3. 34 | %% X::Dom - X must be element of the finite list domain Dom 35 | 36 | %% special cases 37 | X::[] <=> fail. 38 | %%X::[Y] <=> X=Y. 39 | %%X::[A|L] <=> ground(X) | (member(X,[A|L]) -> true). 40 | 41 | %% intersection of domains for the same variable 42 | X::L1, X::L2 <=> is_list(L1), is_list(L2) | 43 | intersection(L1,L2,L) , X::L. 44 | 45 | X::L, X::Min..Max <=> is_list(L) | 46 | remove_lower(Min,L,L1), remove_higher(Max,L1,L2), 47 | X::L2. 48 | 49 | 50 | %% interaction with inequalities 51 | 52 | X le Y, X::L1, Y::L2 ==> is_list(L1),is_list(L2), 53 | min_list(L1,MinX), min_list(L2,MinY), MinX > MinY | 54 | max_list(L2,MaxY), Y::MinX..MaxY. 55 | X le Y, X::L1, Y::L2 ==> is_list(L1),is_list(L2), 56 | max_list(L1,MaxX), max_list(L2,MaxY), MaxX > MaxY | 57 | min_list(L1,MinX), X::MinX..MaxY. 58 | 59 | X lt Y, X::L1, Y::L2 ==> is_list(L1), is_list(L2), 60 | max_list(L1,MaxX), max_list(L2,MaxY), 61 | MaxY1 is MaxY - 1, MaxY1 < MaxX | 62 | min_list(L1,MinX), X::MinX..MaxY1. 63 | X lt Y, X::L1, Y::L2 ==> is_list(L1), is_list(L2), 64 | min_list(L1,MinX), min_list(L2,MinY), 65 | MinX1 is MinX + 1, MinX1 > MinY | 66 | max_list(L2,MaxY), Y :: MinX1..MaxY. 67 | 68 | X ne Y \ Y::D <=> ground(X), is_list(D), member(X,D) | select(X,D,D1), Y::D1. 69 | Y ne X \ Y::D <=> ground(X), is_list(D), member(X,D) | select(X,D,D1), Y::D1. 70 | Y::D \ X ne Y <=> ground(X), is_list(D), \+ member(X,D) | true. 71 | Y::D \ Y ne X <=> ground(X), is_list(D), \+ member(X,D) | true. 72 | 73 | 74 | %% interaction with addition 75 | %% no backpropagation yet! 76 | 77 | add(X,Y,Z), X::L1, Y::L2 ==> is_list(L1), is_list(L2) | 78 | all_addition(L1,L2,L3), Z::L3. 79 | 80 | %% interaction with multiplication 81 | %% no backpropagation yet! 82 | 83 | mult(X,Y,Z), X::L1, Y::L2 ==> is_list(L1), is_list(L2) | 84 | all_multiplication(L1,L2,L3), Z::L3. 85 | 86 | 87 | %% auxiliary predicates ============================================= 88 | 89 | remove_lower(_,[],L1):- !, L1=[]. 90 | remove_lower(Min,[X|L],L1):- 91 | X@Max, 100 | !, 101 | remove_higher(Max,L,L1). 102 | remove_higher(Max,[X|L],[X|L1]):- 103 | remove_higher(Max,L,L1). 104 | 105 | intersection([], _, []). 106 | intersection([Head|L1tail], L2, L3) :- 107 | memberchk(Head, L2), 108 | !, 109 | L3 = [Head|L3tail], 110 | intersection(L1tail, L2, L3tail). 111 | intersection([_|L1tail], L2, L3) :- 112 | intersection(L1tail, L2, L3). 113 | 114 | all_addition(L1,L2,L3) :- 115 | setof(Z, X^Y^(member(X,L1), member(Y,L2), Z is X + Y), L3). 116 | 117 | all_multiplication(L1,L2,L3) :- 118 | setof(Z, X^Y^(member(X,L1), member(Y,L2), Z is X * Y), L3). 119 | 120 | 121 | %% EXAMPLE ========================================================== 122 | 123 | /* 124 | ?- X::[1,2,3,4,5,6,7], Y::[2,4,6,7,8,0], Y lt X, X::4..9, X ne Y, 125 | add(X,Y,Z), mult(X,Y,Z). 126 | */ 127 | 128 | %% end of handler listdom.pl ================================================= 129 | %% =========================================================================== 130 | 131 | 132 | /* 133 | 134 | ?- X::[1,2,3,4,5,6,7], Y::[2,4,6,7,8,0], Y lt X, X::4..9, X ne Y, 135 | add(X,Y,Z), mult(X,Y,Z). 136 | 137 | Bad call to builtin predicate: _9696 =.. ['add/3__0',AttVar4942,AttVar5155,AttVar6836|_9501] in predicate mknewterm / 3 138 | */ -------------------------------------------------------------------------------- /chr_integertable_store.pl: -------------------------------------------------------------------------------- 1 | /* Part of CHR (Constraint Handling Rules) 2 | 3 | Author: Jon Sneyers 4 | E-mail: Jon.Sneyers@cs.kuleuven.be 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2006-2011, K.U. Leuven 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | 2. Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in 18 | the documentation and/or other materials provided with the 19 | distribution. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | */ 34 | 35 | % based on chr_hashtable_store (by Tom Schrijvers) 36 | % is it safe to use nb_setarg here? 37 | 38 | :- module(chr_integertable_store, 39 | [ new_iht/1, 40 | lookup_iht/3, 41 | insert_iht/3, 42 | delete_iht/3, 43 | value_iht/2 44 | ]). 45 | :- use_module(library(lists)). 46 | :- use_module(library(dialect/hprolog)). 47 | 48 | %initial_capacity(65536). 49 | %initial_capacity(1024). 50 | initial_capacity(8). 51 | %initial_capacity(2). 52 | %initial_capacity(1). 53 | 54 | 55 | new_iht(HT) :- 56 | initial_capacity(Capacity), 57 | new_iht(Capacity,HT). 58 | 59 | new_iht(Capacity,HT) :- 60 | functor(T1,t,Capacity), 61 | HT = ht(Capacity,Table), 62 | Table = T1. 63 | 64 | lookup_iht(ht(_,Table),Int,Values) :- 65 | Index is Int + 1, 66 | arg(Index,Table,Values), 67 | Values \= []. 68 | % nonvar(Values). 69 | 70 | insert_iht(HT,Int,Value) :- 71 | Index is Int + 1, 72 | arg(2,HT,Table), 73 | (arg(Index,Table,Bucket) -> 74 | ( var(Bucket) -> 75 | Bucket = [Value] 76 | ; 77 | setarg(Index,Table,[Value|Bucket]) 78 | ) 79 | ; % index > capacity 80 | Capacity is 1< 90 | setarg(Index,Table,[]) 91 | ; 92 | delete_first_fail(Bucket,Value,NBucket), 93 | setarg(Index,Table,NBucket) 94 | ). 95 | %delete_first_fail([], Y, []). 96 | %delete_first_fail([_], _, []) :- !. 97 | delete_first_fail([X | Xs], Y, Xs) :- 98 | X == Y, !. 99 | delete_first_fail([X | Xs], Y, [X | Zs]) :- 100 | delete_first_fail(Xs, Y, Zs). 101 | 102 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 103 | value_iht(HT,Value) :- 104 | HT = ht(Capacity,Table), 105 | value_iht(1,Capacity,Table,Value). 106 | 107 | value_iht(I,N,Table,Value) :- 108 | I =< N, 109 | arg(I,Table,Bucket), 110 | ( 111 | nonvar(Bucket), 112 | member(Value,Bucket) 113 | ; 114 | J is I + 1, 115 | value_iht(J,N,Table,Value) 116 | ). 117 | 118 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 119 | 120 | expand_iht(HT,NewCapacity) :- 121 | HT = ht(Capacity,Table), 122 | functor(NewTable,t,NewCapacity), 123 | setarg(1,HT,NewCapacity), 124 | setarg(2,HT,NewTable), 125 | expand_copy(Table,1,Capacity,NewTable,NewCapacity). 126 | 127 | expand_copy(Table,I,N,NewTable,NewCapacity) :- 128 | ( I > N -> 129 | true 130 | ; 131 | arg(I,Table,Bucket), 132 | ( var(Bucket) -> 133 | true 134 | ; 135 | arg(I,NewTable,Bucket) 136 | ), 137 | J is I + 1, 138 | expand_copy(Table,J,N,NewTable,NewCapacity) 139 | ). 140 | -------------------------------------------------------------------------------- /Tests/zebra.chr: -------------------------------------------------------------------------------- 1 | :- module(zebra,[zebra/0]). 2 | :- use_module(library(chr)). 3 | 4 | :- use_module(library(lists)). 5 | 6 | /* 7 | 1. The Englishman lives in the red house. 8 | 2. The Spaniard owns the dog. 9 | 3. Coffee is drunk in the green house. 10 | 4. The Ukrainian drinks tea. 11 | 5. The green house is immediately to the right of the ivory house. 12 | 6. The Porsche driver owns snails. 13 | 7. The Masserati is driven by the man who lives in the yellow house. 14 | 8. Milk is drunk in the middle house. 15 | 9. The Norwegian lives in the first house on the left. 16 | 10. The man who drives a Saab lives in the house next to the man 17 | with the fox. 18 | 11. The Masserati is driven by the man in the house next to the 19 | house where the horse is kept. 20 | 12. The Honda driver drinks orange juice. 21 | 13. The Japanese drives a Jaguar. 22 | 14. The Norwegian lives next to the blue house. 23 | */ 24 | 25 | :- chr_constraint domain/2, diff/2, cleanup/0. 26 | 27 | zebra :- 28 | solve(Solution), 29 | cleanup, 30 | Solution == [[yellow,norwegian,masserati,water,fox],[blue,ukranian,saab,tea,horse],[red,english,porsche,milk,snails],[ivory,spanish,honda,orange,dog],[green,japanese,jaguar,coffee,zebra]]. 31 | 32 | domain(_X,[]) <=> fail. 33 | domain(X,[V]) <=> X = V. 34 | domain(X,L1), domain(X,L2) <=> intersection(L1,L2,L3), domain(X,L3). 35 | 36 | diff(X,Y), domain(X,L) <=> nonvar(Y) | select(Y,L,NL), domain(X,NL). 37 | diff(X,Y) <=> nonvar(X), nonvar(Y) | X \== Y. 38 | 39 | cleanup, domain(_,_) <=> writeln(a), fail. 40 | cleanup, diff(_,_) <=> writeln(b), fail. 41 | cleanup <=> true. 42 | 43 | all_different([]). 44 | all_different([H|T]) :- 45 | all_different(T,H), 46 | all_different(T). 47 | 48 | all_different([],_). 49 | all_different([H|T],E) :- 50 | diff(H,E), 51 | diff(E,H), 52 | all_different(T,E). 53 | 54 | solve(S) :- 55 | [ [ ACo, AN, ACa, AD, AP ], 56 | [ BCo, BN, BCa, BD, BP ], 57 | [ CCo, CN, CCa, CD, CP ], 58 | [ DCo, DN, DCa, DD, DP ], 59 | [ ECo, EN, ECa, ED, EP ] ] = S, 60 | domain(ACo,[red,green,ivory,yellow,blue]), 61 | domain(BCo,[red,green,ivory,yellow,blue]), 62 | domain(CCo,[red,green,ivory,yellow,blue]), 63 | domain(DCo,[red,green,ivory,yellow,blue]), 64 | domain(ECo,[red,green,ivory,yellow,blue]), 65 | domain(AN ,[english,spanish,ukranian,norwegian,japanese]), 66 | domain(BN ,[english,spanish,ukranian,norwegian,japanese]), 67 | domain(CN ,[english,spanish,ukranian,norwegian,japanese]), 68 | domain(DN ,[english,spanish,ukranian,norwegian,japanese]), 69 | domain(EN ,[english,spanish,ukranian,norwegian,japanese]), 70 | domain(ACa,[porsche,masserati,saab,honda,jaguar]), 71 | domain(BCa,[porsche,masserati,saab,honda,jaguar]), 72 | domain(CCa,[porsche,masserati,saab,honda,jaguar]), 73 | domain(DCa,[porsche,masserati,saab,honda,jaguar]), 74 | domain(ECa,[porsche,masserati,saab,honda,jaguar]), 75 | domain(AD ,[coffee,tea,milk,orange,water]), 76 | domain(BD ,[coffee,tea,milk,orange,water]), 77 | domain(CD ,[coffee,tea,milk,orange,water]), 78 | domain(DD ,[coffee,tea,milk,orange,water]), 79 | domain(ED ,[coffee,tea,milk,orange,water]), 80 | domain(AP ,[dog,snails,fox,horse,zebra]), 81 | domain(BP ,[dog,snails,fox,horse,zebra]), 82 | domain(CP ,[dog,snails,fox,horse,zebra]), 83 | domain(DP ,[dog,snails,fox,horse,zebra]), 84 | domain(EP ,[dog,snails,fox,horse,zebra]), 85 | all_different([ACo,BCo,CCo,DCo,ECo]), 86 | all_different([AN ,BN ,CN ,DN ,EN ]), 87 | all_different([ACa,BCa,CCa,DCa,ECa]), 88 | all_different([AD ,BD ,CD ,DD ,ED ]), 89 | all_different([AP ,BP ,CP ,DP ,EP ]), 90 | [_,_,[_,_,_,milk,_],_,_] = S, % clue 8 91 | [[_,norwegian,_,_,_],_,_,_,_] = S , % clue 9 92 | member( [green,_,_,coffee,_], S), % clue 3 93 | member( [red,english,_,_,_], S), % clue 1 94 | member( [_,ukranian,_,tea,_], S), % clue 4 95 | member( [yellow,_,masserati,_,_], S), % clue 7 96 | member( [_,_,honda,orange,_], S), % clue 12 97 | member( [_,japanese,jaguar,_,_], S), % clue 13 98 | member( [_,spanish,_,_,dog], S), % clue 2 99 | member( [_,_,porsche,_,snails], S), % clue 6 100 | left_right( [ivory,_,_,_,_], [green,_,_,_,_], S), % clue 5 101 | next_to( [_,norwegian,_,_,_],[blue,_,_,_,_], S), % clue 14 102 | next_to( [_,_,masserati,_,_],[_,_,_,_,horse], S), % clue 11 103 | next_to( [_,_,saab,_,_], [_,_,_,_,fox], S), % clue 10 104 | true. 105 | 106 | % left_right(L, R, X) is true when L is to the immediate left of R in list X 107 | 108 | left_right(L, R, [L, R | _]). 109 | 110 | left_right(L, R, [_ | X]) :- left_right(L, R, X). 111 | 112 | 113 | % next_to(X, Y, L) is true when X and Y are next to each other in list L 114 | 115 | next_to(X, Y, L) :- left_right(X, Y, L). 116 | 117 | next_to(X, Y, L) :- left_right(Y, X, L). 118 | -------------------------------------------------------------------------------- /Benchmarks/zebra.chr: -------------------------------------------------------------------------------- 1 | :- module(zebra,[main/0, main/1]). 2 | 3 | :- use_module(library(chr)). 4 | :- use_module(library(lists)). 5 | 6 | /* 7 | 1. The Englishman lives in the red house. 8 | 2. The Spaniard owns the dog. 9 | 3. Coffee is drunk in the green house. 10 | 4. The Ukrainian drinks tea. 11 | 5. The green house is immediately to the right of the ivory house. 12 | 6. The Porsche driver owns snails. 13 | 7. The Masserati is driven by the man who lives in the yellow house. 14 | 8. Milk is drunk in the middle house. 15 | 9. The Norwegian lives in the first house on the left. 16 | 10. The man who drives a Saab lives in the house next to the man 17 | with the fox. 18 | 11. The Masserati is driven by the man in the house next to the 19 | house where the horse is kept. 20 | 12. The Honda driver drinks orange juice. 21 | 13. The Japanese drives a Jaguar. 22 | 14. The Norwegian lives next to the blue house. 23 | */ 24 | 25 | :- chr_constraint domain/2, diff/2. 26 | 27 | domain(_,[]) <=> fail. 28 | domain(X,[V]) <=> X = V. 29 | domain(X,L1), domain(X,L2) <=> intersection(L1,L2,L3), domain(X,L3). 30 | 31 | diff(X,Y), domain(X,L) <=> nonvar(Y) | delete(L,Y,NL), domain(X,NL). 32 | diff(X,Y) <=> nonvar(X), nonvar(Y) | X \== Y. 33 | 34 | all_different([]). 35 | all_different([H|T]) :- 36 | all_different(T,H), 37 | all_different(T). 38 | 39 | all_different([],_). 40 | all_different([H|T],E) :- 41 | diff(H,E), 42 | diff(E,H), 43 | all_different(T,E). 44 | 45 | main :- 46 | main(10). 47 | 48 | main(N):- 49 | statistics(cputime, X), 50 | test(N), 51 | statistics(cputime, Now), 52 | Time is Now-X, 53 | write(bench(zebra, N,Time,0,hprolog)), write('.'),nl. 54 | 55 | test(N) :- 56 | ( N > 0 -> 57 | solve,!, 58 | M is N - 1, 59 | test(M) 60 | ; 61 | true 62 | ). 63 | 64 | solve :- 65 | [ [ ACo, AN, ACa, AD, AP ], 66 | [ BCo, BN, BCa, BD, BP ], 67 | [ CCo, CN, CCa, CD, CP ], 68 | [ DCo, DN, DCa, DD, DP ], 69 | [ ECo, EN, ECa, ED, EP ] ] = S, 70 | domain(ACo,[red,green,ivory,yellow,blue]), 71 | domain(BCo,[red,green,ivory,yellow,blue]), 72 | domain(CCo,[red,green,ivory,yellow,blue]), 73 | domain(DCo,[red,green,ivory,yellow,blue]), 74 | domain(ECo,[red,green,ivory,yellow,blue]), 75 | domain(AN ,[english,spanish,ukranian,norwegian,japanese]), 76 | domain(BN ,[english,spanish,ukranian,norwegian,japanese]), 77 | domain(CN ,[english,spanish,ukranian,norwegian,japanese]), 78 | domain(DN ,[english,spanish,ukranian,norwegian,japanese]), 79 | domain(EN ,[english,spanish,ukranian,norwegian,japanese]), 80 | domain(ACa,[porsche,masserati,saab,honda,jaguar]), 81 | domain(BCa,[porsche,masserati,saab,honda,jaguar]), 82 | domain(CCa,[porsche,masserati,saab,honda,jaguar]), 83 | domain(DCa,[porsche,masserati,saab,honda,jaguar]), 84 | domain(ECa,[porsche,masserati,saab,honda,jaguar]), 85 | domain(AD ,[coffee,tea,milk,orange,water]), 86 | domain(BD ,[coffee,tea,milk,orange,water]), 87 | domain(CD ,[coffee,tea,milk,orange,water]), 88 | domain(DD ,[coffee,tea,milk,orange,water]), 89 | domain(ED ,[coffee,tea,milk,orange,water]), 90 | domain(AP ,[dog,snails,fox,horse,zebra]), 91 | domain(BP ,[dog,snails,fox,horse,zebra]), 92 | domain(CP ,[dog,snails,fox,horse,zebra]), 93 | domain(DP ,[dog,snails,fox,horse,zebra]), 94 | domain(EP ,[dog,snails,fox,horse,zebra]), 95 | all_different([ACo,BCo,CCo,DCo,ECo]), 96 | all_different([AN ,BN ,CN ,DN ,EN ]), 97 | all_different([ACa,BCa,CCa,DCa,ECa]), 98 | all_different([AD ,BD ,CD ,DD ,ED ]), 99 | all_different([AP ,BP ,CP ,DP ,EP ]), 100 | [_,_,[_,_,_,milk,_],_,_] = S, % clue 8 101 | [[_,norwegian,_,_,_],_,_,_,_] = S , % clue 9 102 | member( [green,_,_,coffee,_], S), % clue 3 103 | member( [red,english,_,_,_], S), % clue 1 104 | member( [_,ukranian,_,tea,_], S), % clue 4 105 | member( [yellow,_,masserati,_,_], S), % clue 7 106 | member( [_,_,honda,orange,_], S), % clue 12 107 | member( [_,japanese,jaguar,_,_], S), % clue 13 108 | member( [_,spanish,_,_,dog], S), % clue 2 109 | member( [_,_,porsche,_,snails], S), % clue 6 110 | left_right( [ivory,_,_,_,_], [green,_,_,_,_], S), % clue 5 111 | next_to( [_,norwegian,_,_,_],[blue,_,_,_,_], S), % clue 14 112 | next_to( [_,_,masserati,_,_],[_,_,_,_,horse], S), % clue 11 113 | next_to( [_,_,saab,_,_], [_,_,_,_,fox], S), % clue 10 114 | true. 115 | 116 | % left_right(L, R, X) is true when L is to the immediate left of R in list X 117 | 118 | left_right(L, R, [L, R | _]). 119 | 120 | left_right(L, R, [_ | X]) :- left_right(L, R, X). 121 | 122 | 123 | % next_to(X, Y, L) is true when X and Y are next to each other in list L 124 | 125 | next_to(X, Y, L) :- left_right(X, Y, L). 126 | 127 | next_to(X, Y, L) :- left_right(Y, X, L). 128 | -------------------------------------------------------------------------------- /chr_messages.pl: -------------------------------------------------------------------------------- 1 | /* Part of CHR (Constraint Handling Rules) 2 | 3 | Author: Jan Wielemaker and Tom Schrijvers 4 | E-mail: Tom.Schrijvers@cs.kuleuven.be 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2004-2011, K.U. Leuven 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | 2. Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in 18 | the documentation and/or other materials provided with the 19 | distribution. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | */ 34 | 35 | :- module(chr_messages, 36 | [ chr_message/3 % +CHR Message, Out, Rest 37 | ]). 38 | :- use_module(chr(chr_runtime)). 39 | 40 | :- discontiguous 41 | chr_message/3. 42 | 43 | % compiler messages 44 | 45 | chr_message(compilation_failed(From)) --> 46 | [ 'CHR Failed to compile ~w'-[From] ]. 47 | 48 | % debug messages 49 | 50 | chr_message(prompt) --> 51 | [ at_same_line, ' ? ', flush ]. 52 | chr_message(command(Command)) --> 53 | [ at_same_line, '[~w]'-[Command] ]. 54 | chr_message(invalid_command) --> 55 | [ nl, 'CHR: Not a valid debug option. Use ? for help.' ]. 56 | chr_message(debug_options) --> 57 | { bagof(Ls-Cmd, 58 | bagof(L, 'chr debug command'(L, Cmd), Ls), 59 | Lines) 60 | }, 61 | [ 'CHR Debugger commands:', nl, nl ], 62 | debug_commands(Lines), 63 | [ nl ]. 64 | 65 | debug_commands([]) --> 66 | []. 67 | debug_commands([Ls-Cmd|T]) --> 68 | [ '\t' ], chars(Ls), [ '~t~28|~w'-[Cmd], nl ], 69 | debug_commands(T). 70 | 71 | chars([C]) --> !, 72 | char(C). 73 | chars([C|T]) --> 74 | char(C), [', '], 75 | chars(T). 76 | 77 | char(' ') --> !, ['']. 78 | char('\r') --> !, ['']. 79 | char(end_of_file) --> !, ['EOF']. 80 | char(C) --> [C]. 81 | 82 | 83 | chr_message(ancestors(History, Depth)) --> 84 | [ 'CHR Ancestors:', nl ], 85 | ancestors(History, Depth). 86 | 87 | ancestors([], _) --> 88 | []. 89 | ancestors([Event|Events], Depth) --> 90 | [ '\t' ], event(Event, Depth), [ nl ], 91 | { NDepth is Depth - 1 92 | }, 93 | ancestors(Events, NDepth). 94 | 95 | 96 | % debugging ports 97 | 98 | chr_message(event(Port, Depth)) --> 99 | [ 'CHR: ' ], 100 | event(Port, Depth), 101 | [ flush ]. % do not emit a newline 102 | 103 | event(Port, Depth) --> 104 | depth(Depth), 105 | port(Port). 106 | event(apply(H1,H2,G,B), Depth) --> 107 | depth(Depth), 108 | [ 'Apply: ' ], 109 | rule(H1,H2,G,B). 110 | event(try(H1,H2,G,B), Depth) --> 111 | depth(Depth), 112 | [ 'Try: ' ], 113 | rule(H1,H2,G,B). 114 | event(insert(#(_,Susp)), Depth) --> 115 | depth(Depth), 116 | [ 'Insert: ' ], 117 | head(Susp). 118 | 119 | port(call(Susp)) --> 120 | [ 'Call: ' ], 121 | head(Susp). 122 | port(wake(Susp)) --> 123 | [ 'Wake: ' ], 124 | head(Susp). 125 | port(exit(Susp)) --> 126 | [ 'Exit: ' ], 127 | head(Susp). 128 | port(fail(Susp)) --> 129 | [ 'Fail: ' ], 130 | head(Susp). 131 | port(redo(Susp)) --> 132 | [ 'Redo: ' ], 133 | head(Susp). 134 | port(remove(Susp)) --> 135 | [ 'Remove: ' ], 136 | head(Susp). 137 | 138 | 139 | depth(Depth) --> 140 | [ '~t(~D)~10| '-[Depth] ]. 141 | 142 | head(Susp) --> 143 | { Susp =.. [_,ID,_,_,_,_|GoalArgs], Goal =.. GoalArgs 144 | }, 145 | [ '~w # <~w>'-[Goal, ID] ]. 146 | 147 | heads([H]) --> !, 148 | head(H). 149 | heads([H|T]) --> 150 | head(H), 151 | [ ', ' ], 152 | heads(T). 153 | 154 | 155 | % rule(H1, H2, G, B) 156 | % 157 | % Produce text for the CHR rule "H1 \ H2 [<=]=> G | B" 158 | 159 | rule(H1, H2, G, B) --> 160 | rule_head(H1, H2), 161 | rule_body(G, B). 162 | 163 | rule_head([], H2) --> !, 164 | heads(H2), 165 | [ ' ==> ' ]. 166 | rule_head(H1, []) --> !, 167 | heads(H1), 168 | [ ' <=> ' ]. 169 | rule_head(H1, H2) --> 170 | heads(H2), [ ' \\ ' ], heads(H1), [' <=> ']. 171 | 172 | 173 | rule_body(true, B) --> !, 174 | [ '~w.'-[B] ]. 175 | rule_body(G, B) --> 176 | [ '~w | ~w.'-[G, B] ]. 177 | -------------------------------------------------------------------------------- /test_chr.pl: -------------------------------------------------------------------------------- 1 | /* Part of CHR (Constraint Handling Rules) 2 | 3 | Author: Jan Wielemaker 4 | E-mail: J.Wielemaker@vu.nl 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2004-2018, University of Amsterdam 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | 2. Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in 18 | the documentation and/or other materials provided with the 19 | distribution. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | */ 34 | 35 | :- module(test_chr, 36 | [ test_chr/0 37 | ]). 38 | 39 | :- asserta(user:file_search_path(chr, '.')). 40 | :- asserta(user:file_search_path(library, '.')). 41 | % ctest adds a foreign path to the cmake binary directory 42 | :- asserta(user:file_search_path(chr, foreign('.'))). 43 | :- asserta(user:file_search_path(library, foreign('.'))). 44 | :- use_module(library(chr)). 45 | %% :- use_module(chr). % == library(chr) 46 | 47 | :- set_prolog_flag(optimise, true). 48 | %:- set_prolog_flag(trace_gc, true). 49 | 50 | :- format('CHR test suite. To run all tests run ?- test.~n~n', []). 51 | 52 | /******************************* 53 | * SCRIPTS * 54 | *******************************/ 55 | 56 | 57 | :- dynamic 58 | script_dir/1. 59 | 60 | set_script_dir :- 61 | script_dir(_), !. 62 | set_script_dir :- 63 | find_script_dir(Dir), 64 | assert(script_dir(Dir)). 65 | 66 | find_script_dir(Dir) :- 67 | prolog_load_context(file, File), 68 | follow_links(File, RealFile), 69 | file_directory_name(RealFile, Dir). 70 | 71 | follow_links(File, RealFile) :- 72 | read_link(File, _, RealFile), !. 73 | follow_links(File, File). 74 | 75 | 76 | :- set_script_dir. 77 | 78 | run_test_script(Script) :- 79 | file_base_name(Script, Base), 80 | file_name_extension(Pred, _, Base), 81 | format(' ~w~n',[Script]), 82 | load_files(Script, []), %[silent(true)]), 83 | Pred. 84 | 85 | run_test_scripts(Directory) :- 86 | ( script_dir(ScriptDir), 87 | atomic_list_concat([ScriptDir, /, Directory], Dir), 88 | exists_directory(Dir) 89 | -> true 90 | ; Dir = Directory 91 | ), 92 | atom_concat(Dir, '/*.chr', Pattern), 93 | expand_file_name(Pattern, Files), 94 | file_base_name(Dir, BaseDir), 95 | format('Running scripts from ~w ', [BaseDir]), flush_output, 96 | run_scripts(Files), 97 | format(' done~n'). 98 | 99 | run_scripts([]). 100 | run_scripts([H|T]) :- 101 | ( catch(run_test_script(H), Except, true) 102 | -> ( var(Except) 103 | -> put(.), flush_output 104 | ; Except = blocked(Reason) 105 | -> assert(blocked(H, Reason)), 106 | put(!), flush_output 107 | ; script_failed(H, Except) 108 | ) 109 | ; script_failed(H, fail) 110 | ), 111 | run_scripts(T). 112 | 113 | script_failed(File, fail) :- 114 | format('~NScript ~w failed~n', [File]), 115 | assert(failed(script(File))). 116 | script_failed(File, Except) :- 117 | message_to_string(Except, Error), 118 | format('~NScript ~w failed: ~w~n', [File, Error]), 119 | assert(failed(script(File))). 120 | 121 | 122 | /******************************* 123 | * TEST MAIN-LOOP * 124 | *******************************/ 125 | 126 | testdir('Tests'). 127 | 128 | :- dynamic 129 | failed/1, 130 | blocked/2. 131 | 132 | test_chr :- 133 | retractall(failed(_)), 134 | retractall(blocked(_,_)), 135 | scripts, 136 | report_blocked, 137 | report_failed. 138 | 139 | scripts :- 140 | forall(testdir(Dir), run_test_scripts(Dir)). 141 | 142 | 143 | report_blocked :- 144 | findall(Head-Reason, blocked(Head, Reason), L), 145 | ( L \== [] 146 | -> format('~nThe following tests are blocked:~n', []), 147 | ( member(Head-Reason, L), 148 | format(' ~p~t~40|~w~n', [Head, Reason]), 149 | fail 150 | ; true 151 | ) 152 | ; true 153 | ). 154 | report_failed :- 155 | findall(X, failed(X), L), 156 | length(L, Len), 157 | ( Len > 0 158 | -> format('~n*** ~w tests failed ***~n', [Len]), 159 | fail 160 | ; format('~nAll tests passed~n', []) 161 | ). 162 | 163 | test_failed(R, Except) :- 164 | clause(Head, _, R), 165 | functor(Head, Name, 1), 166 | arg(1, Head, TestName), 167 | clause_property(R, line_count(Line)), 168 | clause_property(R, file(File)), 169 | ( Except == fail 170 | -> format('~N~w:~d: Test ~w(~w) failed~n', 171 | [File, Line, Name, TestName]) 172 | ; message_to_string(Except, Error), 173 | format('~N~w:~d: Test ~w(~w):~n~t~8|ERROR: ~w~n', 174 | [File, Line, Name, TestName, Error]) 175 | ), 176 | assert(failed(Head)). 177 | 178 | blocked(Reason) :- 179 | throw(blocked(Reason)). 180 | 181 | -------------------------------------------------------------------------------- /Examples/deadcode.pl: -------------------------------------------------------------------------------- 1 | /* Part of CHR (Constraint Handling Rules) 2 | 3 | Author: Tom Schrijvers 4 | E-mail: Tom.Schrijvers@cs.kuleuven.be 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2005-2011, K.U. Leuven 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | 2. Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in 18 | the documentation and/or other materials provided with the 19 | distribution. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | */ 34 | 35 | :- module(deadcode,[deadcode/2]). 36 | 37 | :- use_module(library(chr)). 38 | 39 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 40 | :- constraints 41 | defined_predicate(+any), 42 | calls(+any,+any), 43 | live(+any), 44 | print_dead_predicates. 45 | 46 | defined_predicate(P) \ defined_predicate(P) <=> true. 47 | 48 | calls(P,Q) \ calls(P,Q) <=> true. 49 | 50 | live(P) \ live(P) <=> true. 51 | 52 | live(P), calls(P,Q) ==> live(Q). 53 | 54 | print_dead_predicates \ live(P), defined_predicate(P) <=> true. 55 | print_dead_predicates \ defined_predicate(P) <=> 56 | writeln(P). 57 | print_dead_predicates \ calls(_,_) <=> true. 58 | print_dead_predicates \ live(_) <=> true. 59 | print_dead_predicates <=> true. 60 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 61 | 62 | deadcode(File,Starts) :- 63 | readfile(File,Clauses), 64 | exported_predicates(Clauses,Exports), 65 | findall(C, ( member(C,Clauses), C \= (:- _) , C \= (?- _)), Cs), 66 | process_clauses(Cs), 67 | append(Starts,Exports,Alive), 68 | live_predicates(Alive), 69 | print_dead_predicates. 70 | 71 | exported_predicates(Clauses,Exports) :- 72 | ( member( (:- module(_, Exports)), Clauses) -> 73 | true 74 | ; 75 | Exports = [] 76 | ). 77 | process_clauses([]). 78 | process_clauses([C|Cs]) :- 79 | hb(C,H,B), 80 | extract_predicates(B,Ps,[]), 81 | functor(H,F,A), 82 | defined_predicate(F/A), 83 | calls_predicates(Ps,F/A), 84 | process_clauses(Cs). 85 | 86 | calls_predicates([],FA). 87 | calls_predicates([P|Ps],FA) :- 88 | calls(FA,P), 89 | calls_predicates(Ps,FA). 90 | 91 | hb(C,H,B) :- 92 | ( C = (H :- B) -> 93 | true 94 | ; 95 | C = H, 96 | B = true 97 | ). 98 | 99 | live_predicates([]). 100 | live_predicates([P|Ps]) :- 101 | live(P), 102 | live_predicates(Ps). 103 | 104 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 105 | extract_predicates(!,L,L) :- ! . 106 | extract_predicates(_ < _,L,L) :- ! . 107 | extract_predicates(_ = _,L,L) :- ! . 108 | extract_predicates(_ =.. _ ,L,L) :- ! . 109 | extract_predicates(_ =:= _,L,L) :- ! . 110 | extract_predicates(_ == _,L,L) :- ! . 111 | extract_predicates(_ > _,L,L) :- ! . 112 | extract_predicates(_ \= _,L,L) :- ! . 113 | extract_predicates(_ \== _,L,L) :- ! . 114 | extract_predicates(_ is _,L,L) :- ! . 115 | extract_predicates(arg(_,_,_),L,L) :- ! . 116 | extract_predicates(atom_concat(_,_,_),L,L) :- ! . 117 | extract_predicates(atomic(_),L,L) :- ! . 118 | extract_predicates(b_getval(_,_),L,L) :- ! . 119 | extract_predicates(call(_),L,L) :- ! . 120 | extract_predicates(compound(_),L,L) :- ! . 121 | extract_predicates(copy_term(_,_),L,L) :- ! . 122 | extract_predicates(del_attr(_,_),L,L) :- ! . 123 | extract_predicates(fail,L,L) :- ! . 124 | extract_predicates(functor(_,_,_),L,L) :- ! . 125 | extract_predicates(get_attr(_,_,_),L,L) :- ! . 126 | extract_predicates(length(_,_),L,L) :- ! . 127 | extract_predicates(nb_setval(_,_),L,L) :- ! . 128 | extract_predicates(nl,L,L) :- ! . 129 | extract_predicates(nonvar(_),L,L) :- ! . 130 | extract_predicates(once(G),L,T) :- !, 131 | ( nonvar(G) -> 132 | extract_predicates(G,L,T) 133 | ; 134 | L = T 135 | ). 136 | extract_predicates(op(_,_,_),L,L) :- ! . 137 | extract_predicates(prolog_flag(_,_),L,L) :- ! . 138 | extract_predicates(prolog_flag(_,_,_),L,L) :- ! . 139 | extract_predicates(put_attr(_,_,_),L,L) :- ! . 140 | extract_predicates(read(_),L,L) :- ! . 141 | extract_predicates(see(_),L,L) :- ! . 142 | extract_predicates(seen,L,L) :- ! . 143 | extract_predicates(setarg(_,_,_),L,L) :- ! . 144 | extract_predicates(tell(_),L,L) :- ! . 145 | extract_predicates(term_variables(_,_),L,L) :- ! . 146 | extract_predicates(told,L,L) :- ! . 147 | extract_predicates(true,L,L) :- ! . 148 | extract_predicates(var(_),L,L) :- ! . 149 | extract_predicates(write(_),L,L) :- ! . 150 | extract_predicates((G1,G2),L,T) :- ! , 151 | extract_predicates(G1,L,T1), 152 | extract_predicates(G2,T1,T). 153 | extract_predicates((G1->G2),L,T) :- !, 154 | extract_predicates(G1,L,T1), 155 | extract_predicates(G2,T1,T). 156 | extract_predicates((G1;G2),L,T) :- !, 157 | extract_predicates(G1,L,T1), 158 | extract_predicates(G2,T1,T). 159 | extract_predicates(\+ G, L, T) :- !, 160 | extract_predicates(G, L, T). 161 | extract_predicates(findall(_,G,_),L,T) :- !, 162 | extract_predicates(G,L,T). 163 | extract_predicates(bagof(_,G,_),L,T) :- !, 164 | extract_predicates(G,L,T). 165 | extract_predicates(_^G,L,T) :- !, 166 | extract_predicates(G,L,T). 167 | extract_predicates(_:Call,L,T) :- !, 168 | extract_predicates(Call,L,T). 169 | extract_predicates(Call,L,T) :- 170 | ( var(Call) -> 171 | L = T 172 | ; 173 | functor(Call,F,A), 174 | L = [F/A|T] 175 | ). 176 | 177 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 178 | %% 179 | %% File Reading 180 | 181 | readfile(File,Declarations) :- 182 | see(File), 183 | readcontent(Declarations), 184 | seen. 185 | 186 | readcontent(C) :- 187 | read(X), 188 | ( X = (:- op(Prec,Fix,Op)) -> 189 | op(Prec,Fix,Op) 190 | ; 191 | true 192 | ), 193 | ( X == end_of_file -> 194 | C = [] 195 | ; 196 | C = [X | Xs], 197 | readcontent(Xs) 198 | ). 199 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 200 | 201 | -------------------------------------------------------------------------------- /Benchmarks/wfs.chr: -------------------------------------------------------------------------------- 1 | :- module(wfs,[main/0, main/1]). 2 | 3 | :- use_module(library(chr)). 4 | :- use_module(library(lists)). 5 | 6 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 7 | % 8 | % Schrijf het programma waarvan je de wellfounded semantics wil bepalen 9 | % hieronder onder de vorm van prog/1 feiten. Let erop dat je een conjunctie 10 | % in de body tussen haakjes zet zodat prog/1 geparsed wordt, ipv prog/n. 11 | 12 | /* 13 | 14 | prog(p :- p). 15 | 16 | prog(p :- \+ p). 17 | 18 | 19 | prog(p :- (q, \+ r)). 20 | prog(q :- (r, \+ p)). 21 | prog(r :- (p, \+ q)). 22 | 23 | prog(p :- r). 24 | prog(r :- q). 25 | prog(q :- \+ q). 26 | 27 | prog(p :- r). 28 | prog(r). 29 | 30 | prog(p :- p). 31 | prog(s :- \+ p). 32 | prog(y :- (s, \+ x)). 33 | prog(x :- y). 34 | */ 35 | prog(a :- a). 36 | prog(b :- b). 37 | prog(b :- \+ a). 38 | prog(c :- \+ b). 39 | prog(c :- c). 40 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 41 | 42 | 43 | :- chr_constraint true/1, false/1, undefined/1, aclause/2, pos/2, neg/2, nbulit/2, nbplit/2, nbucl/2, phase2/0, true2/1, undefined2/1, aclause2/2, pos2/2, nbplit2/2, phase1/0, witness1/0, witness2/0. 44 | 45 | true(At), aclause(Cl,At) \ pos(_,Cl) <=> true. 46 | 47 | true(At), aclause(Cl,At) \ neg(_,Cl) <=> true. 48 | 49 | false(At), aclause(Cl,At) \ pos(_,Cl) <=> true. 50 | 51 | false(At), aclause(Cl,At) \ neg(_,Cl) <=> true. 52 | 53 | true(At) \ nbucl(At,_) <=> true. 54 | 55 | true(At) \ aclause(Cl,At), nbulit(Cl,_), nbplit(Cl,_) <=> true. 56 | 57 | false(At) \ nbucl(At,_) <=> true. 58 | 59 | nbucl(At,0) <=> false(At). 60 | 61 | aclause(Cl,At), nbulit(Cl,0), nbplit(Cl,0) <=> true(At). 62 | 63 | true(At) \ pos(At,Cl), nbulit(Cl,NU), nbplit(Cl,NP) 64 | <=> 65 | NU1 is NU - 1, nbulit(Cl,NU1), 66 | NP1 is NP - 1, nbplit(Cl,NP1). 67 | 68 | false(At) \ neg(At,Cl), nbulit(Cl,NU) 69 | <=> 70 | NU1 is NU - 1, nbulit(Cl,NU1). 71 | 72 | true(At) \ neg(At,Cl), aclause(Cl,OAt), nbulit(Cl,_), nbplit(Cl,_), nbucl(OAt,N) 73 | <=> 74 | N1 is N - 1, nbucl(OAt,N1). 75 | 76 | false(At) \ pos(At,Cl), aclause(Cl,OAt), nbulit(Cl,_), nbplit(Cl,_), nbucl(OAt,N) 77 | <=> 78 | N1 is N - 1, nbucl(OAt,N1). 79 | 80 | witness2 \ witness2 <=> true. 81 | phase2, nbucl(At,_) ==> witness2, undefined2(At). 82 | phase2, pos(At,Cl) ==> pos2(At,Cl). 83 | phase2, aclause(Cl,At) ==> aclause2(Cl,At). 84 | phase2, nbplit(Cl,N) ==> nbplit2(Cl,N). 85 | phase2, witness2 # ID <=> phase1 pragma passive(ID). 86 | phase2 \ nbplit2(_,_) # ID <=> true pragma passive(ID). 87 | phase2 \ aclause2(_,_) # ID <=> true pragma passive(ID). 88 | phase2 <=> true. 89 | 90 | 91 | true2(At), aclause2(Cl,At) \ pos2(_,Cl) <=> true. 92 | true2(At) \ undefined2(At) <=> true. 93 | aclause2(Cl,At), nbplit2(Cl,0) <=> true2(At). 94 | true2(At) \ pos2(At,Cl), nbplit2(Cl,NP) 95 | <=> 96 | NP1 is NP - 1, nbplit2(Cl,NP1). 97 | 98 | witness1 \ witness1 <=> true. 99 | phase1, undefined2(At) # ID1 , aclause(Cl,At) # ID2 \ pos(_,Cl) # ID3 <=> true pragma passive(ID1), passive(ID2), passive(ID3). 100 | phase1, undefined2(At) # ID1 , aclause(Cl,At) # ID2 \ neg(_,Cl) # ID3 <=> true pragma passive(ID1), passive(ID2), passive(ID3). 101 | phase1, undefined2(At) # ID1 \ aclause(Cl,At) # ID2 , nbulit(Cl,_) # ID3, nbplit(Cl,_) # ID4 <=> true pragma passive(ID1), passive(ID2), passive(ID3), passive(ID4). 102 | phase1 \ undefined2(At) # ID <=> witness1, false(At) pragma passive(ID). 103 | phase1 \ true2(_) # ID <=> true pragma passive(ID). 104 | phase1 \ aclause2(_,_) <=> true. 105 | phase1 \ pos2(_,_) # ID <=> true pragma passive(ID). 106 | phase1 \ nbplit2(_,_) # ID <=> true pragma passive(ID). 107 | phase1, witness1 # ID <=> phase2 pragma passive(ID). 108 | phase1 \ nbucl(At,_) # ID <=> undefined(At) pragma passive(ID). 109 | phase1 \ pos(_,_) # ID <=> true. 110 | phase1 \ neg(_,_) # ID <=> true pragma passive(ID). 111 | phase1 \ aclause(_,_) # ID <=> true pragma passive(ID). 112 | phase1 \ nbulit(_,_) # ID <=> true pragma passive(ID). 113 | phase1 \ nbplit(_,_) # ID <=> true pragma passive(ID). 114 | phase1 <=> true. 115 | 116 | /* 117 | p :- r. 118 | r. 119 | */ 120 | program1 :- 121 | nbucl(p,1), % aantal undefined clauses voor p 122 | pos(r,cl1), % positief voorkomen van r in clause cl1 123 | aclause(cl1,p), % clause cl1 defineert p 124 | nbulit(cl1,1), % aantal undefined literals in cl1 125 | nbplit(cl1,1), % aantal positieve undefined literals in cl1 126 | nbucl(r,1), 127 | aclause(cl2,r), 128 | nbulit(cl2,0), 129 | nbplit(cl2,0). 130 | 131 | /* 132 | p :- not r. 133 | r. 134 | */ 135 | program2 :- 136 | nbucl(p,1), 137 | neg(r,cl1), 138 | aclause(cl1,p), 139 | nbulit(cl1,1), 140 | nbplit(cl1,1), 141 | nbucl(r,1), 142 | aclause(cl2,r), 143 | nbulit(cl2,0), 144 | nbplit(cl2,0). 145 | 146 | /* 147 | p :- p. 148 | */ 149 | program3 :- 150 | nbucl(p,1), 151 | pos(p,cl1), 152 | aclause(cl1,p), 153 | nbulit(cl1,1), 154 | nbplit(cl1,1). 155 | 156 | /* 157 | p :- not p. 158 | */ 159 | program4 :- 160 | nbucl(p,1), 161 | neg(p,cl1), 162 | aclause(cl1,p), 163 | nbulit(cl1,1), 164 | nbplit(cl1,0). 165 | 166 | /* 167 | p :- q, not r. 168 | q :- r, not p. 169 | r :- p, not q. 170 | */ 171 | 172 | program5 :- 173 | nbucl(p,1), 174 | pos(p,cl3), 175 | neg(p,cl2), 176 | aclause(cl1,p), 177 | nbulit(cl1,2), 178 | nbplit(cl1,1), 179 | nbucl(q,1), 180 | pos(q,cl1), 181 | neg(q,cl3), 182 | aclause(cl2,q), 183 | nbulit(cl2,2), 184 | nbplit(cl2,1), 185 | nbucl(r,1), 186 | pos(r,cl2), 187 | neg(r,cl1), 188 | aclause(cl3,r), 189 | nbulit(cl3,2), 190 | nbplit(cl3,1). 191 | 192 | 193 | main :- 194 | main(1000). 195 | 196 | main(N) :- 197 | cputime(T1), 198 | loop(N), 199 | cputime(T2), 200 | T is T2 - T1, 201 | write(bench(wfs ,N , T,0,hprolog)),write('.'),nl. 202 | 203 | loop(N) :- 204 | ( N =< 0 -> 205 | true 206 | ; 207 | ( prog, fail ; true), 208 | M is N - 1, 209 | loop(M) 210 | ). 211 | 212 | prog :- 213 | findall(Clause,wfs:prog(Clause),Clauses), 214 | process(Clauses,1), 215 | setof(At,B^(wfs:prog(At :- B) ; wfs:prog(At), atom(At)),Ats), 216 | process_atoms(Ats), 217 | phase2. 218 | 219 | process([],_). 220 | process([C|Cs],N) :- 221 | ( C = (HAt :- B) -> 222 | aclause(N,HAt), 223 | conj2list(B,Literals,[]), 224 | process_literals(Literals,N,NbULit,NbPLit), 225 | nbulit(N,NbULit), 226 | nbplit(N,NbPLit) 227 | ; 228 | C = HAt, 229 | aclause(N,HAt), 230 | nbulit(N,0), 231 | nbplit(N,0) 232 | ), 233 | N1 is N + 1, 234 | process(Cs,N1). 235 | 236 | conj2list(G,L,T) :- 237 | ( G = (G1,G2) -> 238 | conj2list(G1,L,T1), 239 | conj2list(G2,T1,T) 240 | ; 241 | L = [G|T] 242 | ). 243 | 244 | process_literals([],_,0,0). 245 | process_literals([L|R],Cl,U,P) :- 246 | process_literals(R,Cl,U1,P1), 247 | ( L = (\+ At) -> 248 | neg(At,Cl), 249 | P = P1, 250 | U is U1 + 1 251 | ; 252 | pos(L,Cl), 253 | P is P1 + 1, 254 | U is U1 + 1 255 | ). 256 | 257 | process_atoms([]). 258 | process_atoms([A|As]) :- 259 | findall(A,wfs:prog(A :- _),L), 260 | length(L,N), 261 | nbucl(A,N), 262 | process_atoms(As). 263 | -------------------------------------------------------------------------------- /chr_compiler_errors.pl: -------------------------------------------------------------------------------- 1 | /* Part of CHR (Constraint Handling Rules) 2 | 3 | Author: Tom Schrijvers 4 | E-mail: Tom.Schrijvers@cs.kuleuven.be 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2005-2011, K.U. Leuven 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | 2. Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in 18 | the documentation and/or other materials provided with the 19 | distribution. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | */ 34 | 35 | :- module(chr_compiler_errors, 36 | [ 37 | chr_info/3, 38 | chr_warning/3, 39 | chr_error/3, 40 | print_chr_error/1 41 | ]). 42 | 43 | :- use_module(chr_compiler_options). 44 | 45 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 46 | % chr_info(+Type,+FormattedMessage,+MessageParameters) 47 | 48 | chr_info(_,Message,Params) :- 49 | ( \+verbosity_on -> 50 | true 51 | ; 52 | long_line_with_equality_signs, 53 | format(user_error,'CHR compiler:\n',[]), 54 | format(user_error,Message,Params), 55 | long_line_with_equality_signs 56 | ). 57 | 58 | 59 | %% SWI begin 60 | verbosity_on :- 61 | current_prolog_flag(verbose,V), V \== silent, 62 | current_prolog_flag(verbose_load,true). 63 | %% SWI end 64 | 65 | %% SICStus begin 66 | %% verbosity_on. % at the moment 67 | %% SICStus end 68 | 69 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 70 | % chr_warning(+Type,+FormattedMessage,+MessageParameters) 71 | 72 | chr_warning(deprecated(Term),Message,Params) :- !, 73 | long_line_with_equality_signs, 74 | format(user_error,'CHR compiler WARNING: deprecated syntax ~w.\n',[Term]), 75 | format(user_error,' `--> ',[]), 76 | format(user_error,Message,Params), 77 | format(user_error,' Support for deprecated syntax will be discontinued in the near future!\n',[]), 78 | long_line_with_equality_signs. 79 | 80 | chr_warning(internal,Message,Params) :- !, 81 | long_line_with_equality_signs, 82 | format(user_error,'CHR compiler WARNING: something unexpected happened in the CHR compiler.\n',[]), 83 | format(user_error,' `--> ',[]), 84 | format(user_error,Message,Params), 85 | format(user_error,' Your program may not have been compiled correctly!\n',[]), 86 | format(user_error,' Please contact tom.schrijvers@cs.kuleuven.be.\n',[]), 87 | long_line_with_equality_signs. 88 | 89 | chr_warning(unsupported_pragma(Pragma,Rule),Message,Params) :- !, 90 | long_line_with_equality_signs, 91 | format(user_error,'CHR compiler WARNING: unsupported pragma ~w in ~@.\n',[Pragma,format_rule(Rule)]), 92 | format(user_error,' `--> ',[]), 93 | format(user_error,Message,Params), 94 | format(user_error,' Pragma is ignored!\n',[]), 95 | long_line_with_equality_signs. 96 | chr_warning(problem_pragma(Pragma,Rule),Message,Params) :- !, 97 | long_line_with_equality_signs, 98 | format(user_error,'CHR compiler WARNING: unsupported pragma ~w in ~@.\n',[Pragma,format_rule(Rule)]), 99 | format(user_error,' `--> ',[]), 100 | format(user_error,Message,Params), 101 | long_line_with_equality_signs. 102 | 103 | chr_warning(_,Message,Params) :- 104 | ( chr_pp_flag(verbosity,on) -> 105 | long_line_with_equality_signs, 106 | format(user_error,'CHR compiler WARNING:\n',[]), 107 | format(user_error,' `--> ',[]), 108 | format(user_error,Message,Params), 109 | long_line_with_equality_signs 110 | ; 111 | true 112 | ). 113 | 114 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 115 | % chr_error(+Type,+FormattedMessage,+MessageParameters) 116 | 117 | chr_error(Type,Message,Params) :- 118 | throw(chr_error(error(Type,Message,Params))). 119 | 120 | print_chr_error(error(Type,Message,Params)) :- 121 | print_chr_error(Type,Message,Params). 122 | 123 | print_chr_error(syntax(Term),Message,Params) :- !, 124 | long_line_with_equality_signs, 125 | format(user_error,'CHR compiler ERROR: invalid syntax "~w".\n',[Term]), 126 | format(user_error,' `--> ',[]), 127 | format(user_error,Message,Params), 128 | long_line_with_equality_signs. 129 | 130 | print_chr_error(type_error,Message,Params) :- !, 131 | long_line_with_equality_signs, 132 | format(user_error,'CHR compiler TYPE ERROR:\n',[]), 133 | format(user_error,' `--> ',[]), 134 | format(user_error,Message,Params), 135 | long_line_with_equality_signs. 136 | 137 | print_chr_error(internal,Message,Params) :- !, 138 | long_line_with_equality_signs, 139 | format(user_error,'CHR compiler ERROR: something unexpected happened in the CHR compiler.\n',[]), 140 | format(user_error,' `--> ',[]), 141 | format(user_error,Message,Params), 142 | format(user_error,' Please contact tom.schrijvers@cs.kuleuven.be.\n',[]), 143 | long_line_with_equality_signs. 144 | 145 | print_chr_error(cyclic_alias(Alias),_Message,_Params) :- !, 146 | long_line_with_equality_signs, 147 | format(user_error,'CHR compiler ERROR: cyclic alias "~w".\n',[Alias]), 148 | format(user_error,' `--> Aborting compilation.\n',[]), 149 | long_line_with_equality_signs. 150 | 151 | print_chr_error(_,Message,Params) :- 152 | long_line_with_equality_signs, 153 | format(user_error,'CHR compiler ERROR:\n',[]), 154 | format(user_error,' `--> ',[]), 155 | format(user_error,Message,Params), 156 | long_line_with_equality_signs. 157 | 158 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 159 | 160 | 161 | :- public 162 | format_rule/1. % called using format/3 `@' 163 | 164 | format_rule(PragmaRule) :- 165 | PragmaRule = pragma(_,_,Pragmas,MaybeName,N), 166 | ( MaybeName = yes(Name) -> 167 | write('rule '), write(Name) 168 | ; 169 | write('rule number '), write(N) 170 | ), 171 | ( memberchk(source_location(SourceLocation),Pragmas) -> 172 | write(' at '), 173 | write(SourceLocation) 174 | ; 175 | true 176 | ). 177 | 178 | long_line_with_equality_signs :- 179 | format(user_error,'================================================================================\n',[]). 180 | -------------------------------------------------------------------------------- /Examples/bool.chr: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | %% 3 | %% Thom Fruehwirth ECRC 1991-1993 4 | %% 910528 started boolean,and,or constraints 5 | %% 910904 added xor,neg constraints 6 | %% 911120 added imp constraint 7 | %% 931110 ported to new release 8 | %% 931111 added card constraint 9 | %% 961107 Christian Holzbaur, SICStus mods 10 | %% 11 | %% ported to hProlog by Tom Schrijvers June 2003 12 | 13 | 14 | :- module(bool,[]). 15 | :- use_module(library(chr)). 16 | 17 | :- constraints boolean/1, and/3, or/3, xor/3, neg/2, imp/2, labeling/0, card/4. 18 | 19 | 20 | boolean(0) <=> true. 21 | boolean(1) <=> true. 22 | 23 | labeling, boolean(A)#Pc <=> 24 | ( A=0 ; A=1), 25 | labeling 26 | pragma passive(Pc). 27 | 28 | 29 | %% and/3 specification 30 | %%and(0,0,0). 31 | %%and(0,1,0). 32 | %%and(1,0,0). 33 | %%and(1,1,1). 34 | 35 | and(0,X,Y) <=> Y=0. 36 | and(X,0,Y) <=> Y=0. 37 | and(1,X,Y) <=> Y=X. 38 | and(X,1,Y) <=> Y=X. 39 | and(X,Y,1) <=> X=1,Y=1. 40 | and(X,X,Z) <=> X=Z. 41 | %%and(X,Y,X) <=> imp(X,Y). 42 | %%and(X,Y,Y) <=> imp(Y,X). 43 | and(X,Y,A) \ and(X,Y,B) <=> A=B. 44 | and(X,Y,A) \ and(Y,X,B) <=> A=B. 45 | 46 | labeling, and(A,B,C)#Pc <=> 47 | label_and(A,B,C), 48 | labeling 49 | pragma passive(Pc). 50 | 51 | label_and(0,X,0). 52 | label_and(1,X,X). 53 | 54 | 55 | %% or/3 specification 56 | %%or(0,0,0). 57 | %%or(0,1,1). 58 | %%or(1,0,1). 59 | %%or(1,1,1). 60 | 61 | or(0,X,Y) <=> Y=X. 62 | or(X,0,Y) <=> Y=X. 63 | or(X,Y,0) <=> X=0,Y=0. 64 | or(1,X,Y) <=> Y=1. 65 | or(X,1,Y) <=> Y=1. 66 | or(X,X,Z) <=> X=Z. 67 | %%or(X,Y,X) <=> imp(Y,X). 68 | %%or(X,Y,Y) <=> imp(X,Y). 69 | or(X,Y,A) \ or(X,Y,B) <=> A=B. 70 | or(X,Y,A) \ or(Y,X,B) <=> A=B. 71 | 72 | labeling, or(A,B,C)#Pc <=> 73 | label_or(A,B,C), 74 | labeling 75 | pragma passive(Pc). 76 | 77 | label_or(0,X,X). 78 | label_or(1,X,1). 79 | 80 | 81 | %% xor/3 specification 82 | %%xor(0,0,0). 83 | %%xor(0,1,1). 84 | %%xor(1,0,1). 85 | %%xor(1,1,0). 86 | 87 | xor(0,X,Y) <=> X=Y. 88 | xor(X,0,Y) <=> X=Y. 89 | xor(X,Y,0) <=> X=Y. 90 | xor(1,X,Y) <=> neg(X,Y). 91 | xor(X,1,Y) <=> neg(X,Y). 92 | xor(X,Y,1) <=> neg(X,Y). 93 | xor(X,X,Y) <=> Y=0. 94 | xor(X,Y,X) <=> Y=0. 95 | xor(Y,X,X) <=> Y=0. 96 | xor(X,Y,A) \ xor(X,Y,B) <=> A=B. 97 | xor(X,Y,A) \ xor(Y,X,B) <=> A=B. 98 | 99 | labeling, xor(A,B,C)#Pc <=> 100 | label_xor(A,B,C), 101 | labeling 102 | pragma passive(Pc). 103 | 104 | label_xor(0,X,X). 105 | label_xor(1,X,Y):- neg(X,Y). 106 | 107 | 108 | %% neg/2 specification 109 | %%neg(0,1). 110 | %%neg(1,0). 111 | 112 | neg(0,X) <=> X=1. 113 | neg(X,0) <=> X=1. 114 | neg(1,X) <=> X=0. 115 | neg(X,1) <=> X=0. 116 | neg(X,X) <=> fail. 117 | neg(X,Y) \ neg(Y,Z) <=> X=Z. 118 | neg(X,Y) \ neg(Z,Y) <=> X=Z. 119 | neg(Y,X) \ neg(Y,Z) <=> X=Z. 120 | %% Interaction with other boolean constraints 121 | neg(X,Y) \ and(X,Y,Z) <=> Z=0. 122 | neg(Y,X) \ and(X,Y,Z) <=> Z=0. 123 | neg(X,Z) , and(X,Y,Z) <=> X=1,Y=0,Z=0. 124 | neg(Z,X) , and(X,Y,Z) <=> X=1,Y=0,Z=0. 125 | neg(Y,Z) , and(X,Y,Z) <=> X=0,Y=1,Z=0. 126 | neg(Z,Y) , and(X,Y,Z) <=> X=0,Y=1,Z=0. 127 | neg(X,Y) \ or(X,Y,Z) <=> Z=1. 128 | neg(Y,X) \ or(X,Y,Z) <=> Z=1. 129 | neg(X,Z) , or(X,Y,Z) <=> X=0,Y=1,Z=1. 130 | neg(Z,X) , or(X,Y,Z) <=> X=0,Y=1,Z=1. 131 | neg(Y,Z) , or(X,Y,Z) <=> X=1,Y=0,Z=1. 132 | neg(Z,Y) , or(X,Y,Z) <=> X=1,Y=0,Z=1. 133 | neg(X,Y) \ xor(X,Y,Z) <=> Z=1. 134 | neg(Y,X) \ xor(X,Y,Z) <=> Z=1. 135 | neg(X,Z) \ xor(X,Y,Z) <=> Y=1. 136 | neg(Z,X) \ xor(X,Y,Z) <=> Y=1. 137 | neg(Y,Z) \ xor(X,Y,Z) <=> X=1. 138 | neg(Z,Y) \ xor(X,Y,Z) <=> X=1. 139 | neg(X,Y) , imp(X,Y) <=> X=0,Y=1. 140 | neg(Y,X) , imp(X,Y) <=> X=0,Y=1. 141 | 142 | labeling, neg(A,B)#Pc <=> 143 | label_neg(A,B), 144 | labeling 145 | pragma passive(Pc). 146 | 147 | label_neg(0,1). 148 | label_neg(1,0). 149 | 150 | 151 | %% imp/2 specification (implication) 152 | %%imp(0,0). 153 | %%imp(0,1). 154 | %%imp(1,1). 155 | 156 | imp(0,X) <=> true. 157 | imp(X,0) <=> X=0. 158 | imp(1,X) <=> X=1. 159 | imp(X,1) <=> true. 160 | imp(X,X) <=> true. 161 | imp(X,Y),imp(Y,X) <=> X=Y. 162 | 163 | labeling, imp(A,B)#Pc <=> 164 | label_imp(A,B), 165 | labeling 166 | pragma passive(Pc). 167 | 168 | label_imp(0,X). 169 | label_imp(1,1). 170 | 171 | 172 | 173 | %% Boolean cardinality operator 174 | %% card(A,B,L,N) constrains list L of length N to have between A and B 1s 175 | 176 | 177 | card(A,B,L):- 178 | length(L,N), 179 | A= A=<0,N= set_to_ones(L). % positive satisfaction 193 | neg_sat @ card(A,0,L,N) <=> set_to_zeros(L). % negative satisfaction 194 | pos_red @ card(A,B,L,N) <=> b_delete(X,L,L1),X==1 | % positive reduction 195 | A1 is A-1, B1 is B-1, N1 is N-1, 196 | card(A1,B1,L1,N1). 197 | neg_red @ card(A,B,L,N) <=> b_delete(X,L,L1),X==0 | % negative reduction 198 | N1 is N-1, 199 | card(A,B,L1,N1). 200 | %% special cases with two variables 201 | card2nand @ card(0,1,[X,Y],2) <=> and(X,Y,0). 202 | card2neg @ card(1,1,[X,Y],2) <=> neg(X,Y). 203 | card2or @ card(1,2,[X,Y],2) <=> or(X,Y,1). 204 | 205 | b_delete( X, [X|L], L). 206 | b_delete( Y, [X|Xs], [X|Xt]) :- 207 | b_delete( Y, Xs, Xt). 208 | 209 | labeling, card(A,B,L,N)#Pc <=> 210 | label_card(A,B,L,N), 211 | labeling 212 | pragma passive(Pc). 213 | 214 | label_card(A,B,[],0):- A=<0,0= B), C) :- !, 254 | solve_bool(A,A1), 255 | solve_bool(B,B1), 256 | imp(A1,B1),C=1. 257 | solve_bool(A = B, C) :- !, 258 | solve_bool(A,A1), 259 | solve_bool(B,B1), 260 | A1=B1,C=1. 261 | 262 | %% Labeling 263 | label_bool([]). 264 | label_bool([X|L]) :- 265 | ( X=0;X=1), 266 | label_bool(L). 267 | 268 | /* % no write macros in SICStus and hProlog 269 | 270 | bool_portray(and(A,B,C),Out):- !, Out = (A*B = C). 271 | bool_portray(or(A,B,C),Out):- !, Out = (A+B = C). 272 | bool_portray(xor(A,B,C),Out):- !, Out = (A#B = C). 273 | bool_portray(neg(A,B),Out):- !, Out = (A= not(B)). 274 | bool_portray(imp(A,B),Out):- !, Out = (A -> B). 275 | bool_portray(card(A,B,L,N),Out):- !, Out = card(A,B,L). 276 | 277 | :- define_macro(type(compound),bool_portray/2,[write]). 278 | */ 279 | 280 | /* end of handler bool */ 281 | 282 | -------------------------------------------------------------------------------- /chr_swi_bootstrap.pl: -------------------------------------------------------------------------------- 1 | /* Part of CHR (Constraint Handling Rules) 2 | 3 | Author: Tom Schrijvers 4 | E-mail: Tom.Schrijvers@cs.kuleuven.be 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2004-2015, K.U. Leuven 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | 2. Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in 18 | the documentation and/or other materials provided with the 19 | distribution. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | */ 34 | 35 | :- module(chr, 36 | [ chr_compile_step1/2 % +CHRFile, -PlFile 37 | , chr_compile_step2/2 % +CHRFile, -PlFile 38 | , chr_compile_step3/2 % +CHRFile, -PlFile 39 | , chr_compile_step4/2 % +CHRFile, -PlFile 40 | , chr_compile/3 41 | ]). 42 | :- autoload(library(listing), [portray_clause/2]). 43 | :- autoload(library(dialect), [expects_dialect/1]). 44 | 45 | :- multifile user:file_search_path/2. 46 | user:file_search_path(chr, '.'). 47 | 48 | %% SWI begin 49 | % vsc: 50 | :- expects_dialect(swi). 51 | 52 | :- if(current_prolog_flag(dialect, yap)). 53 | 54 | :- prolog_load_context(directory,D), add_to_path(D). 55 | 56 | :- else. 57 | 58 | :- use_module(library(listing)). % portray_clause/2 59 | 60 | :- endif. 61 | 62 | %% SWI end 63 | :- include(chr_op). 64 | 65 | /******************************* 66 | * FILE-TO-FILE COMPILER * 67 | *******************************/ 68 | 69 | % chr_compile(+CHRFile, -PlFile) 70 | % 71 | % Compile a CHR specification into a Prolog file 72 | 73 | chr_compile_step1(From, To) :- 74 | use_module(chr(chr_translate_bootstrap)), 75 | chr_compile(From, To, informational). 76 | chr_compile_step2(From, To) :- 77 | use_module(chr(chr_translate_bootstrap1)), 78 | chr_compile(From, To, informational). 79 | chr_compile_step3(From, To) :- 80 | use_module(chr(chr_translate_bootstrap2)), 81 | chr_compile(From, To, informational). 82 | chr_compile_step4(From, To) :- 83 | use_module(chr(chr_translate)), 84 | chr_compile(From, To, informational). 85 | 86 | chr_compile(From, To, MsgLevel) :- 87 | print_message(MsgLevel, chr(start(From))), 88 | read_chr_file_to_terms(From,Declarations), 89 | % read_file_to_terms(From, Declarations, 90 | % [ module(chr) % get operators from here 91 | % ]), 92 | print_message(silent, chr(translate(From))), 93 | chr_translate(Declarations, Declarations1), 94 | insert_declarations(Declarations1, NewDeclarations), 95 | print_message(silent, chr(write(To))), 96 | writefile(To, From, NewDeclarations), 97 | print_message(MsgLevel, chr(end(From, To))). 98 | 99 | 100 | %% SWI begin 101 | specific_declarations([ (:- use_module(chr(chr_runtime))), 102 | (:- style_check(-discontiguous)), 103 | (:- style_check(-singleton)), 104 | (:- style_check(-no_effect)) 105 | | Tail 106 | ], Tail). 107 | %% SWI end 108 | 109 | %% SICStus begin 110 | %% specific_declarations([(:- use_module('chr_runtime')), 111 | %% (:-use_module(chr_hashtable_store)), 112 | %% (:- use_module('hpattvars')), 113 | %% (:- use_module('b_globval')), 114 | %% (:- use_module('hprolog')), % needed ? 115 | %% (:- set_prolog_flag(discontiguous_warnings,off)), 116 | %% (:- set_prolog_flag(single_var_warnings,off))|Tail], Tail). 117 | %% SICStus end 118 | 119 | 120 | 121 | insert_declarations(Clauses0, Clauses) :- 122 | specific_declarations(Decls,Tail), 123 | (Clauses0 = [(:- module(M,E))|FileBody] -> 124 | Clauses = [ (:- module(M,E))|Decls], 125 | Tail = FileBody 126 | ; 127 | Clauses = Decls, 128 | Tail = Clauses0 129 | ). 130 | 131 | % writefile(+File, +From, +Desclarations) 132 | % 133 | % Write translated CHR declarations to a File. 134 | 135 | writefile(File, From, Declarations) :- 136 | open(File, write, Out), 137 | writeheader(From, Out), 138 | writecontent(Declarations, Out), 139 | close(Out). 140 | 141 | writecontent([], _). 142 | writecontent([D|Ds], Out) :- 143 | portray_clause(Out, D), % SWI-Prolog 144 | writecontent(Ds, Out). 145 | 146 | 147 | writeheader(File, Out) :- 148 | format(Out, '/* Generated by CHR bootstrap compiler~n', []), 149 | format(Out, ' From: ~w~n', [File]), 150 | format_date(Out), 151 | format(Out, ' DO NOT EDIT. EDIT THE CHR FILE INSTEAD~n', []), 152 | format(Out, '*/~n~n', []). 153 | 154 | %% SWI begin 155 | format_date(Out) :- 156 | get_time(Now), 157 | format_time(string(Date), '%+', Now), 158 | format(Out, ' Date: ~s~n~n', [Date]). 159 | %% SWI end 160 | 161 | %% SICStus begin 162 | %% :- use_module(library(system), [datime/1]). 163 | %% format_date(Out) :- 164 | %% datime(datime(Year,Month,Day,Hour,Min,Sec)), 165 | %% format(Out, ' Date: ~d-~d-~d ~d:~d:~d~n~n', [Day,Month,Year,Hour,Min,Sec]). 166 | %% SICStus end 167 | 168 | 169 | 170 | /******************************* 171 | * MESSAGES * 172 | *******************************/ 173 | 174 | 175 | :- multifile 176 | prolog:message/3. 177 | 178 | prolog:message(chr(start(File))) --> 179 | { file_base_name(File, Base) 180 | }, 181 | [ 'Translating CHR file ~w'-[Base] ]. 182 | prolog:message(chr(end(_From, To))) --> 183 | { file_base_name(To, Base) 184 | }, 185 | [ 'Written translation to ~w'-[Base] ]. 186 | 187 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 188 | read_chr_file_to_terms(Spec, Terms) :- 189 | absolute_file_name(Spec, Path, [ access(read) ]), 190 | open(Path, read, Fd, []), 191 | read_chr_stream_to_terms(Fd, Terms), 192 | close(Fd). 193 | 194 | read_chr_stream_to_terms(Fd, Terms) :- 195 | chr_local_only_read_term(Fd, C0, [ module(chr) ]), 196 | read_chr_stream_to_terms(C0, Fd, Terms). 197 | 198 | read_chr_stream_to_terms(end_of_file, _, []) :- !. 199 | read_chr_stream_to_terms(C, Fd, [C|T]) :- 200 | ( ground(C), 201 | C = (:- op(Priority,Type,Name)) -> 202 | op(Priority,Type,Name) 203 | ; 204 | true 205 | ), 206 | chr_local_only_read_term(Fd, C2, [module(chr)]), 207 | read_chr_stream_to_terms(C2, Fd, T). 208 | 209 | 210 | 211 | 212 | %% SWI begin 213 | chr_local_only_read_term(A,B,C) :- read_term(A,B,C). 214 | %% SWI end 215 | 216 | %% SICStus begin 217 | %% chr_local_only_read_term(A,B,_) :- read_term(A,B,[]). 218 | %% SICStus end 219 | -------------------------------------------------------------------------------- /clean_code.pl: -------------------------------------------------------------------------------- 1 | /* Part of CHR (Constraint Handling Rules) 2 | 3 | Author: Tom Schrijvers 4 | E-mail: Tom.Schrijvers@cs.kuleuven.be 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2004-2011, K.U. Leuven 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | 2. Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in 18 | the documentation and/or other materials provided with the 19 | distribution. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | */ 34 | 35 | % ____ _ ____ _ _ 36 | % / ___|___ __| | ___ / ___| | ___ __ _ _ __ (_)_ __ __ _ 37 | % | | / _ \ / _` |/ _ \ | | | |/ _ \/ _` | '_ \| | '_ \ / _` | 38 | % | |__| (_) | (_| | __/ | |___| | __/ (_| | | | | | | | | (_| | 39 | % \____\___/ \__,_|\___| \____|_|\___|\__,_|_| |_|_|_| |_|\__, | 40 | % |___/ 41 | % 42 | % To be done: 43 | % inline clauses 44 | 45 | :- module(clean_code, 46 | [ 47 | clean_clauses/2 48 | ]). 49 | 50 | :- use_module(library(dialect/hprolog)). 51 | 52 | clean_clauses(Clauses,NClauses) :- 53 | clean_clauses1(Clauses,Clauses1), 54 | merge_clauses(Clauses1,NClauses). 55 | 56 | 57 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 58 | % CLEAN CLAUSES 59 | % 60 | % - move neck unification into the head of the clause 61 | % - drop true body 62 | % - specialize control flow goal wrt true and fail 63 | % 64 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 65 | 66 | clean_clauses1([],[]). 67 | clean_clauses1([C|Cs],[NC|NCs]) :- 68 | clean_clause(C,NC), 69 | clean_clauses1(Cs,NCs). 70 | 71 | clean_clause(Clause,NClause) :- 72 | ( Clause = (Head :- Body) -> 73 | clean_goal(Body,Body1), 74 | move_unification_into_head(Head,Body1,NHead,NBody), 75 | ( NBody == true -> 76 | NClause = NHead 77 | ; 78 | NClause = (NHead :- NBody) 79 | ) 80 | ; Clause = '$source_location'(File,Line) : ActualClause -> 81 | NClause = '$source_location'(File,Line) : NActualClause, 82 | clean_clause(ActualClause,NActualClause) 83 | ; 84 | NClause = Clause 85 | ). 86 | 87 | clean_goal(Goal,NGoal) :- 88 | var(Goal), !, 89 | NGoal = Goal. 90 | clean_goal((G1,G2),NGoal) :- 91 | !, 92 | clean_goal(G1,NG1), 93 | clean_goal(G2,NG2), 94 | ( NG1 == true -> 95 | NGoal = NG2 96 | ; NG2 == true -> 97 | NGoal = NG1 98 | ; 99 | NGoal = (NG1,NG2) 100 | ). 101 | clean_goal((If -> Then ; Else),NGoal) :- 102 | !, 103 | clean_goal(If,NIf), 104 | ( NIf == true -> 105 | clean_goal(Then,NThen), 106 | NGoal = NThen 107 | ; NIf == fail -> 108 | clean_goal(Else,NElse), 109 | NGoal = NElse 110 | ; 111 | clean_goal(Then,NThen), 112 | clean_goal(Else,NElse), 113 | NGoal = (NIf -> NThen; NElse) 114 | ). 115 | clean_goal((G1 ; G2),NGoal) :- 116 | !, 117 | clean_goal(G1,NG1), 118 | clean_goal(G2,NG2), 119 | ( NG1 == fail -> 120 | NGoal = NG2 121 | ; NG2 == fail -> 122 | NGoal = NG1 123 | ; 124 | NGoal = (NG1 ; NG2) 125 | ). 126 | clean_goal(once(G),NGoal) :- 127 | !, 128 | clean_goal(G,NG), 129 | ( NG == true -> 130 | NGoal = true 131 | ; NG == fail -> 132 | NGoal = fail 133 | ; 134 | NGoal = once(NG) 135 | ). 136 | clean_goal((G1 -> G2),NGoal) :- 137 | !, 138 | clean_goal(G1,NG1), 139 | ( NG1 == true -> 140 | clean_goal(G2,NGoal) 141 | ; NG1 == fail -> 142 | NGoal = fail 143 | ; 144 | clean_goal(G2,NG2), 145 | NGoal = (NG1 -> NG2) 146 | ). 147 | clean_goal(Goal,Goal). 148 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 149 | move_unification_into_head(Head,Body,NHead,NBody) :- 150 | conj2list(Body,BodyList), 151 | move_unification_into_head_(BodyList,Head,NHead,NBody). 152 | 153 | move_unification_into_head_([],Head,Head,true). 154 | move_unification_into_head_([G|Gs],Head,NHead,NBody) :- 155 | ( nonvar(G), G = (X = Y) -> 156 | term_variables(Gs,GsVars), 157 | ( var(X), ( \+ memberchk_eq(X,GsVars) ; atomic(Y)) -> 158 | X = Y, 159 | move_unification_into_head_(Gs,Head,NHead,NBody) 160 | ; var(Y), (\+ memberchk_eq(Y,GsVars) ; atomic(X)) -> 161 | X = Y, 162 | move_unification_into_head_(Gs,Head,NHead,NBody) 163 | ; 164 | Head = NHead, 165 | list2conj([G|Gs],NBody) 166 | ) 167 | ; 168 | Head = NHead, 169 | list2conj([G|Gs],NBody) 170 | ). 171 | 172 | 173 | conj2list(Conj,L) :- %% transform conjunctions to list 174 | conj2list(Conj,L,[]). 175 | 176 | conj2list(G,L,T) :- 177 | var(G), !, 178 | L = [G|T]. 179 | conj2list(true,L,L) :- !. 180 | conj2list(Conj,L,T) :- 181 | Conj = (G1,G2), !, 182 | conj2list(G1,L,T1), 183 | conj2list(G2,T1,T). 184 | conj2list(G,[G | T],T). 185 | 186 | list2conj([],true). 187 | list2conj([G],X) :- !, X = G. 188 | list2conj([G|Gs],C) :- 189 | ( G == true -> %% remove some redundant trues 190 | list2conj(Gs,C) 191 | ; 192 | C = (G,R), 193 | list2conj(Gs,R) 194 | ). 195 | 196 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 197 | % MERGE CLAUSES 198 | % 199 | % Find common prefixes of successive clauses and share them. 200 | % 201 | % Note: we assume that the prefix does not generate a side effect. 202 | % 203 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 204 | 205 | merge_clauses([],[]). 206 | merge_clauses([C],[C]). 207 | merge_clauses([X,Y|Clauses],NClauses) :- 208 | ( merge_two_clauses(X,Y,Clause) -> 209 | merge_clauses([Clause|Clauses],NClauses) 210 | ; 211 | NClauses = [X|RClauses], 212 | merge_clauses([Y|Clauses],RClauses) 213 | ). 214 | 215 | merge_two_clauses('$source_location'(F1,L1) : C1, 216 | '$source_location'(_F2,_L2) : C2, 217 | Result) :- !, 218 | merge_two_clauses(C1,C2,C), 219 | Result = '$source_location'(F1,L1) : C. 220 | merge_two_clauses((H1 :- B1), (H2 :- B2), (H :- B)) :- 221 | H1 =@= H2, 222 | H1 = H, 223 | conj2list(B1,List1), 224 | conj2list(B2,List2), 225 | merge_lists(List1,List2,H1,H2,Unifier,List,NList1,NList2), 226 | List \= [], 227 | H1 = H2, 228 | call(Unifier), 229 | list2conj(List,Prefix), 230 | list2conj(NList1,NB1), 231 | ( NList2 == (!) -> 232 | B = Prefix 233 | ; 234 | list2conj(NList2,NB2), 235 | B = (Prefix,(NB1 ; NB2)) 236 | ). 237 | 238 | merge_lists([],[],_,_,true,[],[],[]). 239 | merge_lists([],L2,_,_,true,[],[],L2). 240 | merge_lists([!|Xs],_,_,_,true,[!|Xs],[],!) :- !. 241 | merge_lists([X|Xs],[],_,_,true,[],[X|Xs],[]). 242 | merge_lists([X|Xs],[Y|Ys],H1,H2,Unifier,Common,N1,N2) :- 243 | ( H1-X =@= H2-Y -> 244 | Unifier = (X = Y, RUnifier), 245 | Common = [X|NCommon], 246 | merge_lists(Xs,Ys,H1/X,H2/Y,RUnifier,NCommon,N1,N2) 247 | ; 248 | Unifier = true, 249 | Common = [], 250 | N1 = [X|Xs], 251 | N2 = [Y|Ys] 252 | ). 253 | -------------------------------------------------------------------------------- /Benchmarks/bool.chr: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | %% 3 | %% Thom Fruehwirth ECRC 1991-1993 4 | %% 910528 started boolean,and,or constraints 5 | %% 910904 added xor,neg constraints 6 | %% 911120 added imp constraint 7 | %% 931110 ported to new release 8 | %% 931111 added card constraint 9 | %% 961107 Christian Holzbaur, SICStus mods 10 | %% 11 | %% ported to hProlog by Tom Schrijvers June 2003 12 | 13 | 14 | :- module(bool,[main/0,main/1]). 15 | 16 | :- use_module( library(chr)). 17 | :- use_module(library(lists)). 18 | 19 | :- chr_constraint boolean/1, and/3, or/3, xor/3, neg/2, imp/2, labeling/0, card/4. 20 | 21 | 22 | boolean(0) <=> true. 23 | boolean(1) <=> true. 24 | 25 | labeling, boolean(A)#Pc <=> 26 | ( A=0 ; A=1), 27 | labeling 28 | pragma passive(Pc). 29 | 30 | 31 | %% and/3 specification 32 | %%and(0,0,0). 33 | %%and(0,1,0). 34 | %%and(1,0,0). 35 | %%and(1,1,1). 36 | 37 | and(0,X,Y) <=> Y=0. 38 | and(X,0,Y) <=> Y=0. 39 | and(1,X,Y) <=> Y=X. 40 | and(X,1,Y) <=> Y=X. 41 | and(X,Y,1) <=> X=1,Y=1. 42 | and(X,X,Z) <=> X=Z. 43 | %%and(X,Y,X) <=> imp(X,Y). 44 | %%and(X,Y,Y) <=> imp(Y,X). 45 | and(X,Y,A) \ and(X,Y,B) <=> A=B. 46 | and(X,Y,A) \ and(Y,X,B) <=> A=B. 47 | 48 | labeling, and(A,B,C)#Pc <=> 49 | label_and(A,B,C), 50 | labeling 51 | pragma passive(Pc). 52 | 53 | label_and(0,X,0). 54 | label_and(1,X,X). 55 | 56 | 57 | %% or/3 specification 58 | %%or(0,0,0). 59 | %%or(0,1,1). 60 | %%or(1,0,1). 61 | %%or(1,1,1). 62 | 63 | or(0,X,Y) <=> Y=X. 64 | or(X,0,Y) <=> Y=X. 65 | or(X,Y,0) <=> X=0,Y=0. 66 | or(1,X,Y) <=> Y=1. 67 | or(X,1,Y) <=> Y=1. 68 | or(X,X,Z) <=> X=Z. 69 | %%or(X,Y,X) <=> imp(Y,X). 70 | %%or(X,Y,Y) <=> imp(X,Y). 71 | or(X,Y,A) \ or(X,Y,B) <=> A=B. 72 | or(X,Y,A) \ or(Y,X,B) <=> A=B. 73 | 74 | labeling, or(A,B,C)#Pc <=> 75 | label_or(A,B,C), 76 | labeling 77 | pragma passive(Pc). 78 | 79 | label_or(0,X,X). 80 | label_or(1,X,1). 81 | 82 | 83 | %% xor/3 specification 84 | %%xor(0,0,0). 85 | %%xor(0,1,1). 86 | %%xor(1,0,1). 87 | %%xor(1,1,0). 88 | 89 | xor(0,X,Y) <=> X=Y. 90 | xor(X,0,Y) <=> X=Y. 91 | xor(X,Y,0) <=> X=Y. 92 | xor(1,X,Y) <=> neg(X,Y). 93 | xor(X,1,Y) <=> neg(X,Y). 94 | xor(X,Y,1) <=> neg(X,Y). 95 | xor(X,X,Y) <=> Y=0. 96 | xor(X,Y,X) <=> Y=0. 97 | xor(Y,X,X) <=> Y=0. 98 | xor(X,Y,A) \ xor(X,Y,B) <=> A=B. 99 | xor(X,Y,A) \ xor(Y,X,B) <=> A=B. 100 | 101 | labeling, xor(A,B,C)#Pc <=> 102 | label_xor(A,B,C), 103 | labeling 104 | pragma passive(Pc). 105 | 106 | label_xor(0,X,X). 107 | label_xor(1,X,Y):- neg(X,Y). 108 | 109 | 110 | %% neg/2 specification 111 | %%neg(0,1). 112 | %%neg(1,0). 113 | 114 | neg(0,X) <=> X=1. 115 | neg(X,0) <=> X=1. 116 | neg(1,X) <=> X=0. 117 | neg(X,1) <=> X=0. 118 | neg(X,X) <=> fail. 119 | neg(X,Y) \ neg(Y,Z) <=> X=Z. 120 | neg(X,Y) \ neg(Z,Y) <=> X=Z. 121 | neg(Y,X) \ neg(Y,Z) <=> X=Z. 122 | %% Interaction with other boolean constraints 123 | neg(X,Y) \ and(X,Y,Z) <=> Z=0. 124 | neg(Y,X) \ and(X,Y,Z) <=> Z=0. 125 | neg(X,Z) , and(X,Y,Z) <=> X=1,Y=0,Z=0. 126 | neg(Z,X) , and(X,Y,Z) <=> X=1,Y=0,Z=0. 127 | neg(Y,Z) , and(X,Y,Z) <=> X=0,Y=1,Z=0. 128 | neg(Z,Y) , and(X,Y,Z) <=> X=0,Y=1,Z=0. 129 | neg(X,Y) \ or(X,Y,Z) <=> Z=1. 130 | neg(Y,X) \ or(X,Y,Z) <=> Z=1. 131 | neg(X,Z) , or(X,Y,Z) <=> X=0,Y=1,Z=1. 132 | neg(Z,X) , or(X,Y,Z) <=> X=0,Y=1,Z=1. 133 | neg(Y,Z) , or(X,Y,Z) <=> X=1,Y=0,Z=1. 134 | neg(Z,Y) , or(X,Y,Z) <=> X=1,Y=0,Z=1. 135 | neg(X,Y) \ xor(X,Y,Z) <=> Z=1. 136 | neg(Y,X) \ xor(X,Y,Z) <=> Z=1. 137 | neg(X,Z) \ xor(X,Y,Z) <=> Y=1. 138 | neg(Z,X) \ xor(X,Y,Z) <=> Y=1. 139 | neg(Y,Z) \ xor(X,Y,Z) <=> X=1. 140 | neg(Z,Y) \ xor(X,Y,Z) <=> X=1. 141 | neg(X,Y) , imp(X,Y) <=> X=0,Y=1. 142 | neg(Y,X) , imp(X,Y) <=> X=0,Y=1. 143 | 144 | labeling, neg(A,B)#Pc <=> 145 | label_neg(A,B), 146 | labeling 147 | pragma passive(Pc). 148 | 149 | label_neg(0,1). 150 | label_neg(1,0). 151 | 152 | 153 | %% imp/2 specification (implication) 154 | %%imp(0,0). 155 | %%imp(0,1). 156 | %%imp(1,1). 157 | 158 | imp(0,X) <=> true. 159 | imp(X,0) <=> X=0. 160 | imp(1,X) <=> X=1. 161 | imp(X,1) <=> true. 162 | imp(X,X) <=> true. 163 | imp(X,Y),imp(Y,X) <=> X=Y. 164 | 165 | labeling, imp(A,B)#Pc <=> 166 | label_imp(A,B), 167 | labeling 168 | pragma passive(Pc). 169 | 170 | label_imp(0,X). 171 | label_imp(1,1). 172 | 173 | 174 | 175 | %% Boolean cardinality operator 176 | %% card(A,B,L,N) constrains list L of length N to have between A and B 1s 177 | 178 | 179 | card(A,B,L):- 180 | length(L,N), 181 | A= A=<0,N= set_to_ones(L). % positive satisfaction 195 | neg_sat @ card(A,0,L,N) <=> set_to_zeros(L). % negative satisfaction 196 | pos_red @ card(A,B,L,N) <=> b_delete(X,L,L1),X==1 | % positive reduction 197 | A1 is A-1, B1 is B-1, N1 is N-1, 198 | card(A1,B1,L1,N1). 199 | neg_red @ card(A,B,L,N) <=> b_delete(X,L,L1),X==0 | % negative reduction 200 | N1 is N-1, 201 | card(A,B,L1,N1). 202 | %% special cases with two variables 203 | card2nand @ card(0,1,[X,Y],2) <=> and(X,Y,0). 204 | card2neg @ card(1,1,[X,Y],2) <=> neg(X,Y). 205 | card2or @ card(1,2,[X,Y],2) <=> or(X,Y,1). 206 | 207 | b_delete( X, [X|L], L). 208 | b_delete( Y, [X|Xs], [X|Xt]) :- 209 | b_delete( Y, Xs, Xt). 210 | 211 | labeling, card(A,B,L,N)#Pc <=> 212 | label_card(A,B,L,N), 213 | labeling 214 | pragma passive(Pc). 215 | 216 | label_card(A,B,[],0):- A=<0,0= B), C) :- !, 256 | solve_bool(A,A1), 257 | solve_bool(B,B1), 258 | imp(A1,B1),C=1. 259 | solve_bool(A = B, C) :- !, 260 | solve_bool(A,A1), 261 | solve_bool(B,B1), 262 | A1=B1,C=1. 263 | 264 | %% Labeling 265 | label_bool([]). 266 | label_bool([X|L]) :- 267 | ( X=0;X=1), 268 | label_bool(L). 269 | 270 | /* % no write macros in SICStus and hProlog 271 | 272 | bool_portray(and(A,B,C),Out):- !, Out = (A*B = C). 273 | bool_portray(or(A,B,C),Out):- !, Out = (A+B = C). 274 | bool_portray(xor(A,B,C),Out):- !, Out = (A#B = C). 275 | bool_portray(neg(A,B),Out):- !, Out = (A= not(B)). 276 | bool_portray(imp(A,B),Out):- !, Out = (A -> B). 277 | bool_portray(card(A,B,L,N),Out):- !, Out = card(A,B,L). 278 | 279 | :- define_macro(type(compound),bool_portray/2,[write]). 280 | */ 281 | 282 | /* end of handler bool */ 283 | 284 | half_adder(X,Y,S,C) :- 285 | xor(X,Y,S), 286 | and(X,Y,C). 287 | 288 | full_adder(X,Y,Ci,S,Co) :- 289 | half_adder(X,Y,S1,Co1), 290 | half_adder(Ci,S1,S,Co2), 291 | or(Co1,Co2,Co). 292 | 293 | main :- 294 | main(60000). 295 | 296 | main(N) :- 297 | cputime(X), 298 | adder(N), 299 | cputime(Now), 300 | Time is Now - X, 301 | write(bench(bool, N, Time, 0, hprolog)),write('.'),nl. 302 | 303 | adder(N) :- 304 | length(Ys,N), 305 | add(N,Ys). 306 | 307 | add(N,[Y|Ys]) :- 308 | half_adder(1,Y,0,C), 309 | add0(Ys,C). 310 | 311 | add0([],1). 312 | add0([Y|Ys],C) :- 313 | full_adder(0,Y,C,1,NC), 314 | add1(Ys,NC). 315 | 316 | add1([],0). 317 | add1([Y|Ys],C) :- 318 | full_adder(1,Y,C,0,NC), 319 | add0(Ys,NC). 320 | 321 | %cputime(Time) :- 322 | % statistics(runtime, [_,Time]). 323 | -------------------------------------------------------------------------------- /Benchmarks/ta.chr: -------------------------------------------------------------------------------- 1 | :- module(ta,[main/0,main/1]). 2 | 3 | :- use_module(library(chr)). 4 | :- use_module(library(lists)). 5 | 6 | /* 7 | 8 | Timed automaton => Constraints 9 | 10 | => 11 | 12 | X := N geq(X,N) 13 | --------> 14 | 15 | X =< N leq(X,N) 16 | --------> 17 | 18 | X >= N geq(X,N) 19 | --------> 20 | 21 | 22 | n > 1, 1 ------> v fincl(Xv,X1), 23 | ... / ... 24 | n ----/ fincl(Xv,Xn), 25 | fub_init(Xv,[]) 26 | 27 | n >= 1, v ------> 1 bincl(Xv,X1), 28 | \ ... ... 29 | \----> n bincl(Xv,X1), 30 | bub_init(Xv,[]) 31 | */ 32 | 33 | %% handler ta. 34 | 35 | :- chr_constraint 36 | 37 | fincl/2, % expresses that clock 1 includes clock 2 (union) 38 | % in the sense that clock 2 is forward of clock 1 39 | 40 | bincl/2, % expresses that clock 1 includes clock 2 (union) 41 | % in the sense that clock 1 is forward of clock 2 42 | 43 | leq/2, % expresses that clock 1 =< number 2 44 | 45 | geq/2, % expresses that clock 1 >= number 2 46 | 47 | fub_init/2, % collects the inital upper bounds 48 | % from incoming arrows for clock 1 in list 2 49 | 50 | fub/2, % collects the upper bounds for clock 1 51 | % from incoming arrows in list 2 52 | 53 | flb_init/2, % collects the inital lower bounds 54 | % from incoming arrows for clock 1 in list 2 55 | 56 | flb/2, % collects the lower bounds for clock 1 57 | % from incoming arrows in list 2 58 | 59 | bub_init/2, % collects the inital upper bounds 60 | % from backward arrows for clock 1 in list 2 61 | 62 | bub/2, % collects the upper bounds for clock 1 63 | % from outgoing arrows in list 2 64 | % values of clock 1 cannot exceed all 65 | % values of the clocks in list 2 66 | 67 | blb_init/2, % collects the inital lower bounds 68 | % from backward arrows for clock 1 in list 2 69 | 70 | blb/2, % collects the lower bounds for clock 1 71 | % from outgoing arrows in list 2 72 | % not all values of clock 1 can exceed any 73 | % values of the clocks in list 2 74 | 75 | compl/1, % indicate that all incoming arrows for clock 1 76 | % have been registerd 77 | 78 | dist/3, % indicates that clock 1 - clock 2 =< number 3 79 | 80 | fdist_init/3, % records initial distances for clock 1 and clock 2 from 81 | % incoming arrows in list 3 82 | 83 | fdist/3, % records distances for clock 1 and clock 2 from 84 | % incoming arrows in list 3 85 | 86 | setdist/3. % sets distance between clock 1 and clock 2, where 87 | % clock 1 is reset to value 3 88 | 89 | /* More Constraints: 90 | 91 | */ 92 | 93 | leq(X,N1) \ leq(X,N2) <=> N1 =< N2 | true. 94 | 95 | geq(X,N1) \ geq(X,N2) <=> N2 =< N1 | true. 96 | 97 | dist(X,Y,D1) \ dist(X,Y,D2) <=> D1 =< D2 | true. 98 | 99 | dist(X,Y,D), leq(Y,MY) \ leq(X,MX1) <=> 100 | MX2 is MY + D, MX2 < MX1 | leq(X,MX2). 101 | 102 | dist(X,Y,D), geq(X,MX) \ geq(Y,MY1) <=> 103 | MY2 is MX - D, MY2 > MY1 | geq(Y,MY2). 104 | 105 | fincl(X,Y), leq(Y,N) \ fub_init(X,L) 106 | <=> \+ memberchk_eq(N-Y,L) | 107 | insert_ub(L,Y,N,NL), 108 | fub_init(X,NL). 109 | 110 | fincl(X,Y), geq(Y,N) \ flb_init(X,L) 111 | <=> \+ memberchk_eq(N-Y,L) | 112 | insert_lb(L,Y,N,NL), 113 | flb_init(X,NL). 114 | 115 | dist(X1,Y1,D), fincl(X2,X1), fincl(Y2,Y1) \ fdist_init(X2,Y2,L) 116 | <=> 117 | \+ memberchk_eq(D-X1,L) | 118 | insert_ub(L,X1,D,NL), 119 | fdist_init(X2,Y2,NL). 120 | 121 | bincl(X,Y), leq(Y,N) \ bub_init(X,L) 122 | <=> 123 | \+ memberchk_eq(N-Y,L) | 124 | insert_ub(L,Y,N,NL), 125 | bub_init(X,NL). 126 | 127 | compl(X) \ fub_init(X,L) # ID 128 | <=> 129 | fub(X,L), 130 | val(L,M), 131 | leq(X,M) 132 | pragma passive(ID). 133 | 134 | compl(X) \ flb_init(X,L) # ID 135 | <=> 136 | flb(X,L), 137 | val(L,M), 138 | geq(X,M) 139 | pragma passive(ID). 140 | 141 | compl(X), compl(Y) \ fdist_init(X,Y,L) # ID 142 | <=> 143 | fdist(X,Y,L), 144 | val(L,D), 145 | dist(X,Y,D) 146 | pragma passive(D). 147 | 148 | compl(X) \ bub_init(X,L) # ID 149 | <=> 150 | bub(X,L), 151 | val(L,M), 152 | leq(X,M) 153 | pragma passive(ID). 154 | 155 | fincl(X,Y), leq(Y,N) \ fub(X,L) 156 | <=> 157 | \+ memberchk_eq(N-Y,L) | 158 | insert_ub(L,Y,N,NL), 159 | fub(X,NL), 160 | val(NL,M), 161 | leq(X,M). 162 | 163 | fincl(X,Y), geq(Y,N) \ flb(X,L) 164 | <=> 165 | \+ memberchk_eq(N-Y,L) | 166 | insert_lb(L,Y,N,NL), 167 | flb(X,NL), 168 | val(NL,M), 169 | geq(X,M). 170 | 171 | bincl(X,Y), leq(Y,N) \ bub(X,L) 172 | <=> 173 | \+ memberchk_eq(N-Y,L) | 174 | insert_ub(L,Y,N,NL), 175 | bub(X,NL), 176 | val(NL,M), 177 | leq(X,M). 178 | 179 | fincl(X2,X1), fincl(Y2,Y1), dist(X1,Y1,D) \ fdist(X2,Y2,L) 180 | <=> 181 | \+ memberchk_eq(D-X1,L) | 182 | insert_ub(L,X1,D,NL), 183 | fdist(X2,Y2,NL), 184 | val(NL,MD), 185 | dist(X2,Y2,MD). 186 | 187 | fincl(X,Y), leq(X,N) ==> leq(Y,N). 188 | 189 | fincl(X,Y), geq(X,N) ==> geq(Y,N). 190 | 191 | bincl(X,Y), geq(X,N) ==> geq(Y,N). 192 | 193 | bincl(X1,X2), bincl(Y1,Y2), dist(X1,Y1,D1) \ dist(X2,Y2,D2) <=> D1 < D2 | dist(X2,Y2,D1). 194 | 195 | setdist(X,Y,N), leq(Y,D1) ==> D2 is D1 - N, dist(Y,X,D2). 196 | setdist(X,Y,N), geq(Y,D1) ==> D2 is N - D1, dist(X,Y,D2). 197 | 198 | val([N-_|_],N). 199 | 200 | insert_ub([],X,N,[N-X]). 201 | insert_ub([M-Y|R],X,N,NL) :- 202 | ( Y == X -> 203 | insert_ub(R,X,N,NL) 204 | ; M > N -> 205 | NL = [M-Y|NR], 206 | insert_ub(R,X,N,NR) 207 | ; 208 | NL = [N-X,M-Y|R] 209 | ). 210 | 211 | insert_lb([],X,N,[N-X]). 212 | insert_lb([M-Y|R],X,N,NL) :- 213 | ( Y == X -> 214 | insert_lb(R,X,N,NL) 215 | ; M < N -> 216 | NL = [M-Y|NR], 217 | insert_lb(R,X,N,NR) 218 | ; 219 | NL = [N-X,M-Y|R] 220 | ). 221 | 222 | couple(X,Y) :- 223 | dist(X,Y,10000), 224 | dist(Y,X,10000). 225 | 226 | giri :- 227 | giri([x1,y1,x2,y2,x3,y3,x4,y4,x5,y5,x6,y6,x7,y7,x8,y8,x9,y9,x10,y10]). 228 | 229 | giri(L) :- 230 | L = [X1,Y1,X2,Y2,X3,Y3,X4,Y4,X5,Y5,X6,Y6,X7,Y7,X8,Y8,X9,Y9,X10,Y10], 231 | clocks(L), 232 | 233 | % 1. 234 | couple(X1,Y1), 235 | geq(X1,0), 236 | geq(X2,0), 237 | dist(X1,Y1,0), 238 | dist(Y1,X1,0), 239 | 240 | % 2. 241 | couple(X2,Y2), 242 | 243 | fincl(X2,X1), 244 | fincl(X2,X8), 245 | fincl(X2,X10), 246 | fub_init(X2,[]), 247 | flb_init(X2,[]), 248 | 249 | fincl(Y2,Y1), 250 | fincl(Y2,Y8), 251 | fincl(Y2,Y10), 252 | fub_init(Y2,[]), 253 | flb_init(Y2,[]), 254 | 255 | bincl(X2,X3), 256 | bincl(X2,X4), 257 | bub_init(X2,[]), 258 | blb_init(X2,[]), 259 | 260 | bincl(Y2,Y3), 261 | bincl(Y2,Y4), 262 | bub_init(Y2,[]), 263 | blb_init(Y2,[]), 264 | 265 | fdist_init(X2,Y2,[]), 266 | fdist_init(Y2,X2,[]), 267 | 268 | % 3. 269 | couple(X3,Y3), 270 | leq(X3,3), 271 | 272 | bincl(X3,X9), 273 | bincl(X3,X5), 274 | bub_init(X3,[]), 275 | blb_init(X3,[]), 276 | 277 | bincl(Y3,Y9), 278 | bincl(Y3,Y5), 279 | bub_init(Y3,[]), 280 | blb_init(Y3,[]), 281 | 282 | %fdist_init(X3,Y3,[]), 283 | %fdist_init(Y3,X3,[]), 284 | 285 | % 4. 286 | couple(X4,Y4), 287 | geq(Y4,2), 288 | leq(Y4,5), 289 | 290 | % 5. 291 | couple(X5,Y5), 292 | geq(Y5,5), 293 | leq(Y5,10), 294 | 295 | % 6. 296 | couple(X6,Y6), 297 | 298 | fincl(X6,X4), 299 | fincl(X6,X5), 300 | fub_init(X6,[]), 301 | flb_init(X6,[]), 302 | 303 | fincl(Y6,Y4), 304 | fincl(Y6,Y5), 305 | fub_init(Y6,[]), 306 | flb_init(Y6,[]), 307 | 308 | bincl(X6,X7), 309 | bub_init(X6,[]), 310 | 311 | bincl(Y6,Y7), 312 | bub_init(Y6,[]), 313 | 314 | fdist_init(X6,Y6,[]), 315 | fdist_init(Y6,X6,[]), 316 | 317 | % 7. 318 | couple(X7,Y7), 319 | geq(Y7,15), 320 | leq(Y7,15), 321 | 322 | % 8. 323 | couple(X8,Y8), 324 | geq(X8,2), 325 | geq(Y8,2), 326 | dist(X8,Y8,0), 327 | dist(Y8,X8,0), 328 | 329 | % 9. 330 | couple(X9,Y9), 331 | geq(Y9,5), 332 | leq(Y9,5), 333 | 334 | 335 | % 10. 336 | couple(X10,Y10), 337 | geq(X10,0), 338 | geq(Y10,0), 339 | dist(X10,Y10,0), 340 | dist(Y10,X10,0), 341 | 342 | % finish 343 | compl(X2), 344 | compl(Y2), 345 | 346 | compl(X3), 347 | compl(Y3), 348 | 349 | compl(X6), 350 | compl(Y6). 351 | 352 | 353 | 354 | clocks([]). 355 | clocks([C|Cs]) :- 356 | clock(C), 357 | clocks(Cs). 358 | 359 | clock(X) :- 360 | geq(X,0), 361 | leq(X,10000). 362 | 363 | main :- 364 | main(100). 365 | 366 | main(N) :- 367 | cputime(T1), 368 | loop(N), 369 | cputime(T2), 370 | T is T2 - T1, 371 | write(bench(ta ,N , T,0,hprolog)),write('.'),nl. 372 | 373 | 374 | loop(N) :- 375 | ( N =< 0 -> 376 | true 377 | ; 378 | ( giri, fail ; true), 379 | M is N - 1, 380 | loop(M) 381 | ). 382 | -------------------------------------------------------------------------------- /chr_compiler_utility.pl: -------------------------------------------------------------------------------- 1 | /* Part of CHR (Constraint Handling Rules) 2 | 3 | Author: Tom Schrijvers 4 | E-mail: Tom.Schrijvers@cs.kuleuven.be 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2005-2011, K.U. Leuven 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | 2. Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in 18 | the documentation and/or other materials provided with the 19 | distribution. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | */ 34 | 35 | :- module(chr_compiler_utility, 36 | [ time/2 37 | , replicate/3 38 | , pair_all_with/3 39 | , conj2list/2 40 | , list2conj/2 41 | , disj2list/2 42 | , list2disj/2 43 | , variable_replacement/3 44 | , variable_replacement/4 45 | , identical_rules/2 46 | , identical_guarded_rules/2 47 | , copy_with_variable_replacement/3 48 | , my_term_copy/3 49 | , my_term_copy/4 50 | , atom_concat_list/2 51 | , init/2 52 | , member2/3 53 | , select2/6 54 | , set_elems/2 55 | , instrument_goal/4 56 | , sort_by_key/3 57 | , arg1/3 58 | , wrap_in_functor/3 59 | , tree_set_empty/1 60 | , tree_set_memberchk/2 61 | , tree_set_add/3 62 | , tree_set_merge/3 63 | , fold1/3 64 | , fold/4 65 | , maplist_dcg//3 66 | , maplist_dcg//4 67 | ]). 68 | 69 | :- use_module(pairlist). 70 | :- use_module(library(lists), [permutation/2]). 71 | :- use_module(library(assoc)). 72 | 73 | :- meta_predicate 74 | fold1(3,+,-), 75 | fold(+,3,+,-). 76 | 77 | %% SICStus begin 78 | %% use_module(library(terms),[term_variables/2]). 79 | %% SICStus end 80 | 81 | 82 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 83 | % time(Phase,Goal) :- 84 | % statistics(runtime,[T1|_]), 85 | % call(Goal), 86 | % statistics(runtime,[T2|_]), 87 | % T is T2 - T1, 88 | % format(' ~w ~46t ~D~80| ms\n',[Phase,T]), 89 | % deterministic(Det), 90 | % ( Det == true -> 91 | % true 92 | % ; 93 | % format('\t\tNOT DETERMINISTIC!\n',[]) 94 | % ). 95 | time(_,Goal) :- call(Goal). 96 | 97 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 98 | replicate(N,E,L) :- 99 | ( N =< 0 -> 100 | L = [] 101 | ; 102 | L = [E|T], 103 | M is N - 1, 104 | replicate(M,E,T) 105 | ). 106 | 107 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 108 | pair_all_with([],_,[]). 109 | pair_all_with([X|Xs],Y,[X-Y|Rest]) :- 110 | pair_all_with(Xs,Y,Rest). 111 | 112 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 113 | conj2list(Conj,L) :- %% transform conjunctions to list 114 | conj2list(Conj,L,[]). 115 | 116 | conj2list(Var,L,T) :- 117 | var(Var), !, 118 | L = [Var|T]. 119 | conj2list(true,L,L) :- !. 120 | conj2list(Conj,L,T) :- 121 | Conj = (G1,G2), !, 122 | conj2list(G1,L,T1), 123 | conj2list(G2,T1,T). 124 | conj2list(G,[G | T],T). 125 | 126 | disj2list(Conj,L) :- %% transform disjunctions to list 127 | disj2list(Conj,L,[]). 128 | disj2list(Conj,L,T) :- 129 | Conj = (fail;G2), !, 130 | disj2list(G2,L,T). 131 | disj2list(Conj,L,T) :- 132 | Conj = (G1;G2), !, 133 | disj2list(G1,L,T1), 134 | disj2list(G2,T1,T). 135 | disj2list(G,[G | T],T). 136 | 137 | list2conj([],true). 138 | list2conj([G],X) :- !, X = G. 139 | list2conj([G|Gs],C) :- 140 | ( G == true -> %% remove some redundant trues 141 | list2conj(Gs,C) 142 | ; 143 | C = (G,R), 144 | list2conj(Gs,R) 145 | ). 146 | 147 | list2disj([],fail). 148 | list2disj([G],X) :- !, X = G. 149 | list2disj([G|Gs],C) :- 150 | ( G == fail -> %% remove some redundant fails 151 | list2disj(Gs,C) 152 | ; 153 | C = (G;R), 154 | list2disj(Gs,R) 155 | ). 156 | 157 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 158 | % check wether two rules are identical 159 | 160 | identical_guarded_rules(rule(H11,H21,G1,_),rule(H12,H22,G2,_)) :- 161 | G1 == G2, 162 | permutation(H11,P1), 163 | P1 == H12, 164 | permutation(H21,P2), 165 | P2 == H22. 166 | 167 | identical_rules(rule(H11,H21,G1,B1),rule(H12,H22,G2,B2)) :- 168 | G1 == G2, 169 | identical_bodies(B1,B2), 170 | permutation(H11,P1), 171 | P1 == H12, 172 | permutation(H21,P2), 173 | P2 == H22. 174 | 175 | identical_bodies(B1,B2) :- 176 | ( B1 = (X1 = Y1), 177 | B2 = (X2 = Y2) -> 178 | ( X1 == X2, 179 | Y1 == Y2 180 | ; X1 == Y2, 181 | X2 == Y1 182 | ), 183 | ! 184 | ; B1 == B2 185 | ). 186 | 187 | % replace variables in list 188 | 189 | copy_with_variable_replacement(X,Y,L) :- 190 | ( var(X) -> 191 | ( lookup_eq(L,X,Y) -> 192 | true 193 | ; X = Y 194 | ) 195 | ; functor(X,F,A), 196 | functor(Y,F,A), 197 | X =.. [_|XArgs], 198 | Y =.. [_|YArgs], 199 | copy_with_variable_replacement_l(XArgs,YArgs,L) 200 | ). 201 | 202 | copy_with_variable_replacement_l([],[],_). 203 | copy_with_variable_replacement_l([X|Xs],[Y|Ys],L) :- 204 | copy_with_variable_replacement(X,Y,L), 205 | copy_with_variable_replacement_l(Xs,Ys,L). 206 | 207 | % build variable replacement list 208 | 209 | variable_replacement(X,Y,L) :- 210 | variable_replacement(X,Y,[],L). 211 | 212 | variable_replacement(X,Y,L1,L2) :- 213 | ( var(X) -> 214 | var(Y), 215 | ( lookup_eq(L1,X,Z) -> 216 | Z == Y, 217 | L2 = L1 218 | ; ( X == Y -> L2=L1 ; L2 = [X-Y,Y-X|L1]) 219 | ) 220 | ; X =.. [F|XArgs], 221 | nonvar(Y), 222 | Y =.. [F|YArgs], 223 | variable_replacement_l(XArgs,YArgs,L1,L2) 224 | ). 225 | 226 | variable_replacement_l([],[],L,L). 227 | variable_replacement_l([X|Xs],[Y|Ys],L1,L3) :- 228 | variable_replacement(X,Y,L1,L2), 229 | variable_replacement_l(Xs,Ys,L2,L3). 230 | 231 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 232 | my_term_copy(X,Dict,Y) :- 233 | my_term_copy(X,Dict,_,Y). 234 | 235 | my_term_copy(X,Dict1,Dict2,Y) :- 236 | ( var(X) -> 237 | ( lookup_eq(Dict1,X,Y) -> 238 | Dict2 = Dict1 239 | ; Dict2 = [X-Y|Dict1] 240 | ) 241 | ; functor(X,XF,XA), 242 | functor(Y,XF,XA), 243 | X =.. [_|XArgs], 244 | Y =.. [_|YArgs], 245 | my_term_copy_list(XArgs,Dict1,Dict2,YArgs) 246 | ). 247 | 248 | my_term_copy_list([],Dict,Dict,[]). 249 | my_term_copy_list([X|Xs],Dict1,Dict3,[Y|Ys]) :- 250 | my_term_copy(X,Dict1,Dict2,Y), 251 | my_term_copy_list(Xs,Dict2,Dict3,Ys). 252 | 253 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 254 | atom_concat_list([X],X) :- ! . 255 | atom_concat_list([X|Xs],A) :- 256 | atom_concat_list(Xs,B), 257 | atomic_concat(X,B,A). 258 | 259 | set_elems([],_). 260 | set_elems([X|Xs],X) :- 261 | set_elems(Xs,X). 262 | 263 | init([],[]). 264 | init([_],[]) :- !. 265 | init([X|Xs],[X|R]) :- 266 | init(Xs,R). 267 | 268 | member2([X|_],[Y|_],X-Y). 269 | member2([_|Xs],[_|Ys],P) :- 270 | member2(Xs,Ys,P). 271 | 272 | select2(X, Y, [X|Xs], [Y|Ys], Xs, Ys). 273 | select2(X, Y, [X1|Xs], [Y1|Ys], [X1|NXs], [Y1|NYs]) :- 274 | select2(X, Y, Xs, Ys, NXs, NYs). 275 | 276 | instrument_goal(Goal,Pre,Post,(Pre,Goal,Post)). 277 | 278 | sort_by_key(List,Keys,SortedList) :- 279 | pairup(Keys,List,Pairs), 280 | sort(Pairs,SortedPairs), 281 | once(pairup(_,SortedList,SortedPairs)). 282 | 283 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 284 | arg1(Term,Index,Arg) :- arg(Index,Term,Arg). 285 | 286 | wrap_in_functor(Functor,X,Term) :- 287 | Term =.. [Functor,X]. 288 | 289 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 290 | 291 | tree_set_empty(TreeSet) :- empty_assoc(TreeSet). 292 | tree_set_memberchk(Element,TreeSet) :- get_assoc(Element,TreeSet,_). 293 | tree_set_add(TreeSet,Element,NTreeSet) :- put_assoc(Element,TreeSet,x,NTreeSet). 294 | tree_set_merge(TreeSet1,TreeSet2,TreeSet3) :- 295 | assoc_to_list(TreeSet1,List), 296 | fold(List,tree_set_add_pair,TreeSet2,TreeSet3). 297 | tree_set_add_pair(Key-Value,TreeSet,NTreeSet) :- 298 | put_assoc(Key,TreeSet,Value,NTreeSet). 299 | 300 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 301 | fold1(P,[Head|Tail],Result) :- 302 | fold(Tail,P,Head,Result). 303 | 304 | fold([],_,Acc,Acc). 305 | fold([X|Xs],P,Acc,Res) :- 306 | call(P,X,Acc,NAcc), 307 | fold(Xs,P,NAcc,Res). 308 | 309 | maplist_dcg(P,L1,L2,L) --> 310 | maplist_dcg_(L1,L2,L,P). 311 | 312 | maplist_dcg_([],[],[],_) --> []. 313 | maplist_dcg_([X|Xs],[Y|Ys],[Z|Zs],P) --> 314 | call(P,X,Y,Z), 315 | maplist_dcg_(Xs,Ys,Zs,P). 316 | 317 | maplist_dcg(P,L1,L2) --> 318 | maplist_dcg_(L1,L2,P). 319 | 320 | maplist_dcg_([],[],_) --> []. 321 | maplist_dcg_([X|Xs],[Y|Ys],P) --> 322 | call(P,X,Y), 323 | maplist_dcg_(Xs,Ys,P). 324 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 325 | :- dynamic 326 | user:goal_expansion/2. 327 | :- multifile 328 | user:goal_expansion/2. 329 | 330 | user:goal_expansion(arg1(Term,Index,Arg), arg(Index,Term,Arg)). 331 | user:goal_expansion(wrap_in_functor(Functor,In,Out), Goal) :- 332 | ( atom(Functor), var(Out) -> 333 | Out =.. [Functor,In], 334 | Goal = true 335 | ; 336 | Goal = (Out =.. [Functor,In]) 337 | ). 338 | 339 | -------------------------------------------------------------------------------- /chr_hashtable_store.pl: -------------------------------------------------------------------------------- 1 | /* Part of CHR (Constraint Handling Rules) 2 | 3 | Author: Tom Schrijvers 4 | E-mail: Tom.Schrijvers@cs.kuleuven.be 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2004-2013, K.U. Leuven 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | 2. Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in 18 | the documentation and/or other materials provided with the 19 | distribution. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | */ 34 | 35 | % author: Tom Schrijvers 36 | % email: Tom.Schrijvers@cs.kuleuven.be 37 | % copyright: K.U.Leuven, 2004 38 | 39 | :- module(chr_hashtable_store, 40 | [ new_ht/1, 41 | lookup_ht/3, 42 | lookup_ht1/4, 43 | lookup_ht2/4, 44 | insert_ht/3, 45 | insert_ht1/4, 46 | insert_ht/4, 47 | delete_ht/3, 48 | delete_ht1/4, 49 | delete_first_ht/3, 50 | value_ht/2, 51 | stats_ht/1, 52 | stats_ht/1 53 | ]). 54 | 55 | :- use_module(pairlist). 56 | :- use_module(library(dialect/hprolog)). 57 | :- use_module(library(lists)). 58 | 59 | :- multifile user:goal_expansion/2. 60 | :- dynamic user:goal_expansion/2. 61 | 62 | initial_capacity(89). 63 | 64 | new_ht(HT) :- 65 | initial_capacity(Capacity), 66 | new_ht(Capacity,HT). 67 | 68 | new_ht(Capacity,HT) :- 69 | functor(T1,t,Capacity), 70 | HT = ht(Capacity,0,Table), 71 | Table = T1. 72 | 73 | lookup_ht(HT,Key,Values) :- 74 | term_hash(Key,Hash), 75 | lookup_ht1(HT,Hash,Key,Values). 76 | /* 77 | HT = ht(Capacity,_,Table), 78 | Index is (Hash mod Capacity) + 1, 79 | arg(Index,Table,Bucket), 80 | nonvar(Bucket), 81 | ( Bucket = K-Vs -> 82 | K == Key, 83 | Values = Vs 84 | ; 85 | lookup(Bucket,Key,Values) 86 | ). 87 | */ 88 | 89 | % :- load_foreign_library(chr_support). 90 | 91 | /* 92 | lookup_ht1(HT,Hash,Key,Values) :- 93 | ( lookup_ht1_(HT,Hash,Key,Values) -> 94 | true 95 | ; 96 | ( lookup_ht1__(HT,Hash,Key,Values) -> 97 | writeln(lookup_ht1(HT,Hash,Key,Values)), 98 | throw(error) 99 | ; 100 | fail 101 | ) 102 | ). 103 | */ 104 | 105 | lookup_ht1(HT,Hash,Key,Values) :- 106 | HT = ht(Capacity,_,Table), 107 | Index is (Hash mod Capacity) + 1, 108 | arg(Index,Table,Bucket), 109 | nonvar(Bucket), 110 | ( Bucket = K-Vs -> 111 | K == Key, 112 | Values = Vs 113 | ; 114 | lookup(Bucket,Key,Values) 115 | ). 116 | 117 | lookup_ht2(HT,Key,Values,Index) :- 118 | term_hash(Key,Hash), 119 | HT = ht(Capacity,_,Table), 120 | Index is (Hash mod Capacity) + 1, 121 | arg(Index,Table,Bucket), 122 | nonvar(Bucket), 123 | ( Bucket = K-Vs -> 124 | K == Key, 125 | Values = Vs 126 | ; 127 | lookup(Bucket,Key,Values) 128 | ). 129 | 130 | lookup_pair_eq([P | KVs],Key,Pair) :- 131 | P = K-_, 132 | ( K == Key -> 133 | P = Pair 134 | ; 135 | lookup_pair_eq(KVs,Key,Pair) 136 | ). 137 | 138 | insert_ht(HT,Key,Value) :- 139 | term_hash(Key,Hash), 140 | HT = ht(Capacity0,Load,Table0), 141 | LookupIndex is (Hash mod Capacity0) + 1, 142 | arg(LookupIndex,Table0,LookupBucket), 143 | ( var(LookupBucket) -> 144 | LookupBucket = Key - [Value] 145 | ; LookupBucket = K-Values -> 146 | ( K == Key -> 147 | setarg(2,LookupBucket,[Value|Values]) 148 | ; 149 | setarg(LookupIndex,Table0,[Key-[Value],LookupBucket]) 150 | ) 151 | ; 152 | ( lookup_pair_eq(LookupBucket,Key,Pair) -> 153 | Pair = _-Values, 154 | setarg(2,Pair,[Value|Values]) 155 | ; 156 | setarg(LookupIndex,Table0,[Key-[Value]|LookupBucket]) 157 | ) 158 | ), 159 | NLoad is Load + 1, 160 | setarg(2,HT,NLoad), 161 | ( Load == Capacity0 -> 162 | expand_ht(HT,_Capacity) 163 | ; 164 | true 165 | ). 166 | 167 | insert_ht1(HT,Key,Hash,Value) :- 168 | HT = ht(Capacity0,Load,Table0), 169 | LookupIndex is (Hash mod Capacity0) + 1, 170 | arg(LookupIndex,Table0,LookupBucket), 171 | ( var(LookupBucket) -> 172 | LookupBucket = Key - [Value] 173 | ; LookupBucket = K-Values -> 174 | ( K == Key -> 175 | setarg(2,LookupBucket,[Value|Values]) 176 | ; 177 | setarg(LookupIndex,Table0,[Key-[Value],LookupBucket]) 178 | ) 179 | ; 180 | ( lookup_pair_eq(LookupBucket,Key,Pair) -> 181 | Pair = _-Values, 182 | setarg(2,Pair,[Value|Values]) 183 | ; 184 | setarg(LookupIndex,Table0,[Key-[Value]|LookupBucket]) 185 | ) 186 | ), 187 | NLoad is Load + 1, 188 | setarg(2,HT,NLoad), 189 | ( Load == Capacity0 -> 190 | expand_ht(HT,_Capacity) 191 | ; 192 | true 193 | ). 194 | 195 | % LDK: insert version with extra argument denoting result 196 | 197 | insert_ht(HT,Key,Value,Result) :- 198 | HT = ht(Capacity,Load,Table), 199 | term_hash(Key,Hash), 200 | LookupIndex is (Hash mod Capacity) + 1, 201 | arg(LookupIndex,Table,LookupBucket), 202 | ( var(LookupBucket) 203 | -> Result = [Value], 204 | LookupBucket = Key - Result, 205 | NewLoad is Load + 1 206 | ; LookupBucket = K - V 207 | -> ( K = Key 208 | -> Result = [Value|V], 209 | setarg(2,LookupBucket,Result), 210 | NewLoad = Load 211 | ; Result = [Value], 212 | setarg(LookupIndex,Table,[Key - Result,LookupBucket]), 213 | NewLoad is Load + 1 214 | ) 215 | ; ( lookup_pair_eq(LookupBucket,Key,Pair) 216 | -> Pair = _-Values, 217 | Result = [Value|Values], 218 | setarg(2,Pair,Result), 219 | NewLoad = Load 220 | ; Result = [Value], 221 | setarg(LookupIndex,Table,[Key - Result|LookupBucket]), 222 | NewLoad is Load + 1 223 | ) 224 | ), 225 | setarg(2,HT,NewLoad), 226 | ( NewLoad > Capacity 227 | -> expand_ht(HT,_) 228 | ; true 229 | ). 230 | 231 | % LDK: deletion of the first element of a bucket 232 | delete_first_ht(HT,Key,Values) :- 233 | HT = ht(Capacity,Load,Table), 234 | term_hash(Key,Hash), 235 | Index is (Hash mod Capacity) + 1, 236 | arg(Index,Table,Bucket), 237 | ( Bucket = _-[_|Values] 238 | -> ( Values = [] 239 | -> setarg(Index,Table,_), 240 | NewLoad is Load - 1 241 | ; setarg(2,Bucket,Values), 242 | NewLoad = Load 243 | ) 244 | ; lookup_pair_eq(Bucket,Key,Pair) 245 | -> Pair = _-[_|Values], 246 | ( Values = [] 247 | -> pairlist_delete_eq(Bucket,Key,NewBucket), 248 | ( NewBucket = [] 249 | -> setarg(Index,Table,_) 250 | ; NewBucket = [OtherPair] 251 | -> setarg(Index,Table,OtherPair) 252 | ; setarg(Index,Table,NewBucket) 253 | ), 254 | NewLoad is Load - 1 255 | ; setarg(2,Pair,Values), 256 | NewLoad = Load 257 | ) 258 | ), 259 | setarg(2,HT,NewLoad). 260 | 261 | delete_ht(HT,Key,Value) :- 262 | HT = ht(Capacity,Load,Table), 263 | NLoad is Load - 1, 264 | term_hash(Key,Hash), 265 | Index is (Hash mod Capacity) + 1, 266 | arg(Index,Table,Bucket), 267 | ( /* var(Bucket) -> 268 | true 269 | ; */ Bucket = _K-Vs -> 270 | ( /* _K == Key, */ 271 | delete_first_fail(Vs,Value,NVs) -> 272 | setarg(2,HT,NLoad), 273 | ( NVs == [] -> 274 | setarg(Index,Table,_) 275 | ; 276 | setarg(2,Bucket,NVs) 277 | ) 278 | ; 279 | true 280 | ) 281 | ; 282 | ( lookup_pair_eq(Bucket,Key,Pair), 283 | Pair = _-Vs, 284 | delete_first_fail(Vs,Value,NVs) -> 285 | setarg(2,HT,NLoad), 286 | ( NVs == [] -> 287 | pairlist_delete_eq(Bucket,Key,NBucket), 288 | ( NBucket = [Singleton] -> 289 | setarg(Index,Table,Singleton) 290 | ; 291 | setarg(Index,Table,NBucket) 292 | ) 293 | ; 294 | setarg(2,Pair,NVs) 295 | ) 296 | ; 297 | true 298 | ) 299 | ). 300 | 301 | delete_first_fail([X | Xs], Y, Zs) :- 302 | ( X == Y -> 303 | Zs = Xs 304 | ; 305 | Zs = [X | Zs1], 306 | delete_first_fail(Xs, Y, Zs1) 307 | ). 308 | 309 | delete_ht1(HT,Key,Value,Index) :- 310 | HT = ht(_Capacity,Load,Table), 311 | NLoad is Load - 1, 312 | % term_hash(Key,Hash), 313 | % Index is (Hash mod _Capacity) + 1, 314 | arg(Index,Table,Bucket), 315 | ( /* var(Bucket) -> 316 | true 317 | ; */ Bucket = _K-Vs -> 318 | ( /* _K == Key, */ 319 | delete_first_fail(Vs,Value,NVs) -> 320 | setarg(2,HT,NLoad), 321 | ( NVs == [] -> 322 | setarg(Index,Table,_) 323 | ; 324 | setarg(2,Bucket,NVs) 325 | ) 326 | ; 327 | true 328 | ) 329 | ; 330 | ( lookup_pair_eq(Bucket,Key,Pair), 331 | Pair = _-Vs, 332 | delete_first_fail(Vs,Value,NVs) -> 333 | setarg(2,HT,NLoad), 334 | ( NVs == [] -> 335 | pairlist_delete_eq(Bucket,Key,NBucket), 336 | ( NBucket = [Singleton] -> 337 | setarg(Index,Table,Singleton) 338 | ; 339 | setarg(Index,Table,NBucket) 340 | ) 341 | ; 342 | setarg(2,Pair,NVs) 343 | ) 344 | ; 345 | true 346 | ) 347 | ). 348 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 349 | value_ht(HT,Value) :- 350 | HT = ht(Capacity,_,Table), 351 | value_ht(1,Capacity,Table,Value). 352 | 353 | value_ht(I,N,Table,Value) :- 354 | I =< N, 355 | arg(I,Table,Bucket), 356 | ( 357 | nonvar(Bucket), 358 | ( Bucket = _-Vs -> 359 | true 360 | ; 361 | member(_-Vs,Bucket) 362 | ), 363 | member(Value,Vs) 364 | ; 365 | J is I + 1, 366 | value_ht(J,N,Table,Value) 367 | ). 368 | 369 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 370 | 371 | expand_ht(HT,NewCapacity) :- 372 | HT = ht(Capacity,_,Table), 373 | NewCapacity is Capacity * 2 + 1, 374 | functor(NewTable,t,NewCapacity), 375 | setarg(1,HT,NewCapacity), 376 | setarg(3,HT,NewTable), 377 | expand_copy(Table,1,Capacity,NewTable,NewCapacity). 378 | 379 | expand_copy(Table,I,N,NewTable,NewCapacity) :- 380 | ( I > N -> 381 | true 382 | ; 383 | arg(I,Table,Bucket), 384 | ( var(Bucket) -> 385 | true 386 | ; Bucket = Key - Value -> 387 | expand_insert(NewTable,NewCapacity,Key,Value) 388 | ; 389 | expand_inserts(Bucket,NewTable,NewCapacity) 390 | ), 391 | J is I + 1, 392 | expand_copy(Table,J,N,NewTable,NewCapacity) 393 | ). 394 | 395 | expand_inserts([],_,_). 396 | expand_inserts([K-V|R],Table,Capacity) :- 397 | expand_insert(Table,Capacity,K,V), 398 | expand_inserts(R,Table,Capacity). 399 | 400 | expand_insert(Table,Capacity,K,V) :- 401 | term_hash(K,Hash), 402 | Index is (Hash mod Capacity) + 1, 403 | arg(Index,Table,Bucket), 404 | ( var(Bucket) -> 405 | Bucket = K - V 406 | ; Bucket = _-_ -> 407 | setarg(Index,Table,[K-V,Bucket]) 408 | ; 409 | setarg(Index,Table,[K-V|Bucket]) 410 | ). 411 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 412 | stats_ht(HT) :- 413 | HT = ht(Capacity,Load,Table), 414 | format('HT load = ~w / ~w\n',[Load,Capacity]), 415 | ( between(1,Capacity,Index), 416 | arg(Index,Table,Entry), 417 | ( var(Entry) -> Size = 0 418 | ; Entry = _-_ -> Size = 1 419 | ; length(Entry,Size) 420 | ), 421 | format('~w : ~w\n',[Index,Size]), 422 | fail 423 | ; 424 | true 425 | ). 426 | -------------------------------------------------------------------------------- /chr_compiler_options.pl: -------------------------------------------------------------------------------- 1 | /* Part of CHR (Constraint Handling Rules) 2 | 3 | Author: Tom Schrijvers 4 | E-mail: Tom.Schrijvers@cs.kuleuven.be 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2005-2011, K.U. Leuven 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | 2. Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in 18 | the documentation and/or other materials provided with the 19 | distribution. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | */ 34 | 35 | :- module(chr_compiler_options, 36 | [ handle_option/2 37 | , init_chr_pp_flags/0 38 | , chr_pp_flag/2 39 | ]). 40 | 41 | %% SICStus begin 42 | %% :- use_module(hprolog, [nb_setval/2,nb_getval/2]). 43 | %% local_current_prolog_flag(_,_) :- fail. 44 | %% SICStus end 45 | 46 | %% SWI begin 47 | local_current_prolog_flag(X,Y) :- current_prolog_flag(X,Y). 48 | %% SWI end 49 | 50 | 51 | :- use_module(chr_compiler_errors). 52 | 53 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 54 | % Global Options 55 | % 56 | 57 | handle_option(Name,Value) :- 58 | var(Name), !, 59 | chr_error(syntax((:- chr_option(Name,Value))),'First argument should be an atom, not a variable.\n',[]). 60 | 61 | handle_option(Name,Value) :- 62 | var(Value), !, 63 | chr_error(syntax((:- chr_option(Name,Value))),'Second argument cannot be a variable.\n',[]). 64 | 65 | handle_option(Name,Value) :- 66 | option_definition(Name,Value,Flags), 67 | !, 68 | set_chr_pp_flags(Flags). 69 | 70 | handle_option(Name,Value) :- 71 | \+ option_definition(Name,_,_), !, 72 | chr_error(syntax((:- chr_option(Name,Value))),'Invalid option name ~w: consult the manual for valid options.\n',[Name]). 73 | 74 | handle_option(Name,Value) :- 75 | chr_error(syntax((:- chr_option(Name,Value))),'Invalid option value ~w: consult the manual for valid option values.\n',[Value]). 76 | 77 | option_definition(optimize,experimental,Flags) :- 78 | Flags = [ functional_dependency_analysis - on, 79 | check_unnecessary_active - full, 80 | reorder_heads - on, 81 | set_semantics_rule - on, 82 | storage_analysis - on, 83 | guard_via_reschedule - on, 84 | guard_simplification - on, 85 | check_impossible_rules - on, 86 | occurrence_subsumption - on, 87 | observation_analysis - on, 88 | ai_observation_analysis - on, 89 | late_allocation - on, 90 | reduced_indexing - on, 91 | term_indexing - on, 92 | inline_insertremove - on, 93 | mixed_stores - on 94 | ]. 95 | option_definition(optimize,full,Flags) :- 96 | Flags = [ functional_dependency_analysis - on, 97 | check_unnecessary_active - full, 98 | reorder_heads - on, 99 | set_semantics_rule - on, 100 | storage_analysis - on, 101 | guard_via_reschedule - on, 102 | guard_simplification - on, 103 | check_impossible_rules - on, 104 | occurrence_subsumption - on, 105 | observation_analysis - on, 106 | ai_observation_analysis - on, 107 | late_allocation - on, 108 | reduced_indexing - on, 109 | inline_insertremove - on, 110 | mixed_stores - off, 111 | debugable - off 112 | ]. 113 | 114 | option_definition(optimize,off,Flags) :- 115 | Flags = [ functional_dependency_analysis - off, 116 | check_unnecessary_active - off, 117 | reorder_heads - off, 118 | set_semantics_rule - off, 119 | storage_analysis - off, 120 | guard_via_reschedule - off, 121 | guard_simplification - off, 122 | check_impossible_rules - off, 123 | occurrence_subsumption - off, 124 | observation_analysis - off, 125 | ai_observation_analysis - off, 126 | late_allocation - off, 127 | reduced_indexing - off 128 | ]. 129 | 130 | option_definition(functional_dependency_analysis,on,Flags) :- 131 | Flags = [ functional_dependency_analysis - on ]. 132 | option_definition(functional_dependency_analysis,off,Flags) :- 133 | Flags = [ functional_dependency_analysis - off ]. 134 | 135 | option_definition(set_semantics_rule,on,Flags) :- 136 | Flags = [ set_semantics_rule - on ]. 137 | option_definition(set_semantics_rule,off,Flags) :- 138 | Flags = [ set_semantics_rule - off ]. 139 | 140 | option_definition(check_unnecessary_active,full,Flags) :- 141 | Flags = [ check_unnecessary_active - full ]. 142 | option_definition(check_unnecessary_active,simplification,Flags) :- 143 | Flags = [ check_unnecessary_active - simplification ]. 144 | option_definition(check_unnecessary_active,off,Flags) :- 145 | Flags = [ check_unnecessary_active - off ]. 146 | 147 | option_definition(check_guard_bindings,on,Flags) :- 148 | Flags = [ guard_locks - on ]. 149 | option_definition(check_guard_bindings,off,Flags) :- 150 | Flags = [ guard_locks - off ]. 151 | option_definition(check_guard_bindings,error,Flags) :- 152 | Flags = [ guard_locks - error ]. 153 | 154 | option_definition(reduced_indexing,on,Flags) :- 155 | Flags = [ reduced_indexing - on ]. 156 | option_definition(reduced_indexing,off,Flags) :- 157 | Flags = [ reduced_indexing - off ]. 158 | 159 | option_definition(storage_analysis,on,Flags) :- 160 | Flags = [ storage_analysis - on ]. 161 | option_definition(storage_analysis,off,Flags) :- 162 | Flags = [ storage_analysis - off ]. 163 | 164 | option_definition(guard_simplification,on,Flags) :- 165 | Flags = [ guard_simplification - on ]. 166 | option_definition(guard_simplification,off,Flags) :- 167 | Flags = [ guard_simplification - off ]. 168 | 169 | option_definition(check_impossible_rules,on,Flags) :- 170 | Flags = [ check_impossible_rules - on ]. 171 | option_definition(check_impossible_rules,off,Flags) :- 172 | Flags = [ check_impossible_rules - off ]. 173 | 174 | option_definition(occurrence_subsumption,on,Flags) :- 175 | Flags = [ occurrence_subsumption - on ]. 176 | option_definition(occurrence_subsumption,off,Flags) :- 177 | Flags = [ occurrence_subsumption - off ]. 178 | 179 | option_definition(late_allocation,on,Flags) :- 180 | Flags = [ late_allocation - on ]. 181 | option_definition(late_allocation,off,Flags) :- 182 | Flags = [ late_allocation - off ]. 183 | 184 | option_definition(inline_insertremove,on,Flags) :- 185 | Flags = [ inline_insertremove - on ]. 186 | option_definition(inline_insertremove,off,Flags) :- 187 | Flags = [ inline_insertremove - off ]. 188 | 189 | option_definition(type_definition,TypeDef,[]) :- 190 | ( nonvar(TypeDef) -> 191 | TypeDef = type(T,D), 192 | chr_translate:type_definition(T,D) 193 | ; true). 194 | option_definition(type_declaration,TypeDecl,[]) :- 195 | ( nonvar(TypeDecl) -> 196 | functor(TypeDecl,F,A), 197 | TypeDecl =.. [_|ArgTypes], 198 | chr_translate:constraint_type(F/A,ArgTypes) 199 | ; true). 200 | 201 | option_definition(mode,ModeDecl,[]) :- 202 | ( nonvar(ModeDecl) -> 203 | functor(ModeDecl,F,A), 204 | ModeDecl =.. [_|ArgModes], 205 | chr_translate:constraint_mode(F/A,ArgModes) 206 | ; true). 207 | option_definition(store,FA-Store,[]) :- 208 | chr_translate:store_type(FA,Store). 209 | 210 | %------------------------------------------------------------------------------% 211 | option_definition(declare_stored_constraints,off,[declare_stored_constraints-off]). 212 | option_definition(declare_stored_constraints,on ,[declare_stored_constraints-on]). 213 | 214 | option_definition(stored,F/A,[]) :- 215 | chr_translate:stored_assertion(F/A). 216 | %------------------------------------------------------------------------------% 217 | option_definition(experiment,off,[experiment-off]). 218 | option_definition(experiment,on,[experiment-on]). 219 | option_definition(experimental,off,[experiment-off]). 220 | option_definition(experimental,on,[experiment-on]). 221 | option_definition(sss,off,[sss-off]). 222 | option_definition(sss,on,[sss-on]). 223 | %------------------------------------------------------------------------------% 224 | option_definition(debug,off,Flags) :- 225 | option_definition(optimize,full,Flags2), 226 | Flags = [ debugable - off | Flags2]. 227 | option_definition(debug,on,Flags) :- 228 | ( local_current_prolog_flag(generate_debug_info,false) -> 229 | % TODO: should not be allowed when nodebug flag is set in SWI-Prolog 230 | chr_warning(any,':- chr_option(debug,on) inconsistent with current_prolog_flag(generate_debug_info,off\n\tCHR option is ignored!\n)',[]), 231 | Flags = [] 232 | ; 233 | Flags = [ debugable - on ] 234 | ). 235 | 236 | option_definition(store_counter,off,[]). 237 | option_definition(store_counter,on,[store_counter-on]). 238 | 239 | option_definition(observation,off,Flags) :- 240 | Flags = [ 241 | observation_analysis - off, 242 | ai_observation_analysis - off, 243 | late_allocation - off, 244 | storage_analysis - off 245 | ]. 246 | option_definition(observation,on,Flags) :- 247 | Flags = [ 248 | observation_analysis - on, 249 | ai_observation_analysis - on 250 | ]. 251 | option_definition(observation,regular,Flags) :- 252 | Flags = [ 253 | observation_analysis - on, 254 | ai_observation_analysis - off 255 | ]. 256 | option_definition(observation,ai,Flags) :- 257 | Flags = [ 258 | observation_analysis - off, 259 | ai_observation_analysis - on 260 | ]. 261 | 262 | option_definition(store_in_guards, on, [store_in_guards - on]). 263 | option_definition(store_in_guards, off, [store_in_guards - off]). 264 | 265 | option_definition(solver_events,NMod,Flags) :- 266 | Flags = [solver_events - NMod]. 267 | 268 | option_definition(toplevel_show_store,on,Flags) :- 269 | Flags = [toplevel_show_store - on]. 270 | 271 | option_definition(toplevel_show_store,off,Flags) :- 272 | Flags = [toplevel_show_store - off]. 273 | 274 | option_definition(term_indexing,on,Flags) :- 275 | Flags = [term_indexing - on]. 276 | option_definition(term_indexing,off,Flags) :- 277 | Flags = [term_indexing - off]. 278 | 279 | option_definition(verbosity,on,Flags) :- 280 | Flags = [verbosity - on]. 281 | option_definition(verbosity,off,Flags) :- 282 | Flags = [verbosity - off]. 283 | 284 | option_definition(ht_removal,on,Flags) :- 285 | Flags = [ht_removal - on]. 286 | option_definition(ht_removal,off,Flags) :- 287 | Flags = [ht_removal - off]. 288 | 289 | option_definition(mixed_stores,on,Flags) :- 290 | Flags = [mixed_stores - on]. 291 | option_definition(mixed_stores,off,Flags) :- 292 | Flags = [mixed_stores - off]. 293 | 294 | option_definition(line_numbers,on,Flags) :- 295 | Flags = [line_numbers - on]. 296 | option_definition(line_numbers,off,Flags) :- 297 | Flags = [line_numbers - off]. 298 | 299 | option_definition(dynattr,on,Flags) :- 300 | Flags = [dynattr - on]. 301 | option_definition(dynattr,off,Flags) :- 302 | Flags = [dynattr - off]. 303 | 304 | option_definition(verbose,off,[verbose-off]). 305 | option_definition(verbose,on,[verbose-on]). 306 | 307 | option_definition(dump,off,[dump-off]). 308 | option_definition(dump,on,[dump-on]). 309 | 310 | init_chr_pp_flags :- 311 | chr_pp_flag_definition(Name,[DefaultValue|_]), 312 | set_chr_pp_flag(Name,DefaultValue), 313 | fail. 314 | init_chr_pp_flags. 315 | 316 | set_chr_pp_flags([]). 317 | set_chr_pp_flags([Name-Value|Flags]) :- 318 | set_chr_pp_flag(Name,Value), 319 | set_chr_pp_flags(Flags). 320 | 321 | set_chr_pp_flag(Name,Value) :- 322 | atom_concat('$chr_pp_',Name,GlobalVar), 323 | nb_setval(GlobalVar,Value). 324 | 325 | chr_pp_flag_definition(functional_dependency_analysis,[off,on]). 326 | chr_pp_flag_definition(check_unnecessary_active,[off,full,simplification]). 327 | chr_pp_flag_definition(reorder_heads,[off,on]). 328 | chr_pp_flag_definition(set_semantics_rule,[off,on]). 329 | chr_pp_flag_definition(guard_via_reschedule,[off,on]). 330 | chr_pp_flag_definition(guard_locks,[on,off,error]). 331 | chr_pp_flag_definition(storage_analysis,[off,on]). 332 | chr_pp_flag_definition(debugable,[on,off]). 333 | chr_pp_flag_definition(reduced_indexing,[off,on]). 334 | chr_pp_flag_definition(observation_analysis,[off,on]). 335 | chr_pp_flag_definition(ai_observation_analysis,[off,on]). 336 | chr_pp_flag_definition(store_in_guards,[off,on]). 337 | chr_pp_flag_definition(late_allocation,[off,on]). 338 | chr_pp_flag_definition(store_counter,[off,on]). 339 | chr_pp_flag_definition(guard_simplification,[off,on]). 340 | chr_pp_flag_definition(check_impossible_rules,[off,on]). 341 | chr_pp_flag_definition(occurrence_subsumption,[off,on]). 342 | chr_pp_flag_definition(observation,[off,on]). 343 | chr_pp_flag_definition(show,[off,on]). 344 | chr_pp_flag_definition(inline_insertremove,[on,off]). 345 | chr_pp_flag_definition(solver_events,[none,_]). 346 | chr_pp_flag_definition(toplevel_show_store,[on,off]). 347 | chr_pp_flag_definition(term_indexing,[off,on]). 348 | chr_pp_flag_definition(verbosity,[on,off]). 349 | chr_pp_flag_definition(ht_removal,[off,on]). 350 | chr_pp_flag_definition(mixed_stores,[on,off]). 351 | chr_pp_flag_definition(line_numbers,[off,on]). 352 | chr_pp_flag_definition(dynattr,[off,on]). 353 | chr_pp_flag_definition(experiment,[off,on]). 354 | chr_pp_flag_definition(sss,[off,on]). 355 | % emit compiler inferred code 356 | chr_pp_flag_definition(verbose,[off,on]). 357 | % emit input code and output code 358 | chr_pp_flag_definition(dump,[off,on]). 359 | 360 | chr_pp_flag_definition(declare_stored_constraints,[off,on]). 361 | 362 | chr_pp_flag(Name,Value) :- 363 | atom_concat('$chr_pp_',Name,GlobalVar), 364 | nb_getval(GlobalVar,V), 365 | ( V == [] -> 366 | chr_pp_flag_definition(Name,[Value|_]) 367 | ; 368 | V = Value 369 | ). 370 | 371 | 372 | % TODO: add whatever goes wrong with (debug,on), (optimize,full) combo here! 373 | % trivial example of what does go wrong: 374 | % b <=> true. 375 | % !!! 376 | sanity_check :- 377 | chr_pp_flag(store_in_guards, on), 378 | chr_pp_flag(ai_observation_analysis, on), 379 | chr_warning(any, 'ai_observation_analysis should be turned off when using store_in_guards\n', []), 380 | fail. 381 | sanity_check. 382 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 383 | -------------------------------------------------------------------------------- /chr_swi.pl: -------------------------------------------------------------------------------- 1 | /* Part of CHR (Constraint Handling Rules) 2 | 3 | Author: Tom Schrijvers and Jan Wielemaker 4 | E-mail: Tom.Schrijvers@cs.kuleuven.be 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2004-2025, K.U. Leuven 7 | SWI-Prolog Solutions b.v. 8 | All rights reserved. 9 | 10 | Redistribution and use in source and binary forms, with or without 11 | modification, are permitted provided that the following conditions 12 | are met: 13 | 14 | 1. Redistributions of source code must retain the above copyright 15 | notice, this list of conditions and the following disclaimer. 16 | 17 | 2. Redistributions in binary form must reproduce the above copyright 18 | notice, this list of conditions and the following disclaimer in 19 | the documentation and/or other materials provided with the 20 | distribution. 21 | 22 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 23 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 24 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 25 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 26 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 27 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 28 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 29 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 30 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 31 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 32 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 33 | POSSIBILITY OF SUCH DAMAGE. 34 | */ 35 | 36 | %% SWI begin 37 | :- module(chr, 38 | [ op(1180, xfx, ==>), 39 | op(1180, xfx, <=>), 40 | op(1150, fx, constraints), 41 | op(1150, fx, chr_constraint), 42 | op(1150, fx, chr_preprocessor), 43 | op(1150, fx, handler), 44 | op(1150, fx, rules), 45 | op(1100, xfx, \), 46 | op(1200, xfx, @), 47 | op(1190, xfx, pragma), 48 | op( 500, yfx, #), 49 | op(1150, fx, chr_type), 50 | op(1150, fx, chr_declaration), 51 | op(1130, xfx, --->), 52 | op(1150, fx, (?)), 53 | chr_show_store/1, % +Module 54 | find_chr_constraint/1, % +Pattern 55 | current_chr_constraint/1, % :Pattern 56 | chr_trace/0, 57 | chr_notrace/0, 58 | chr_leash/1 % +Ports 59 | ]). 60 | :- use_module(library(dialect), [expects_dialect/1]). 61 | :- use_module(library(apply), [maplist/3]). 62 | :- use_module(library(lists), [member/2]). 63 | :- use_module(library(prolog_code), [pi_head/2]). 64 | 65 | :- expects_dialect(swi). 66 | 67 | :- set_prolog_flag(generate_debug_info, false). 68 | 69 | :- multifile 70 | debug_ask_continue/1, 71 | preprocess/2. 72 | 73 | :- multifile user:file_search_path/2. 74 | :- dynamic user:file_search_path/2. 75 | :- dynamic chr_translated_program/1. 76 | 77 | user:file_search_path(chr, library(chr)). 78 | 79 | :- load_files([ chr(chr_translate), 80 | chr(chr_runtime), 81 | chr(chr_messages), 82 | chr(chr_hashtable_store), 83 | chr(chr_compiler_errors) 84 | ], 85 | [ if(not_loaded), 86 | silent(true) 87 | ]). 88 | 89 | :- use_module(library(lists), [member/2]). 90 | %% SWI end 91 | 92 | %% SICStus begin 93 | %% :- module(chr,[ 94 | %% chr_trace/0, 95 | %% chr_notrace/0, 96 | %% chr_leash/0, 97 | %% chr_flag/3, 98 | %% chr_show_store/1 99 | %% ]). 100 | %% 101 | %% :- op(1180, xfx, ==>), 102 | %% op(1180, xfx, <=>), 103 | %% op(1150, fx, constraints), 104 | %% op(1150, fx, handler), 105 | %% op(1150, fx, rules), 106 | %% op(1100, xfx, \), 107 | %% op(1200, xfx, @), 108 | %% op(1190, xfx, pragma), 109 | %% op( 500, yfx, #), 110 | %% op(1150, fx, chr_type), 111 | %% op(1130, xfx, --->), 112 | %% op(1150, fx, (?)). 113 | %% 114 | %% :- multifile user:file_search_path/2. 115 | %% :- dynamic chr_translated_program/1. 116 | %% 117 | %% user:file_search_path(chr, library(chr)). 118 | %% 119 | %% 120 | %% :- use_module('chr/chr_translate'). 121 | %% :- use_module('chr/chr_runtime'). 122 | %% :- use_module('chr/chr_hashtable_store'). 123 | %% :- use_module('chr/hprolog'). 124 | %% SICStus end 125 | 126 | :- multifile chr:'$chr_module'/1. 127 | 128 | :- dynamic chr_term/3. % File, Term 129 | 130 | :- dynamic chr_pp/2. % File, Term 131 | 132 | % chr_expandable(+Term) 133 | % 134 | % Succeeds if Term is a rule that must be handled by the CHR 135 | % compiler. Ideally CHR definitions should be between 136 | % 137 | % :- constraints ... 138 | % ... 139 | % :- end_constraints. 140 | % 141 | % As they are not we have to use some heuristics. We assume any 142 | % file is a CHR after we've seen :- constraints ... 143 | 144 | chr_expandable((:- constraints _)). 145 | chr_expandable((constraints _)). 146 | chr_expandable((:- chr_constraint _)). 147 | chr_expandable((:- chr_type _)). 148 | chr_expandable((chr_type _)). 149 | chr_expandable((:- chr_declaration _)). 150 | chr_expandable(option(_, _)). 151 | chr_expandable((:- chr_option(_, _))). 152 | chr_expandable((handler _)). 153 | chr_expandable((rules _)). 154 | chr_expandable((_ <=> _)). 155 | chr_expandable((_ @ _)). 156 | chr_expandable((_ ==> _)). 157 | chr_expandable((_ pragma _)). 158 | 159 | % chr_expand(+Term, -Expansion) 160 | % 161 | % Extract CHR declarations and rules from the file and run the 162 | % CHR compiler when reaching end-of-file. 163 | 164 | %% SWI begin 165 | extra_declarations([ (:- use_module(chr(chr_runtime))), 166 | (:- style_check(-discontiguous)), 167 | (:- style_check(-singleton)), 168 | (:- style_check(-no_effect)), 169 | (:- set_prolog_flag(generate_debug_info, false)) 170 | | Tail 171 | ], Tail). 172 | %% SWI end 173 | 174 | %% SICStus begin 175 | %% extra_declarations([(:-use_module(chr(chr_runtime))) 176 | %% , (:- use_module(chr(hprolog),[term_variables/2,term_variables/3])) 177 | %% , (:-use_module(chr(hpattvars))) 178 | %% | Tail], Tail). 179 | %% SICStus end 180 | 181 | chr_expand(Term, []) :- 182 | chr_expandable(Term), 183 | !, 184 | prolog_load_context(source,Source), 185 | prolog_load_context(source,File), 186 | prolog_load_context(term_position,Pos), 187 | stream_position_data(line_count,Pos,SourceLocation), 188 | add_pragma_to_chr_rule(Term,source_location(File:SourceLocation),NTerm), 189 | assert(chr_term(Source, SourceLocation, NTerm)). 190 | chr_expand(Term, []) :- 191 | Term = (:- chr_preprocessor Preprocessor), 192 | !, 193 | prolog_load_context(source,File), 194 | assert(chr_pp(File, Preprocessor)). 195 | chr_expand(end_of_file, FinalProgram) :- 196 | extra_declarations(FinalProgram,Program), 197 | prolog_load_context(source,File), 198 | findall(T, retract(chr_term(File,_Line,T)), CHR0), 199 | CHR0 \== [], 200 | prolog_load_context(module, Module), 201 | add_debug_decl(CHR0, CHR1), 202 | add_optimise_decl(CHR1, CHR2), 203 | call_preprocess(CHR2, CHR3), 204 | CHR4 = [ (:- module(Module, [])) | CHR3 ], 205 | findall(P, retract(chr_pp(File, P)), Preprocessors), 206 | ( Preprocessors = [] -> 207 | CHR4 = CHR 208 | ; Preprocessors = [Preprocessor] -> 209 | chr_compiler_errors:chr_info(preprocessor,'\tPreprocessing with ~w.\n',[Preprocessor]), 210 | call_chr_preprocessor(Preprocessor,CHR4,CHR) 211 | ; 212 | chr_compiler_errors:print_chr_error(error(syntax(Preprocessors),'Too many preprocessors! Only one is allowed!\n',[])), 213 | fail 214 | ), 215 | catch(call_chr_translate(File, 216 | [ (:- module(Module, [])) 217 | | CHR 218 | ], 219 | Program0), 220 | chr_error(Error), 221 | ( chr_compiler_errors:print_chr_error(Error), 222 | fail 223 | ) 224 | ), 225 | delete_header(Program0, Program). 226 | 227 | 228 | delete_header([(:- module(_,_))|T0], T) :- 229 | !, 230 | delete_header(T0, T). 231 | delete_header(L, L). 232 | 233 | add_debug_decl(CHR, CHR) :- 234 | member(option(Name, _), CHR), Name == debug, 235 | !. 236 | add_debug_decl(CHR, CHR) :- 237 | member((:- chr_option(Name, _)), CHR), Name == debug, 238 | !. 239 | add_debug_decl(CHR, [(:- chr_option(debug, Debug))|CHR]) :- 240 | ( chr_current_prolog_flag(generate_debug_info, true) 241 | -> Debug = on 242 | ; Debug = off 243 | ). 244 | 245 | %% SWI begin 246 | chr_current_prolog_flag(Flag,Val) :- current_prolog_flag(Flag,Val). 247 | %% SWI end 248 | 249 | add_optimise_decl(CHR, CHR) :- 250 | \+(\+(memberchk((:- chr_option(optimize, _)), CHR))), 251 | !. 252 | add_optimise_decl(CHR, [(:- chr_option(optimize, full))|CHR]) :- 253 | chr_current_prolog_flag(optimize, full), 254 | !. 255 | add_optimise_decl(CHR, CHR). 256 | 257 | %! call_preprocess(+CHR0, -CHR) is det. 258 | % 259 | % Call user chr:preprocess(CHR0, CHR). 260 | 261 | call_preprocess(CHR0, CHR) :- 262 | preprocess(CHR0, CHR), 263 | !. 264 | call_preprocess(CHR, CHR). 265 | 266 | % call_chr_translate(+File, +In, -Out) 267 | % 268 | % The entire chr_translate/2 translation may fail, in which case we'd 269 | % better issue a warning rather than simply ignoring the CHR 270 | % declarations. 271 | 272 | call_chr_translate(File, In, _Out) :- 273 | ( chr_translate_line_info(In, File, Out0) -> 274 | nb_setval(chr_translated_program,Out0), 275 | fail 276 | ). 277 | call_chr_translate(_, _In, Out) :- 278 | nb_current(chr_translated_program,Out), 279 | !, 280 | nb_delete(chr_translated_program). 281 | 282 | call_chr_translate(File, _, []) :- 283 | print_message(error, chr(compilation_failed(File))). 284 | 285 | call_chr_preprocessor(Preprocessor,CHR,_NCHR) :- 286 | ( call(Preprocessor,CHR,CHR0) -> 287 | nb_setval(chr_preprocessed_program,CHR0), 288 | fail 289 | ). 290 | call_chr_preprocessor(_,_,NCHR) :- 291 | nb_current(chr_preprocessed_program,NCHR), 292 | !, 293 | nb_delete(chr_preprocessed_program). 294 | call_chr_preprocessor(Preprocessor,_,_) :- 295 | chr_compiler_errors:print_chr_error(error(preprocessor,'Preprocessor `~w\' failed!\n',[Preprocessor])). 296 | 297 | %% SWI begin 298 | 299 | /******************************* 300 | * SYNCHRONISE TRACER * 301 | *******************************/ 302 | 303 | :- multifile 304 | prolog:message_action/2, 305 | chr:debug_event/2, 306 | chr:debug_interact/3. 307 | 308 | prolog:message_action(trace_mode(OnOff), _) :- 309 | ( OnOff == on 310 | -> chr_trace 311 | ; chr_notrace 312 | ). 313 | 314 | :- public 315 | debug_event/2, 316 | debug_interact/3. 317 | 318 | %! debug_event(+State, +Event) 319 | % 320 | % Hook into the CHR debugger. At this moment we will discard CHR 321 | % events if we are in a Prolog `skip' and we ignore the 322 | 323 | debug_event(_State, _Event) :- 324 | tracing, % are we tracing? 325 | prolog_skip_level(Skip, Skip), 326 | Skip \== very_deep, 327 | prolog_current_frame(Me), 328 | prolog_frame_attribute(Me, level, Level), 329 | Level > Skip, 330 | !. 331 | 332 | %! debug_interact(+Event, +Depth, -Command) 333 | % 334 | % Hook into the CHR debugger to display Event and ask for the next 335 | % command to execute. This definition causes the normal Prolog 336 | % debugger to be used for the standard ports. 337 | 338 | debug_interact(Event, _Depth, creep) :- 339 | prolog_event(Event), 340 | tracing, 341 | !. 342 | 343 | prolog_event(call(_)). 344 | prolog_event(exit(_)). 345 | prolog_event(fail(_)). 346 | 347 | %! debug_ask_continue(-Command) is semidet. 348 | % 349 | % Hook to ask for a CHR debug continuation. Must bind Command to 350 | % one of =creep=, =skip=, =ancestors=, =nodebug=, =abort=, =fail=, 351 | % =break=, =help= or =exit=. 352 | 353 | 354 | /******************************* 355 | * MESSAGES * 356 | *******************************/ 357 | 358 | :- multifile 359 | prolog:message/3. 360 | 361 | prolog:message(chr(CHR)) --> 362 | chr_message(CHR). 363 | 364 | :- multifile 365 | check:trivial_fail_goal/1. 366 | 367 | check:trivial_fail_goal(_:Goal) :- 368 | functor(Goal, Name, _), 369 | sub_atom(Name, 0, _, _, '$chr_store_constants_'). 370 | 371 | /******************************* 372 | * TOPLEVEL PRINTING * 373 | *******************************/ 374 | 375 | :- create_prolog_flag(chr_toplevel_show_store, true, []). 376 | 377 | :- residual_goals(chr_residuals). 378 | 379 | %! chr_residuals// is det. 380 | % 381 | % Find the CHR constraints from the store. These are accessible 382 | % through the nondet predicate current_chr_constraint/1. Doing a 383 | % findall/4 however would loose the bindings. We therefore rolled 384 | % findallv/4, which exploits non-backtrackable assignment and 385 | % realises a copy of the template without disturbing the bindings 386 | % using this strangely looking construct. Note that the bindings 387 | % created by the unifications are in New, which is newer then the 388 | % latest choicepoint and therefore the bindings are not trailed. 389 | % 390 | % == 391 | % duplicate_term(Templ, New), 392 | % New = Templ 393 | % == 394 | 395 | chr_residuals(Residuals, Tail) :- 396 | chr_current_prolog_flag(chr_toplevel_show_store,true), 397 | nb_current(chr_global, _), 398 | !, 399 | Goal = _:_, 400 | findallv(Goal, current_chr_constraint(Goal), Residuals, Tail). 401 | chr_residuals(Residuals, Residuals). 402 | 403 | :- meta_predicate 404 | findallv(?, 0, ?, ?). 405 | 406 | findallv(Templ, Goal, List, Tail) :- 407 | List2 = [x|_], 408 | State = state(List2), 409 | ( call(Goal), 410 | arg(1, State, L), 411 | duplicate_term(Templ, New), 412 | New = Templ, 413 | Cons = [New|_], 414 | nb_linkarg(2, L, Cons), 415 | nb_linkarg(1, State, Cons), 416 | fail 417 | ; List2 = [x|List], 418 | arg(1, State, Last), 419 | arg(2, Last, Tail) 420 | ). 421 | 422 | 423 | /******************************* 424 | * MUST BE LAST! * 425 | *******************************/ 426 | 427 | %! in_chr_context is semidet. 428 | % 429 | % True if we are expanding into a context where the chr module is 430 | % loaded. 431 | 432 | in_chr_context :- 433 | prolog_load_context(module, M), 434 | ( current_op(1180, xfx, M:(==>)) 435 | -> true 436 | ; module_property(chr, exports(PIs)), 437 | member(PI, PIs), 438 | pi_head(PI, Head), 439 | predicate_property(M:Head, imported_from(chr)) 440 | -> true 441 | ). 442 | 443 | :- multifile system:term_expansion/2. 444 | :- dynamic system:term_expansion/2. 445 | 446 | system:term_expansion(In, Out) :- 447 | \+ current_prolog_flag(xref, true), 448 | in_chr_context, 449 | chr_expand(In, Out). 450 | 451 | %% SWI end 452 | 453 | %% SICStus begin 454 | % 455 | % :- dynamic 456 | % current_toplevel_show_store/1, 457 | % current_generate_debug_info/1, 458 | % current_optimize/1. 459 | % 460 | % current_toplevel_show_store(on). 461 | % 462 | % current_generate_debug_info(false). 463 | % 464 | % current_optimize(off). 465 | % 466 | % chr_current_prolog_flag(generate_debug_info, X) :- 467 | % chr_flag(generate_debug_info, X, X). 468 | % chr_current_prolog_flag(optimize, X) :- 469 | % chr_flag(optimize, X, X). 470 | % 471 | % chr_flag(Flag, Old, New) :- 472 | % Goal = chr_flag(Flag,Old,New), 473 | % g must_be(Flag, oneof([toplevel_show_store,generate_debug_info,optimize]), Goal, 1), 474 | % chr_flag(Flag, Old, New, Goal). 475 | % 476 | % chr_flag(toplevel_show_store, Old, New, Goal) :- 477 | % clause(current_toplevel_show_store(Old), true, Ref), 478 | % ( New==Old -> true 479 | % ; must_be(New, oneof([on,off]), Goal, 3), 480 | % erase(Ref), 481 | % assertz(current_toplevel_show_store(New)) 482 | % ). 483 | % chr_flag(generate_debug_info, Old, New, Goal) :- 484 | % clause(current_generate_debug_info(Old), true, Ref), 485 | % ( New==Old -> true 486 | % ; must_be(New, oneof([false,true]), Goal, 3), 487 | % erase(Ref), 488 | % assertz(current_generate_debug_info(New)) 489 | % ). 490 | % chr_flag(optimize, Old, New, Goal) :- 491 | % clause(current_optimize(Old), true, Ref), 492 | % ( New==Old -> true 493 | % ; must_be(New, oneof([full,off]), Goal, 3), 494 | % erase(Ref), 495 | % assertz(current_optimize(New)) 496 | % ). 497 | % 498 | % 499 | % all_stores_goal(Goal, CVAs) :- 500 | % chr_flag(toplevel_show_store, on, on), !, 501 | % findall(C-CVAs, find_chr_constraint(C), Pairs), 502 | % andify(Pairs, Goal, CVAs). 503 | % all_stores_goal(true, _). 504 | % 505 | % andify([], true, _). 506 | % andify([X-Vs|L], Conj, Vs) :- andify(L, X, Conj, Vs). 507 | % 508 | % andify([], X, X, _). 509 | % andify([Y-Vs|L], X, (X,Conj), Vs) :- andify(L, Y, Conj, Vs). 510 | % 511 | % :- multifile user:term_expansion/6. 512 | % 513 | % user:term_expansion(In, _, Ids, Out, [], [chr|Ids]) :- 514 | % nonvar(In), 515 | % nonmember(chr, Ids), 516 | % chr_expand(In, Out), !. 517 | % 518 | %% SICStus end 519 | 520 | %%% for SSS %%% 521 | 522 | add_pragma_to_chr_rule((Name @ Rule), Pragma, Result) :- 523 | !, 524 | add_pragma_to_chr_rule(Rule,Pragma,NRule), 525 | Result = (Name @ NRule). 526 | add_pragma_to_chr_rule((Rule pragma Pragmas), Pragma, Result) :- 527 | !, 528 | Result = (Rule pragma (Pragma,Pragmas)). 529 | add_pragma_to_chr_rule((Head ==> Body), Pragma, Result) :- 530 | !, 531 | Result = (Head ==> Body pragma Pragma). 532 | add_pragma_to_chr_rule((Head <=> Body), Pragma, Result) :- 533 | !, 534 | Result = (Head <=> Body pragma Pragma). 535 | add_pragma_to_chr_rule(Term,_,Term). 536 | 537 | 538 | /******************************* 539 | * SANDBOX SUPPORT * 540 | *******************************/ 541 | 542 | :- multifile 543 | sandbox:safe_primitive/1. 544 | 545 | % CHR uses a lot of global variables. We don't really mind as long as 546 | % the user does not mess around with global variable that may have a 547 | % predefined meaning. 548 | 549 | sandbox:safe_primitive(system:b_setval(V, _)) :- 550 | chr_var(V). 551 | sandbox:safe_primitive(system:nb_linkval(V, _)) :- 552 | chr_var(V). 553 | sandbox:safe_primitive(chr:debug_event(_,_)). 554 | sandbox:safe_primitive(chr:debug_interact(_,_,_)). 555 | 556 | chr_var(Name) :- sub_atom(Name, 0, _, _, '$chr'). 557 | chr_var(Name) :- sub_atom(Name, 0, _, _, 'chr'). 558 | 559 | 560 | /******************************* 561 | * SYNTAX HIGHLIGHTING * 562 | *******************************/ 563 | 564 | :- multifile 565 | prolog_colour:term_colours/2, 566 | prolog_colour:goal_colours/2. 567 | 568 | %! term_colours(+Term, -Colours) 569 | % 570 | % Colourisation of a toplevel term as read from the file. 571 | 572 | term_colours((_Name @ Rule), delimiter - [ identifier, RuleColours ]) :- 573 | !, 574 | term_colours(Rule, RuleColours). 575 | term_colours((Rule pragma _Pragma), delimiter - [RuleColours,pragma]) :- 576 | !, 577 | term_colours(Rule, RuleColours). 578 | term_colours((Head <=> Body), delimiter - [ HeadColours, BodyColours ]) :- 579 | !, 580 | chr_head(Head, HeadColours), 581 | chr_body(Body, BodyColours). 582 | term_colours((Head ==> Body), delimiter - [ HeadColours, BodyColours ]) :- 583 | !, 584 | chr_head(Head, HeadColours), 585 | chr_body(Body, BodyColours). 586 | 587 | chr_head(_C#_Id, delimiter - [ head, identifier ]) :- !. 588 | chr_head((A \ B), delimiter - [ AC, BC ]) :- 589 | !, 590 | chr_head(A, AC), 591 | chr_head(B, BC). 592 | chr_head((A, B), functor - [ AC, BC ]) :- 593 | !, 594 | chr_head(A, AC), 595 | chr_head(B, BC). 596 | chr_head(_, head). 597 | 598 | chr_body((Guard|Goal), delimiter - [ GuardColour, GoalColour ]) :- 599 | !, 600 | chr_body(Guard, GuardColour), 601 | chr_body(Goal, GoalColour). 602 | chr_body(_, body). 603 | 604 | 605 | %! goal_colours(+Goal, -Colours) 606 | % 607 | % Colouring of special goals. 608 | 609 | goal_colours(constraints(Decls), deprecated-[DeclColours]) :- 610 | chr_constraint_colours(Decls, DeclColours). 611 | goal_colours(chr_constraint(Decls), built_in-[DeclColours]) :- 612 | chr_constraint_colours(Decls, DeclColours). 613 | goal_colours(chr_type(TypeDecl), built_in-[DeclColours]) :- 614 | chr_type_decl_colours(TypeDecl, DeclColours). 615 | goal_colours(chr_option(Option,Value), built_in-[OpC,ValC]) :- 616 | chr_option_colours(Option, Value, OpC, ValC). 617 | 618 | chr_constraint_colours(Var, instantiation_error(Var)) :- 619 | var(Var), 620 | !. 621 | chr_constraint_colours((H,T), classify-[HeadColours,BodyColours]) :- 622 | !, 623 | chr_constraint_colours(H, HeadColours), 624 | chr_constraint_colours(T, BodyColours). 625 | chr_constraint_colours(PI, Colours) :- 626 | pi_to_term(PI, Goal), 627 | !, 628 | Colours = predicate_indicator-[ goal(constraint(0), Goal), 629 | arity 630 | ]. 631 | chr_constraint_colours(Goal, Colours) :- 632 | atom(Goal), 633 | !, 634 | Colours = goal(constraint(0), Goal). 635 | chr_constraint_colours(Goal, Colours) :- 636 | compound(Goal), 637 | !, 638 | compound_name_arguments(Goal, _Name, Args), 639 | maplist(chr_argspec, Args, ArgColours), 640 | Colours = goal(constraint(0), Goal)-ArgColours. 641 | 642 | chr_argspec(Term, mode(Mode)-[chr_type(Type)]) :- 643 | compound(Term), 644 | compound_name_arguments(Term, Mode, [Type]), 645 | chr_mode(Mode). 646 | 647 | chr_mode(+). 648 | chr_mode(?). 649 | chr_mode(-). 650 | 651 | pi_to_term(Name/Arity, Term) :- 652 | atom(Name), integer(Arity), Arity >= 0, 653 | !, 654 | functor(Term, Name, Arity). 655 | 656 | chr_type_decl_colours((Type ---> Def), built_in-[chr_type(Type), DefColours]) :- 657 | chr_type_colours(Def, DefColours). 658 | chr_type_decl_colours((Type == Alias), built_in-[chr_type(Type), chr_type(Alias)]). 659 | 660 | chr_type_colours(Var, classify) :- 661 | var(Var), 662 | !. 663 | chr_type_colours((A;B), control-[CA,CB]) :- 664 | !, 665 | chr_type_colours(A, CA), 666 | chr_type_colours(B, CB). 667 | chr_type_colours(T, chr_type(T)). 668 | 669 | chr_option_colours(Option, Value, identifier, ValCol) :- 670 | chr_option_range(Option, Values), 671 | !, 672 | ( nonvar(Value), 673 | memberchk(Value, Values) 674 | -> ValCol = classify 675 | ; ValCol = error 676 | ). 677 | chr_option_colours(_, _, error, classify). 678 | 679 | chr_option_range(check_guard_bindings, [on,off]). 680 | chr_option_range(optimize, [off, full]). 681 | chr_option_range(debug, [on, off]). 682 | 683 | prolog_colour:term_colours(Term, Colours) :- 684 | term_colours(Term, Colours). 685 | prolog_colour:goal_colours(Term, Colours) :- 686 | goal_colours(Term, Colours). 687 | --------------------------------------------------------------------------------