Commit b33944ca authored by Michael Hanus 's avatar Michael Hanus
Browse files

Adapted to version3

parent a40cca66
......@@ -5,13 +5,13 @@
--- as primitive constraints in CHR(Curry)
---
--- @author Michael Hanus
--- @version October 2016
--- @version July 2021
----------------------------------------------------------------------
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns -Wno-missing-signatures #-}
import CHR
import qualified List
import qualified Data.List
----------------------------------------------------------------------
-- Finite domain constraints in CHR (influence from SWI-Prolog manual)
......@@ -19,8 +19,8 @@ data FDom = Dom Int [Int] | Diff Int Int
dom = toGoal2 Dom
diff = toGoal2 Diff
intersect xs ys zs = anyPrim (\() -> zs =:= List.intersect xs ys)
delete x ys zs = anyPrim $ \() -> zs =:= List.delete x ys
intersect xs ys zs = anyPrim (\() -> zs =:= Data.List.intersect xs ys)
delete x ys zs = anyPrim $ \() -> zs =:= Data.List.delete x ys
member x xs = anyPrim $ \() -> contains x xs
where contains z (y:ys) = z=:=y ? contains z ys
......@@ -93,4 +93,5 @@ main55 [l1,l2,l3,l4] = labeling runFD2 $
diff l2 l4 /\ diff l3 l4 /\ l2 .=. 3 -- fix color of L2
compileFD = compileCHR "FDCHR" [dom1,dom2,dom3,dom4,diff1,diff2,diff3,diff4]
compileFD =
compileCHR "FDCHR" "FD" [dom1,dom2,dom3,dom4,diff1,diff2,diff3,diff4]
......@@ -2,7 +2,7 @@
--- CHR(Curry): using CHR to compute Fibonacci numbers with tabling
---
--- @author Michael Hanus
--- @version February 2015
--- @version July 2021
----------------------------------------------------------------------
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns -Wno-missing-signatures #-}
......@@ -38,5 +38,5 @@ runFib2 = runCHR [dup,fib1,fibn,addrule]
main41 x = runFib2 $ fib 7 x --> x=21
compileFib = compileCHR "FIBCHR" [fibo1,fibo2,fibo3,addrule]
compileFib = compileCHR "FIBCHR" "Fib" [fibo1,fibo2,fibo3,addrule]
-- solveCHR $ fib 20 x where x free
......@@ -2,7 +2,7 @@
--- CHR(Curry): use CHR to compute the greatest common divisor
---
--- @author Michael Hanus
--- @version February 2015
--- @version July 2021
----------------------------------------------------------------------
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns -Wno-missing-signatures #-}
......@@ -28,5 +28,5 @@ main30 = runGCD $ gcd 16 /\ gcd 28 --> gcd 4
main31 = runGCD $ gcd 206 /\ gcd 40 --> gcd 2
----------------------------------------------------------------------
compileGCD = compileCHR "GCDCHR" [gcda,gcd2]
compileGCD = compileCHR "GCDCHR" "GCD" [gcda,gcd2]
-- solveCHR $ gcdanswer x /\ gcd 206 /\ gcd 40 where x free
......@@ -2,15 +2,14 @@
--- CHR(Curry): solving linear arithmetic equations with Gaussian elimination
---
--- @author Michael Hanus
--- @version February 2015
--- @version July 2021
----------------------------------------------------------------------
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns -Wno-missing-signatures #-}
import CHR
import Float
import Sort(mergeSortBy)
import Unsafe(compareAnyTerm)
import Data.List ( sortBy )
import System.IO.Unsafe ( compareAnyTerm )
infix 7 :*:
infixr 6 :+:
......@@ -22,7 +21,8 @@ infix 5 :=:
type Poly = [(Float,Float)] -- a polynom is a list of (coeff,variable)
data Gauss = Equals Poly Float
| ArithOp (Float->Float->Float) Float Float Float
| Plus Float Float Float
| Mult Float Float Float
-- Notational abbreviations:
(:*:) :: Float -> Float -> Poly
......@@ -33,9 +33,8 @@ p :+: q = p ++ q
-- CHR constraints:
(:=:) = toGoal2 Equals
arithop = toGoal4 ArithOp
plus = arithop (+.)
mult = arithop (*.)
plus = toGoal3 Plus
mult = toGoal3 Mult
-- Specific primitive constraints:
-- Find and delete some element in a list.
......@@ -45,18 +44,18 @@ select x xs zs = anyPrim $ \() -> del xs zs
? (let q1 free in del p q1 & q =:= y:q1)
-- Multiply a polynomial p with a constant c.
polyMult c p q = anyPrim $ \() -> q =:= map (\ (a,x) -> (a*.c,x)) p
polyMult c p q = anyPrim $ \() -> q =:= map (\ (a,x) -> (a*c,x)) p
-- Add two polynomials
polyAdd ps qs rs = anyPrim $ \() ->
let ops = mergeSortBy (\ (_,x) (_,y) -> compareAnyTerm x y /= GT) ps
oqs = mergeSortBy (\ (_,x) (_,y) -> compareAnyTerm x y /= GT) qs
let ops = sortBy (\ (_,x) (_,y) -> compareAnyTerm x y /= GT) ps
oqs = sortBy (\ (_,x) (_,y) -> compareAnyTerm x y /= GT) qs
in rs =:= addP ops oqs
where
addP [] ys = ys
addP (x:xs) [] = x:xs
addP ((i,x):xs) ((j,y):ys)
| compareAnyTerm x y == EQ = (i+.j,x) : addP xs ys
| compareAnyTerm x y == EQ = (i+j,x) : addP xs ys
| compareAnyTerm x y == LT = (i,x) : addP xs ((j,y):ys)
| otherwise = (j,y) : addP ((i,x):xs) ys
......@@ -64,27 +63,26 @@ polyAdd ps qs rs = anyPrim $ \() ->
-- main rule: eliminate a term in a polynomial:
eliminate [a,x,c1,c2,b,c,c1c,c3] = let p,p1,p2,p1c,p3 free in
((a,x):p1) :=: c1 \\ p :=: c2 <=> select (b,x) p p2 |>
c .=. 0.0 -. b /. a /\
c .=. 0.0 - b / a /\
mult c1 c c1c /\ polyMult c p1 p1c /\
plus c1c c2 c3 /\ polyAdd p2 p1c p3 /\
p3 :=: c3
-- remove constant monomials:
constM [a,x,c] = let p,q free in
p :=: c <=> select (a,x) p q /\ nonvar x |> q :=: (c -. a *. x)
p :=: c <=> select (a,x) p q /\ nonvar x |> q :=: (c - a * x)
-- empty polynomials have zero value:
emptyP [c] = [] :=: c <=> c .=. 0.0
-- bind a variable if unique:
bindVar [a,x,c] = [(a,x)] :=: c <=> x .=. c /. a
bindVar [a,x,c] = [(a,x)] :=: c <=> x .=. c / a
-- Simplify arithmetic relations:
arithrule [x,y,z] = arithop op x y z <=> nonvar x /\ nonvar y |>
z .=. x `op` y
where op free
evalPlus [x,y,z] = plus x y z <=> nonvar x /\ nonvar y |> z .=. x + y
evalMult [x,y,z] = mult x y z <=> nonvar x /\ nonvar y |> z .=. x * y
runGauss = runCHR [arithrule,emptyP,constM,eliminate,bindVar]
runGauss = runCHR [evalPlus,evalMult,emptyP,constM,eliminate,bindVar]
main80 x y = runGauss $ 3:*:x :=: 6 /\ 2:*:x :+: 6:*:y :=: 10.0
main81 x y = runGauss $
......@@ -117,6 +115,8 @@ main86 i = runGauss $ cvi (Parallel (Resistor 180) (Resistor 470)) 5 i
-- i=0.038416075650118
----------------------------------------------------------------------
compileGauss = compileCHR "GAUSSCHR" [arithrule,emptyP,constM,eliminate,bindVar]
-- [(3.0,x)] :=: 6.0 /\ [(2.0,x),(6.0,y)] :=: 10.0
--> x=2.0, y=1.0
compileGauss =
compileCHR "GAUSSCHR" "Gauss"
[evalPlus, evalMult, emptyP, constM, eliminate, bindVar]
-- solveCHR $ [(3.0,x)] :=: 6.0 /\ [(2.0,x),(6.0,y)] :=: 10.0
-- --> x=2.0, y=1.0
......@@ -2,7 +2,7 @@
--- CHR(Curry): the classical Leq example
---
--- @author Michael Hanus
--- @version February 2015
--- @version July 2021
----------------------------------------------------------------------
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns -Wno-missing-signatures #-}
......@@ -30,4 +30,4 @@ main11 x y z = runLEQ $ leq x y /\ leq y z /\ leq z x
main12 x y z z' = runLEQ $ leq x y /\ leq z z'
compileLeq =
compileCHR "LEQCHR" [reflexivity,antisymmetry,idempotence,transitivity]
compileCHR "LEQCHR" "Leq" [reflexivity,antisymmetry,idempotence,transitivity]
Loading program "Leq"...
main10 x
Loading program Leq
main10
{x=1} []
main11 x y z
main11
{x=x, y=x, z=x} []
main12 x y z z'
main12
{x=x, y=y, z=z, z'=z'} [Leq z z',Leq x y]
Loading program "Bool"...
main20 x y z
Loading program Bool
main20
{x=True, y=True, z=True} []
main21 a b s c
main21
{a=True, b=True, s=False, c=True} []
main22 a b s c
main22
{a=a, b=b, s=s, c=False} [And a b False,Or a b s]
Loading program "GCD"...
runGCD $ ((gcd 16) /\ (gcd 28))
Loading program GCD
main30
[GCD 4]
runGCD $ ((gcd 206) /\ (gcd 40))
main31
[GCD 2]
compileCHR "GCDCHR" [gcda,gcd2]
Curry interface to CHR(Prolog) written to GCDCHR.curry
Loading program "GCDCHR"...
solveCHR $ ((gcdanswer x) /\ ((gcd 206) /\ (gcd 40)))
Loading program GCDCHR
solveCHR $ gcdanswer x / gcd 206 / gcd 40 where x free
{x=2} True
Loading program "Fib"...
(runCHR [dup,fib1,fibn,addrule]) $ ((fib 7) x)
Loading program Fib
main41
{x=21} [Fib 7 21,Fib 4 5,Fib 2 2,Fib 3 3,Fib 5 8,Fib 6 13]
compileCHR "FIBCHR" [fibo1,fibo2,fibo3,addrule]
Curry interface to CHR(Prolog) written to FIBCHR.curry
Loading program "FIBCHR"...
solveCHR $ (fib 20 x)
Loading program FIBCHR
solveCHR $ fib 20 x where x free
{x=10946} True
Loading program "FD"...
main50 x y
Loading program FD
main50
{x=1, y=1} []
main51 x
main51
{x=3} []
main52 [x,y,z]
main52
{x=2, y=2, z=2} []
main53 xs
main53
{xs=[2,3,1]} []
{xs=[3,2,1]} []
{xs=[1,3,2]} []
{xs=[3,1,2]} []
{xs=[1,2,3]} []
{xs=[2,1,3]} []
main55 xs
main55
{xs=[4,3,2,1]} []
{xs=[2,3,4,1]} []
{xs=[4,3,1,2]} []
{xs=[1,3,4,2]} []
{xs=[2,3,1,4]} []
{xs=[1,3,2,4]} []
Loading program "UnionFind"...
Loading program UnionFind
main60
[Root 1,Arrow 2 1,Root 4,Root 3]
main61 x
main61
{x=1} [Root 4,Root 3,Arrow 2 1,Root 1]
main62 x y
main62
{x=1, y=3} [Root 4,Arrow 2 1,Arrow 1 3,Root 3]
main63
[Root 5,Arrow 3 5,Arrow 4 3,Root 1,Arrow 2 1]
main64 x y
main64
{x=1, y=5} [Root 1,Arrow 2 1,Arrow 4 3,Arrow 3 5,Root 5]
main65 x y
main65
{x='a', y='e'} [Root 'a',Arrow 'b' 'a',Arrow 'd' 'c',Arrow 'c' 'e',Root 'e']
compileCHR "UFCHR" [makeI,unionI,findNode,findRoot,linkEq,linkTo]
Curry interface to CHR(Prolog) written to UFCHR.curry
Loading program "UFCHR"...
solveCHR $ (andCHR [make 1,make 2,make 3,make 4,make 5,union 1 2,union 3 4,union 5 3,find 2 x,find 4 y])
Loading program UFCHR
solveCHR $ andCHR [make 1, make 2, make 3, make 4, make 5, union 1 2, union 3 4, union 5 3, find 2 x, find 4 y] where x,y free
{x=1, y=5} True
Loading program "Primes"...
runPrime $ (prime 20)
Loading program Primes
main70
[Prime 2,Prime 19,Prime 17,Prime 3,Prime 13,Prime 11,Prime 7,Prime 5]
Loading program "Gauss"...
main80 x y
Loading program Gauss
main80
{x=2.0, y=1.0} []
main81 x y
main81
{x=5.0, y=2.0} []
main82 x y
main82
{x=2.0, y=2.0} []
main85 i
main85
{i=0.007692307692307692} []
main86 i
main86
{i=0.0384160756501182} []
compileCHR "GAUSSCHR" [arithrule,emptyP,constM,eliminate,bindVar]
Curry interface to CHR(Prolog) written to GAUSSCHR.curry
Loading program "GAUSSCHR"...
......@@ -2,7 +2,7 @@
--- CHR(Curry): union-find algorithm in CHR
---
--- @author Michael Hanus
--- @version February 2015
--- @version July 2021
----------------------------------------------------------------------
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns -Wno-missing-signatures #-}
......@@ -53,6 +53,7 @@ main65 x y =
find 'b' x, find 'd' y] --> x='a', y='e'
compileUF = compileCHR "UFCHR" [makeI,unionI,findNode,findRoot,linkEq,linkTo]
compileUF =
compileCHR "UFCHR" "UnionFind" [makeI,unionI,findNode,findRoot,linkEq,linkTo]
-- solveCHR $ andC [make 1, make 2, make 3, make 4, make 5, union 1 2, union 3 4, union 5 3, find 2 x, find 4 y]
--> x=1, y=5
......@@ -2,83 +2,114 @@
# Shell script to test the current set of CHR(Curry) examples
# Root location of the Curry System specified by variable CURRYROOT
CURRYROOT=`$CURRYBIN :set v0 :set -time :add Distribution :eval "putStrLn installDir" :quit`
CURRYROOT=`$CURRYBIN :set v0 :set -time :add Curry.Compiler.Distribution :eval "putStrLn installDir" :quit`
CURRYBINDIR=$CURRYROOT/bin
BACKEND=`$CURRYBIN --noreadline :set v0 :set -time :load Distribution :eval "putStrLn (curryRuntime ++ show curryRuntimeMajorVersion)" :quit 2> /dev/null`
BACKEND=`$CURRYBIN --noreadline :set v0 :set -time :load Curry.Compiler.Distribution :eval "putStrLn (curryRuntime ++ show curryRuntimeMajorVersion)" :quit 2> /dev/null`
VERBOSE=no
if [ "$1" = "-v" ] ; then
VERBOSE=yes
fi
if [ "$BACKEND" != sicstus4 -a "$BACKEND" != swi6 -a "$BACKEND" != swi7 ] ; then
if [ "$BACKEND" != sicstus4 -a "$BACKEND" != swi6 -a "$BACKEND" != swi7 -a "$BACKEND" != swi8 ] ; then
echo "No appropriate Prolog back end, skip the CHR tests."
exit
fi
LOGFILE=xxx$$
$CURRYBINDIR/cleancurry
cat << EOM | $CURRYBIN -q :set -interactive :set v0 :set printdepth 0 :set +verbose :set -time > $LOGFILE
cat << EOM | $CURRYBIN -q :set -interactive :set v0 :set printdepth 0 :set -time | tee $LOGFILE
:!echo Loading program Leq
:load Leq
:!echo main10
main10 x where x free
:!echo main11
main11 (x::Int) y z where x,y,z free
:!echo main12
main12 (x::Int) y z z' where x,y,z,z' free
:!echo Loading program Bool
:load Bool
:!echo main20
main20 x y z where x,y,z free
:!echo main21
main21 a b s c where a,b,s,c free
:!echo main22
main22 a b s c where a,b,s,c free
:!echo Loading program GCD
:load GCD
:add CHR
runGCD $ gcd 16 /\ gcd 28
runGCD $ gcd 206 /\ gcd 40
compileCHR "GCDCHR" [gcda,gcd2]
:!echo main30
main30
:!echo main31
main31
compileGCD
:!echo Loading program GCDCHR
:load GCDCHR
:!echo solveCHR $ gcdanswer x /\ gcd 206 /\ gcd 40 where x free
solveCHR $ gcdanswer x /\ gcd 206 /\ gcd 40 where x free
:!echo Loading program Fib
:load Fib
:add CHR
runCHR [dup,fib1,fibn,addrule] $ fib 7 x where x free
compileCHR "FIBCHR" [fibo1,fibo2,fibo3,addrule]
:!echo main41
main41 x where x free
compileFib
:!echo Loading program FIBCHR
:load FIBCHR
:!echo solveCHR $ fib 20 x where x free
solveCHR $ fib 20 x where x free
:!echo Loading program FD
:load FD
:!echo main50
main50 x y where x,y free
:!echo main51
main51 x where x free
:!echo main52
main52 [x,y,z] where x,y,z free
:!echo main53
main53 xs where xs free
:!echo main55
main55 xs where xs free
:!echo Loading program UnionFind
:load UnionFind
:!echo main60
main60
:!echo main61
main61 x where x free
:!echo main62
main62 x y where x,y free
:!echo main63
main63
:!echo main64
main64 x y where x,y free
:!echo main65
main65 x y where x,y free
:add CHR
compileCHR "UFCHR" [makeI,unionI,findNode,findRoot,linkEq,linkTo]
compileUF
:!echo Loading program UFCHR
:load UFCHR
:!echo solveCHR $ andCHR [make 1, make 2, make 3, make 4, make 5, union 1 2, union 3 4, union 5 3, find 2 x, find 4 y] where x,y free
solveCHR $ andCHR [make 1, make 2, make 3, make 4, make 5, union 1 2, union 3 4, union 5 3, find 2 x, find 4 y] where x,y free
:!echo Loading program Primes
:load Primes
runPrime $ prime 20
:!echo main70
main70
:!echo Loading program Gauss
:load Gauss
:!echo main80
main80 x y where x,y free
:!echo main81
main81 x y where x,y free
:!echo main82
main82 x y where x,y free
:!echo main85
main85 i where i free
:!echo main86
main86 i where i free
:add CHR
compileCHR "GAUSSCHR" [arithrule,emptyP,constM,eliminate,bindVar]
:load GAUSSCHR
:add Gauss
-- omitted due to compilation problems:
-- solveCHR $ 3.0:*:x GAUSSCHR.:=: 6.0 /\ 2.0:*:x :+: 6.0:*:y GAUSSCHR.:=: 10.0 where x,y free
EOM
# clean up:
......
{
"name": "chr-curry",
"version": "2.1.0",
"version": "3.0.0",
"author": "Michael Hanus <mh@informatik.uni-kiel.de>",
"synopsis": "A library to use Constraint Handling Rules in Curry programs",
"category": [ "Constraints" ],
"dependencies": {
"base" : ">= 1.1.0, < 2.0.0",
"flatcurry" : ">= 2.0.0",
"prolog" : ">= 1.0.0",
"redblacktree" : ">= 0.0.1",
"searchtree" : ">= 1.0.0",
"wl-pprint" : ">= 0.0.1",
"xml" : ">= 2.0.0"
"base" : ">= 3.0.0, < 4.0.0",
"flatcurry" : ">= 3.0.0, < 4.0.0",
"prolog" : ">= 3.0.0, < 4.0.0",
"redblacktree" : ">= 3.0.0, < 4.0.0",
"searchtree" : ">= 3.0.0, < 4.0.0",
"wl-pprint" : ">= 3.0.0, < 4.0.0",
"xml" : ">= 3.0.0, < 4.0.0"
},
"exportedModules": [ "CHR" ],
"description": "This package provides an implementation of Constraint Handling Rules in Curry.",
"compilerCompatibility": {
"pakcs": ">= 2.2.1, < 3.0.0"
"pakcs": ">= 3.0.0, < 4.0.0"
},
"license": "BSD-3-Clause",
"licenseFile": "LICENSE",
......
This diff is collapsed.
......@@ -9,7 +9,6 @@
---
--- @author Michael Hanus
--- @version February 2015
--- @category general
----------------------------------------------------------------------
module CHRcompiled where
......@@ -59,3 +58,4 @@ solveCHR (Goal g) | g = warnSuspendedConstraints True
warnSuspendedConstraints :: Bool -> Bool
warnSuspendedConstraints external
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment