├── hie.yaml ├── inputs ├── mult.pot ├── qrev.pot ├── plusplus.pot ├── appapp.pot ├── append.pot ├── pluscomm.pot ├── issue7.pot ├── pluscomm2.pot ├── plusassoc.pot ├── pluscomm3.pot ├── issue15.pot ├── nrev3.pot ├── nonterm.pot ├── maprev.pot ├── eWizeOp.pot ├── revrev.pot ├── neil1.pot ├── neil3.pot ├── ack.pot ├── nrev.pot ├── linAlgebra_problem.pot ├── mult3.pot ├── mapfold.pot ├── issue16.pot ├── fib2.pot ├── sumfac.pot ├── mult2.pot ├── nesting1.pot ├── fib.pot ├── neil2.pot ├── nrev2.pot ├── multdistilled.pot ├── nesting2.pot ├── isort.pot ├── treeSum.pot ├── example3.pot ├── nesting3.pot ├── example1.pot ├── gcd2.pot ├── example2.pot ├── Bool.pot ├── issue9.pot ├── gcd.pot ├── gcd3.pot ├── mcv.pot ├── NatList.pot ├── issue10.pot ├── test.pot ├── msort.pot ├── palindrome.pot ├── Nat.pot ├── issue11.pot ├── issue12.pot ├── issue12distilled.pot └── linearAlgebra.pot ├── ChangeLog.md ├── examples ├── KronMask.pot ├── MAdds.pot ├── Masks.pot ├── Bool.pot ├── mAddDistilled.pot ├── MasksDistilled.pot ├── KronMaskDistilled.pot ├── QTree.pot ├── mAddAddDistilled.pot └── MAddsDistilled.pot ├── .gitignore ├── stack.yaml.lock ├── src ├── Exception.hs ├── Main.hs ├── Trans.hs ├── Tree.hs └── Term.hs ├── package.yaml ├── .vscode └── tasks.json ├── LICENSE ├── distiller.cabal ├── README.md └── stack.yaml /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | stack: 3 | -------------------------------------------------------------------------------- /inputs/mult.pot: -------------------------------------------------------------------------------- 1 | import Nat 2 | 3 | main = mul x y -------------------------------------------------------------------------------- /inputs/qrev.pot: -------------------------------------------------------------------------------- 1 | import NatList 2 | 3 | main = qrev xs [] 4 | 5 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for distiller 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /inputs/plusplus.pot: -------------------------------------------------------------------------------- 1 | import Nat 2 | 3 | main = plus x x 4 | 5 | 6 | -------------------------------------------------------------------------------- /inputs/appapp.pot: -------------------------------------------------------------------------------- 1 | import NatList 2 | 3 | main = append (append xs ys) zs 4 | -------------------------------------------------------------------------------- /inputs/append.pot: -------------------------------------------------------------------------------- 1 | import NatList 2 | 3 | main = append xs ys 4 | 5 | 6 | 7 | -------------------------------------------------------------------------------- /inputs/pluscomm.pot: -------------------------------------------------------------------------------- 1 | import Nat 2 | 3 | main = eqNat (plus x y) (plus y x) 4 | 5 | 6 | -------------------------------------------------------------------------------- /inputs/issue7.pot: -------------------------------------------------------------------------------- 1 | import NatList 2 | 3 | main = map inc (qrev xs Nil); 4 | 5 | inc n = Succ(n) -------------------------------------------------------------------------------- /inputs/pluscomm2.pot: -------------------------------------------------------------------------------- 1 | import Nat 2 | 3 | main = eqNat (plus x Succ(y)) (plus y Succ(x)) 4 | 5 | 6 | -------------------------------------------------------------------------------- /inputs/plusassoc.pot: -------------------------------------------------------------------------------- 1 | import Nat 2 | 3 | main = eqNat (plus x (plus y z)) (plus (plus x y) z) 4 | 5 | 6 | -------------------------------------------------------------------------------- /inputs/pluscomm3.pot: -------------------------------------------------------------------------------- 1 | import Nat 2 | 3 | main = eqNat (plus x Succ(Succ(y))) (plus y Succ(Succ(x))) 4 | 5 | 6 | -------------------------------------------------------------------------------- /examples/KronMask.pot: -------------------------------------------------------------------------------- 1 | import Bool 2 | import QTree 3 | import Matrices 4 | 5 | main = kron (not) (or) (mask m1 msk) (m2) 6 | 7 | -------------------------------------------------------------------------------- /examples/MAdds.pot: -------------------------------------------------------------------------------- 1 | import Bool 2 | import QTree 3 | import Matrices 4 | 5 | main = mAdd (not) (or) (mAdd (not) (or) (m1) (m2)) (m3) 6 | 7 | -------------------------------------------------------------------------------- /inputs/issue15.pot: -------------------------------------------------------------------------------- 1 | main = map f xs; 2 | 3 | map g xs = 4 | case xs of 5 | Nil -> Nil 6 | | Cons(x, xs1) -> Cons(g x, map g xs1) -------------------------------------------------------------------------------- /inputs/nrev3.pot: -------------------------------------------------------------------------------- 1 | main = f xs (\x->x); 2 | f xs g = case xs of 3 | Nil -> g Nil 4 | | Cons(x,xs) -> f xs (\xs->Cons(x,g xs)) 5 | -------------------------------------------------------------------------------- /inputs/nonterm.pot: -------------------------------------------------------------------------------- 1 | main = f x y; 2 | 3 | f x y = case x of 4 | Zero -> y 5 | | Succ(x') -> f x y 6 | 7 | 8 | 9 | 10 | -------------------------------------------------------------------------------- /examples/Masks.pot: -------------------------------------------------------------------------------- 1 | import Bool 2 | import QTree 3 | import Matrices 4 | 5 | main = mask (mask m1 msk1) msk2; 6 | 7 | isZ x = case x of 8 | True -> False 9 | | False -> True 10 | 11 | -------------------------------------------------------------------------------- /inputs/maprev.pot: -------------------------------------------------------------------------------- 1 | import NatList 2 | 3 | main = map inc (qrev xs []); 4 | 5 | map f xs = case xs of 6 | Nil -> Nil 7 | | Cons(x,xs) -> Cons(f x,map f xs); 8 | 9 | inc n = Succ(n) 10 | -------------------------------------------------------------------------------- /inputs/eWizeOp.pot: -------------------------------------------------------------------------------- 1 | main = eWizeOp g s2 (eWizeOp g s m) ; 2 | 3 | eWizeOp g s m = 4 | case m of 5 | Val (v1) -> (Val (g v1 s)) 6 | | Node (q1, q2) -> (Node ((eWizeOp g s q1), (eWizeOp g s q2))) 7 | 8 | 9 | -------------------------------------------------------------------------------- /inputs/revrev.pot: -------------------------------------------------------------------------------- 1 | import NatList 2 | 3 | main = revrev xs Nil; 4 | 5 | revrev xs ys = case xs of 6 | Nil -> ys 7 | | Cons(x,xs) -> append (revrev xs (Cons(x,ys))) Cons(x,Nil) 8 | 9 | 10 | -------------------------------------------------------------------------------- /inputs/neil1.pot: -------------------------------------------------------------------------------- 1 | import Nat 2 | 3 | main = f x x; 4 | 5 | f x y = case x of 6 | Zero -> g y 7 | | Succ(x') -> f x' y; 8 | 9 | g y = case y of 10 | Zero -> Zero 11 | | Succ(y') -> g y' 12 | 13 | -------------------------------------------------------------------------------- /inputs/neil3.pot: -------------------------------------------------------------------------------- 1 | import NatList 2 | 3 | main = f xs; 4 | 5 | f xs = case xs of 6 | Nil -> True 7 | | Cons(x,xs) -> case (f xs) of 8 | True -> f xs 9 | | False -> False 10 | -------------------------------------------------------------------------------- /inputs/ack.pot: -------------------------------------------------------------------------------- 1 | main = ack m n; 2 | 3 | ack m n = case m of 4 | Zero -> Succ(n) 5 | | Succ(m') -> case n of 6 | Zero -> ack m' Succ(Zero) 7 | | Succ(n') -> ack m' (ack m n') 8 | 9 | 10 | -------------------------------------------------------------------------------- /inputs/nrev.pot: -------------------------------------------------------------------------------- 1 | main = nrev xs; 2 | 3 | append xs ys = case xs of 4 | Nil -> ys 5 | | Cons(x,xs) -> Cons(x,append xs ys); 6 | 7 | nrev xs = case xs of 8 | Nil -> Nil 9 | | Cons(x,xs) -> append (nrev xs) Cons(x,Nil) 10 | -------------------------------------------------------------------------------- /inputs/linAlgebra_problem.pot: -------------------------------------------------------------------------------- 1 | main = 2 | -- FAIL 3 | eWizeOp g1 (eWizeOp g1 m) 4 | 5 | -- OK 6 | -- eWizeOp g (eWizeOp g2 m) 7 | ; 8 | 9 | eWizeOp g m = 10 | case m of 11 | Val (v1) -> (Val (g v1)) 12 | | Node (q1, q2) -> (Node ((eWizeOp g q1), (eWizeOp g q2))) -------------------------------------------------------------------------------- /inputs/mult3.pot: -------------------------------------------------------------------------------- 1 | main = case x of 2 | Zero -> 0 3 | | Succ(x') -> f x' y (\x -> x); 4 | f x y g = case y of 5 | Zero -> (f' x g) 6 | | Succ(y') -> Succ(f x y' (\x -> Succ(g x))); 7 | f' x g = case x of 8 | Zero -> Zero 9 | | Succ(x') -> g (f' x' g) -------------------------------------------------------------------------------- /inputs/mapfold.pot: -------------------------------------------------------------------------------- 1 | import Bool 2 | 3 | main = fold or (False) (map not l); 4 | 5 | map f l = 6 | case l of 7 | Nil -> Nil 8 | | Cons(hd, tl) -> Cons(f hd,map f tl); 9 | 10 | fold f s l = 11 | case l of 12 | Nil -> s 13 | | Cons(hd, tl) -> fold f (f s hd) tl 14 | -------------------------------------------------------------------------------- /inputs/issue16.pot: -------------------------------------------------------------------------------- 1 | main = map g xs; 2 | 3 | map g xs = map1 Nil g xs; 4 | 5 | map1 res g xs = 6 | case xs of 7 | Nil -> res 8 | | Cons(x, xs1) -> map1 (push res (g x)) g xs1; 9 | 10 | push xs c = 11 | case xs of 12 | Nil -> Cons(c, Nil) 13 | | Cons(x, xs1) -> Cons(x, (push xs1 c)) -------------------------------------------------------------------------------- /inputs/fib2.pot: -------------------------------------------------------------------------------- 1 | main = fib n (\x->x) (\x->x); 2 | 3 | fib n f g = case n of 4 | Zero -> f 1 5 | | Succ(n) -> case n of 6 | Zero -> g 1 7 | | Succ(n) -> fib n (\x -> f (g Succ(x))) (\y -> g (f (g Succ(Succ(y))))) 8 | 9 | 10 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | cabal.project.local~ 21 | .HTF/ 22 | .ghc.environment.* 23 | -------------------------------------------------------------------------------- /inputs/sumfac.pot: -------------------------------------------------------------------------------- 1 | import Nat 2 | 3 | main = loop n 1; 4 | 5 | loop n s = case n of 6 | Zero -> s 7 | | Succ(n') -> loop' n Succ(Zero) n' s; 8 | 9 | loop' i p n s = case i of 10 | Zero -> loop n (plus s p) 11 | | Succ(i') -> loop' i' (mul i p) n s 12 | 13 | -------------------------------------------------------------------------------- /inputs/mult2.pot: -------------------------------------------------------------------------------- 1 | import Nat 2 | 3 | main = case x of 4 | Zero -> 0 5 | | Succ(x') -> (f y x' y (\x y g -> f x y x g)); 6 | f x y z g = case x of 7 | Zero -> (case y of 8 | Zero -> Zero 9 | | Succ(y') -> g z y' g) 10 | | Succ(x') -> Succ(f x' y z g) 11 | 12 | 13 | -------------------------------------------------------------------------------- /inputs/nesting1.pot: -------------------------------------------------------------------------------- 1 | main = g m n u v m n'; 2 | 3 | g m n u v x y = case x of 4 | Zero -> Tuple(m,n,u,v,x,y) 5 | | Succ(x') -> h m Succ(n) Succ(u) Zero x' n; 6 | 7 | h m n u v x y = case y of 8 | Zero -> g m n u v x y 9 | | Succ(y') -> h m n u Succ(v) x y' 10 | 11 | -------------------------------------------------------------------------------- /inputs/fib.pot: -------------------------------------------------------------------------------- 1 | main = fib n; 2 | 3 | fib n = case n of 4 | Zero -> Succ(Zero) 5 | | Succ(n) -> case n of 6 | Zero -> Succ(Zero) 7 | | Succ(n') -> add (fib n') (fib n); 8 | 9 | add m n = case m of 10 | Zero -> n 11 | | Succ(m) -> Succ(add m n) 12 | 13 | -------------------------------------------------------------------------------- /inputs/neil2.pot: -------------------------------------------------------------------------------- 1 | import Nat 2 | 3 | main = f x x; 4 | 5 | f x y = case x of 6 | Zero -> g y 7 | | Succ(x') -> f x' y; 8 | 9 | g z = case z of 10 | Zero -> Zero 11 | | Succ(z') -> case z' of 12 | Zero -> Succ(Succ(Zero)) 13 | | Succ(z'') -> g z'' 14 | 15 | -------------------------------------------------------------------------------- /inputs/nrev2.pot: -------------------------------------------------------------------------------- 1 | main = nrev2 xs; 2 | 3 | nrev2 xs = 4 | case xs of 5 | Nil -> Nil 6 | | Cons(a, as) -> Cons(last a as, nrev2 (cutlast a as)); 7 | 8 | last b bs = 9 | case bs of 10 | Nil -> b 11 | | Cons(c, cs) -> last c cs; 12 | 13 | cutlast d ds = 14 | case ds of 15 | Nil -> Nil 16 | | Cons(e, es) -> Cons(d, cutlast e es) -------------------------------------------------------------------------------- /inputs/multdistilled.pot: -------------------------------------------------------------------------------- 1 | main = case y of 2 | Zero -> (case x' of 3 | Zero -> 0 4 | | Succ(x') -> f y x' y) 5 | | Succ(x'') -> Succ(f x'' x' y); 6 | f y x' x = case y of 7 | Zero -> (case x' of 8 | Zero -> 0 9 | | Succ(x') -> f x x' x) 10 | | Succ(x'') -> Succ(f x'' x' x) -------------------------------------------------------------------------------- /inputs/nesting2.pot: -------------------------------------------------------------------------------- 1 | main = case n of 2 | Zero -> Tuple(m,n,u,v,m,n) 3 | | Succ(n') -> f m Succ(n') u Zero m n'; 4 | 5 | f m n u v x y = case y of 6 | Zero -> g m n u v x 7 | | Succ(y') -> f m n u Succ(v) x y'; 8 | 9 | g m n u v x = case x of 10 | Zero -> Tuple(m,n,u,v,Zero,Zero) 11 | | Succ(x') -> g m Succ(n) Succ(u) Succ(v) x' -------------------------------------------------------------------------------- /inputs/isort.pot: -------------------------------------------------------------------------------- 1 | import NatList 2 | 3 | main = isort xs; 4 | 5 | isort xs = case xs of 6 | Nil -> Nil 7 | | Cons(x,xs) -> insert x (isort xs); 8 | 9 | insert y xs = case xs of 10 | Nil -> Cons(y,Nil) 11 | | Cons(z,zs) -> case (gt z y) of 12 | True -> Cons(y,Cons(z,zs)) 13 | | False -> Cons(z,insert y zs) 14 | 15 | 16 | -------------------------------------------------------------------------------- /inputs/treeSum.pot: -------------------------------------------------------------------------------- 1 | main = treeSum (treeIncr (treeDouble tree)); 2 | 3 | treeFold f b t = case t of 4 | Empty -> b 5 | | Node(l,x,r) -> f (treeFold f b l) x (treeFold f b r); 6 | 7 | treeMap f t = case t of 8 | Empty -> Empty 9 | | Node(l,x,r) -> Node(treeMap f l,f x,treeMap f r); 10 | 11 | treeDouble t = treeMap double t; 12 | 13 | treeIncr t = treeMap incr t; 14 | 15 | treeSum t = treeFold (\l x r -> add l (add x r)) 0 t -------------------------------------------------------------------------------- /inputs/example3.pot: -------------------------------------------------------------------------------- 1 | main = mOp op m; 2 | 3 | reduceTree n1 n2 nd = 4 | case n1 of 5 | None -> (case n2 of 6 | None -> None 7 | | Val (v1) -> nd 8 | | Node (m1,m2) -> nd) 9 | | Val(v2) -> nd 10 | | Node(l1,l2) -> nd; 11 | 12 | mOp g m = 13 | case m of 14 | None -> None 15 | | Val(v1) -> g v1 16 | | Node(q1,q2) -> reduceTree (mOp g q1) (mOp g q2) (Node(q1,q2)) 17 | 18 | -------------------------------------------------------------------------------- /inputs/nesting3.pot: -------------------------------------------------------------------------------- 1 | main = case n of 2 | Zero -> Tuple(m,0,u,v,m,0) 3 | | Succ(n') -> f' n' m n' u 0; 4 | f' x'' m x u x' = case x'' of 5 | Zero -> f'' m m x u x' 6 | | Succ(y') -> f' y' m x u Succ(x'); 7 | f'' x''''''' x''' x'''' x''''' x'''''' = case x''''''' of 8 | Zero -> Tuple(x''',Succ(x''''),x''''',x'''''',0,0) 9 | | Succ(x') -> f'' x' x''' Succ(x'''') Succ(x''''') Succ(x'''''') -------------------------------------------------------------------------------- /inputs/example1.pot: -------------------------------------------------------------------------------- 1 | main = mOp op m; 2 | 3 | reduceTree n1 n2 = 4 | let nd = (Node (n1, n2)) in 5 | (case n1 of 6 | None -> (case n2 of 7 | None -> None 8 | | Val (v1) -> nd 9 | | Node (m1, m2) -> nd) 10 | | Val (v2) -> nd 11 | | Node (l1, l2) -> nd); 12 | 13 | mOp g m = 14 | case m of 15 | None -> None 16 | | Val (v1) -> (g v1) 17 | | Node (q1, q2) -> (reduceTree (mOp g q1) (mOp g q2)) -------------------------------------------------------------------------------- /inputs/gcd2.pot: -------------------------------------------------------------------------------- 1 | main = f0 x y; 2 | 3 | f0 a b = case a of 4 | Zero -> b 5 | | Succ(a) -> case b of 6 | Zero -> Succ(a) 7 | | Succ(b) -> f1 a b a b; 8 | 9 | f1 a b c d = case a of 10 | Zero -> (case b of 11 | Zero -> Succ(c) 12 | | Succ(b) -> f1 c b c b) 13 | | Succ(a) -> (case b of 14 | Zero -> f1 d a d a 15 | | Succ(b) -> f1 a b c d) -------------------------------------------------------------------------------- /inputs/example2.pot: -------------------------------------------------------------------------------- 1 | main = mOp op m; 2 | 3 | reduceTree n1 n2 = 4 | (case n1 of 5 | None -> (case n2 of 6 | None -> None 7 | | Val (v1) -> (Node (n1, n2)) 8 | | Node (m1, m2) -> (Node (n1, n2))) 9 | | Val (v2) -> (Node (n1, n2)) 10 | | Node (l1, l2) -> (Node (n1, n2))); 11 | 12 | mOp g m = 13 | case m of 14 | None -> None 15 | | Val (v1) -> (g v1) 16 | | Node (q1, q2) -> (reduceTree (mOp g q1) (mOp g q2)) -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 585817 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/5.yaml 11 | sha256: 22d24d0dacad9c1450b9a174c28d203f9bb482a2a8da9710a2f2a9f4afee2887 12 | original: 13 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/5.yaml 14 | -------------------------------------------------------------------------------- /src/Exception.hs: -------------------------------------------------------------------------------- 1 | module Exception where 2 | 3 | import Control.Monad (ap,liftM) 4 | import Debug.Trace 5 | 6 | data Exception a b = Exn a | NoExn b deriving Show 7 | 8 | instance Functor (Exception a) where 9 | fmap = liftM 10 | 11 | instance Applicative (Exception a) where 12 | pure x = NoExn x 13 | (<*>) = ap 14 | 15 | instance Monad (Exception a) where 16 | (>>=) (Exn d) f = Exn d 17 | (>>=) (NoExn a) f = f a 18 | 19 | handle :: Exception a b -> (a -> Exception a b) -> Exception a b 20 | handle x f = case x of 21 | Exn c -> f c 22 | NoExn a -> NoExn a 23 | 24 | throw :: a -> Exception a b 25 | throw = Exn 26 | 27 | returnval (NoExn a) = a 28 | -------------------------------------------------------------------------------- /inputs/Bool.pot: -------------------------------------------------------------------------------- 1 | and x y = case x of 2 | True -> y 3 | | False -> False; 4 | 5 | or x y = case x of 6 | True -> True 7 | | False -> y; 8 | 9 | iff x y = case x of 10 | True -> y 11 | | False -> not y; 12 | 13 | implies x y = case x of 14 | True -> y 15 | | False -> True; 16 | 17 | not x = case x of 18 | True -> False 19 | | False -> True; 20 | 21 | eqBool x y = case x of 22 | True -> y 23 | | False -> not y -------------------------------------------------------------------------------- /examples/Bool.pot: -------------------------------------------------------------------------------- 1 | and x y = case x of 2 | True -> y 3 | | False -> False; 4 | 5 | or x y = case x of 6 | True -> True 7 | | False -> y; 8 | 9 | iff x y = case x of 10 | True -> y 11 | | False -> not y; 12 | 13 | implies x y = case x of 14 | True -> y 15 | | False -> True; 16 | 17 | not x = case x of 18 | True -> False 19 | | False -> True; 20 | 21 | eqBool x y = case x of 22 | True -> y 23 | | False -> not y -------------------------------------------------------------------------------- /inputs/issue9.pot: -------------------------------------------------------------------------------- 1 | main = fold f2 s (map isZ f1 m1); 2 | 3 | mkNode isZ x = case (isZ x) of True -> None | False -> Val(x); 4 | 5 | reduceTree n1 n2 n3 n4 = Node (n1, n2, n3, n4); 6 | 7 | map isZ g m = 8 | case m of 9 | Error -> Error 10 | | None -> None 11 | | Val (v) -> (mkNode isZ (g v)) 12 | | Node (q1, q2, q3, q4) -> (reduceTree 13 | (map isZ g q1) 14 | (map isZ g q2) 15 | (map isZ g q3) 16 | (map isZ g q4)) 17 | ; 18 | 19 | fold g s m = 20 | case m of 21 | None -> s 22 | | Error -> s 23 | | Val(v) -> (g s v) 24 | | Node (n1, n2, n3, n4) -> g (fold g s n1) (g (fold g s n2) (g (fold g s n3) (fold g s n4))) -------------------------------------------------------------------------------- /inputs/gcd.pot: -------------------------------------------------------------------------------- 1 | main = gcd x y; 2 | 3 | gcd x y = case x of 4 | Zero -> y 5 | | Succ(x') -> case y of 6 | Zero -> x 7 | | Succ(y') -> case (gt x y) of 8 | True -> gcd (minus x y) y 9 | | False -> case (gt y x) of 10 | True -> gcd x (minus y x) 11 | | False -> x; 12 | 13 | gt x y = case x of 14 | Zero -> False 15 | | Succ(x) -> case y of 16 | Zero -> True 17 | | Succ(y) -> gt x y; 18 | 19 | minus x y = case y of 20 | Zero -> x 21 | | Succ(y) -> case x of 22 | Zero -> Zero 23 | | Succ(x) -> minus x y 24 | 25 | -------------------------------------------------------------------------------- /inputs/gcd3.pot: -------------------------------------------------------------------------------- 1 | main = f0 x y x y; 2 | 3 | f0 a b c d = case a of 4 | Zero -> (case b of 5 | Zero -> c 6 | | Succ(b) -> f1 c b c b) 7 | | Succ(a) -> case b of 8 | Zero -> f1 d a d a 9 | | Succ(b) -> f0 a b c d; 10 | 11 | f1 a b c d = case a of 12 | Zero -> f1 c b c b 13 | | Succ(a) -> case b of 14 | Zero -> (case a of 15 | Zero -> c 16 | | Succ(a) -> f2 d a d a) 17 | | Succ(b) -> f1 a b c d; 18 | 19 | f2 a b c d = case a of 20 | Zero -> (case b of 21 | Zero -> Succ(c) 22 | | Succ(b) -> f2 c b c b) 23 | | Succ(a) -> case b of 24 | Zero -> f2 d a d a 25 | | Succ(b) -> f2 a b c d 26 | 27 | -------------------------------------------------------------------------------- /inputs/mcv.pot: -------------------------------------------------------------------------------- 1 | import Nat 2 | 3 | main = mcv input; 4 | 5 | input = Prog(3,And(Ref(4),Ref(5)),Prog(5,Or(Ref(0),Ref(2)),Prog(4,And(Ref(1),Ref(2)),Prog(2,And(Ref(1),Ref(1)),Prog(1,TT,Empty))))); 6 | 7 | mcv p = case p of 8 | Empty -> False 9 | | Prog(v,e,p') -> eval e p'; 10 | 11 | eval e p = case e of 12 | TT -> True 13 | | FF -> False 14 | | And(e,e') -> (case (eval e p) of 15 | True -> eval e' p 16 | | False -> False) 17 | | Or(e,e') -> (case (eval e p) of 18 | True -> True 19 | | False -> eval e' p) 20 | | Ref(v) -> case p of 21 | Empty -> False 22 | | Prog(v',e',p') -> case (eqNat v v') of 23 | True -> eval e' p' 24 | | False -> eval e p' 25 | 26 | -------------------------------------------------------------------------------- /inputs/NatList.pot: -------------------------------------------------------------------------------- 1 | import Bool 2 | import Nat 3 | 4 | append xs ys = case xs of 5 | Nil -> ys 6 | | Cons(x,xs) -> Cons(x,append xs ys); 7 | 8 | nrev xs = case xs of 9 | Nil -> Nil 10 | | Cons(x,xs) -> append (nrev xs) Cons(x,Nil); 11 | 12 | qrev xs ys = case xs of 13 | Nil -> ys 14 | | Cons(x,xs) -> qrev xs Cons(x,ys); 15 | 16 | length xs = case xs of 17 | Nil -> Zero 18 | | Cons(x,xs) -> Succ(length xs); 19 | 20 | map f xs = case xs of 21 | Nil -> Nil 22 | | Cons(x,xs) -> Cons(f x,map f xs); 23 | 24 | eqNatList xs ys = case xs of 25 | Nil -> (case ys of 26 | Nil -> True 27 | | Cons(y,ys) -> False) 28 | | Cons(x,xs) -> case ys of 29 | Nil -> False 30 | | Cons(y,ys) -> and (eqNat x y) (eqNatList xs ys) -------------------------------------------------------------------------------- /inputs/issue10.pot: -------------------------------------------------------------------------------- 1 | main = mAdd isZ g m1 (mAdd isZ h m2 m3); 2 | 3 | mAdd isZ g m1 m2 = 4 | case m1 of 5 | Error -> Error 6 | | None -> (m2) 7 | | Val (v1) -> (case m2 of 8 | Error -> Error 9 | | None -> m1 10 | | Val (v) -> (mkNode isZ (g v1 v)) 11 | | Node (t1, t2, t3, t4) -> Error) 12 | | Node (q1, q2, q3, q4) -> (case m2 of 13 | Error -> Error 14 | | None -> m1 15 | | Val (v) -> Error 16 | | Node (t1, t2, t3, t4) -> (Node( 17 | (mAdd isZ g q1 t1) 18 | ,(mAdd isZ g q2 t2) 19 | ,(mAdd isZ g q3 t3) 20 | ,(mAdd isZ g q4 t4)))) -------------------------------------------------------------------------------- /examples/mAddDistilled.pot: -------------------------------------------------------------------------------- 1 | main = f m1 m2 mkNode is_zero op_add; 2 | f m1 m2 mkNode is_zero op_add = case m1 of 3 | Error -> Error 4 | | None -> m2 5 | | Val(v1) -> (case m2 of 6 | Error -> Error 7 | | None -> Val(v1) 8 | | Val(v) -> (mkNode is_zero (op_add v1 v)) 9 | | Node(t1,t2,t3,t4) -> Error) 10 | | Node(q1,q2,q3,q4) -> (case m2 of 11 | Error -> Error 12 | | None -> Node(q1,q2,q3,q4) 13 | | Val(v) -> Error 14 | | Node(t1,t2,t3,t4) -> Node(f q1 t1 mkNode is_zero op_add,f q2 t2 mkNode is_zero op_add,f q3 t3 mkNode is_zero op_add,f q4 t4 mkNode is_zero op_add)) -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: distiller 2 | version: 0.1.0.0 3 | github: "poitin/distiller" 4 | license: BSD3 5 | author: "Geoff Hamilton" 6 | maintainer: "geoffrey.hamilton@dcu.ie" 7 | copyright: "2021 Geoff Hamilton" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | 25 | library: 26 | source-dirs: src 27 | 28 | executables: 29 | distiller: 30 | main: Main.hs 31 | source-dirs: src 32 | ghc-options: 33 | - -threaded 34 | - -rtsopts 35 | - -with-rtsopts=-N 36 | dependencies: 37 | - distiller 38 | 39 | -------------------------------------------------------------------------------- /inputs/test.pot: -------------------------------------------------------------------------------- 1 | main = eql x x; 2 | 3 | logand x1 x2 = case x1 of 4 | False -> False 5 | | True -> x2; 6 | 7 | eql x y = case x of 8 | Cons(ls, x') -> (case y of 9 | Cons(lt, y') -> logand (eqq ls lt) (eql x' y') 10 | | Nil -> False ) 11 | | Nil -> (case y of 12 | Nil -> True 13 | | Cons(ls, y') -> False ); 14 | 15 | eqq x y = case x of 16 | Cons(s, x') -> (case y of 17 | Cons(t, y') -> (case s of 18 | True -> (case t of 19 | True -> eqq x' y' 20 | | False -> False ) 21 | | False -> (case t of 22 | False -> eqq x' y' 23 | | True -> False ) ) 24 | | Nil -> False ) 25 | | Nil -> (case y of 26 | Nil -> True 27 | | Cons(s, y') -> False) -------------------------------------------------------------------------------- /inputs/msort.pot: -------------------------------------------------------------------------------- 1 | import NatList 2 | 3 | main = msort xs; 4 | 5 | msort xs = case xs of 6 | Nil -> Nil 7 | | Cons(x',xs') -> case xs' of 8 | Nil -> Cons(x',Nil) 9 | | Cons(x'',xs'') -> merge (msort (firsts xs)) (msort (seconds xs)); 10 | 11 | merge xs ys = case xs of 12 | Nil -> ys 13 | | Cons(x',xs') -> case ys of 14 | Nil -> xs 15 | | Cons(y',ys') -> case (gt y' x') of 16 | True -> Cons(x',merge xs' ys) 17 | | False -> Cons(y',merge xs ys'); 18 | firsts xs = case xs of 19 | Nil -> Nil 20 | | Cons(x',xs') -> case xs' of 21 | Nil -> Cons(x',Nil) 22 | | Cons(x'',xs'') -> Cons(x',firsts xs''); 23 | seconds xs = case xs of 24 | Nil -> Nil 25 | | Cons(x',xs') -> case xs' of 26 | Nil -> Nil 27 | | Cons(x'',xs'') -> Cons(x'',seconds xs'') 28 | 29 | 30 | -------------------------------------------------------------------------------- /.vscode/tasks.json: -------------------------------------------------------------------------------- 1 | 2 | { 3 | // Automatically created by phoityne-vscode extension. 4 | 5 | "version": "2.0.0", 6 | "presentation": { 7 | "reveal": "always", 8 | "panel": "new" 9 | }, 10 | "tasks": [ 11 | { 12 | // F7 13 | "group": { 14 | "kind": "build", 15 | "isDefault": true 16 | }, 17 | "label": "haskell build", 18 | "type": "shell", 19 | //"command": "cabal configure && cabal build" 20 | "command": "stack build" 21 | }, 22 | { 23 | // F6 24 | "group": "build", 25 | "type": "shell", 26 | "label": "haskell clean & build", 27 | //"command": "cabal clean && cabal configure && cabal build" 28 | "command": "stack clean && stack build" 29 | //"command": "stack clean ; stack build" // for powershell 30 | }, 31 | { 32 | // F8 33 | "group": { 34 | "kind": "test", 35 | "isDefault": true 36 | }, 37 | "type": "shell", 38 | "label": "haskell test", 39 | //"command": "cabal test" 40 | "command": "stack test" 41 | }, 42 | { 43 | // F6 44 | "isBackground": true, 45 | "type": "shell", 46 | "label": "haskell watch", 47 | "command": "stack build --test --no-run-tests --file-watch" 48 | } 49 | ] 50 | } 51 | -------------------------------------------------------------------------------- /inputs/palindrome.pot: -------------------------------------------------------------------------------- 1 | import NatList 2 | 3 | main = palindrome xs xs; 4 | 5 | palindrome xs ys = case ys of 6 | Nil -> True 7 | | Cons(y,ys') -> palindrome' xs ys' xs ys; 8 | 9 | palindrome' us vs xs ys = case vs of 10 | Nil -> (case ys of 11 | Cons(y,ys') -> (case us of 12 | Cons(u,us') -> (case y of 13 | Zero -> (case u of 14 | Zero -> palindrome xs ys' 15 | | One -> False) 16 | | One -> (case u of 17 | Zero -> False 18 | | One -> palindrome xs ys')))) 19 | | Cons(v,vs') -> case us of 20 | Cons(u,us') -> palindrome' us' vs' xs ys 21 | -------------------------------------------------------------------------------- /inputs/Nat.pot: -------------------------------------------------------------------------------- 1 | import Bool 2 | 3 | plus x y = case x of 4 | Zero -> y 5 | | Succ(x) -> Succ(plus x y); 6 | 7 | minus x y = case y of 8 | Zero -> x 9 | | Succ(y) -> case x of 10 | Zero -> Zero 11 | | Succ(x) -> minus x y; 12 | mul x y = case x of 13 | Zero -> Zero 14 | | Succ(x) -> plus y (mul x y); 15 | 16 | div x y = case (gt y x) of 17 | True -> Zero 18 | | False -> Succ(div (minus x y) y); 19 | 20 | pow x y = case y of 21 | Zero -> Succ(Zero) 22 | | Succ(y) -> mul x (pow x y); 23 | 24 | gt x y = case x of 25 | Zero -> False 26 | | Succ(x) -> case y of 27 | Zero -> True 28 | | Succ(y) -> gt x y; 29 | 30 | lt x y = case y of 31 | Zero -> False 32 | | Succ(y) -> case x of 33 | Zero -> True 34 | | Succ(x) -> lt x y; 35 | eqNat x y = case x of 36 | Zero -> (case y of 37 | Zero -> True 38 | | Succ(y) -> False) 39 | | Succ(x) -> case y of 40 | Zero -> False 41 | | Succ(y) -> eqNat x y -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2020 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /distiller.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.33.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 1d14bbcd1f769a3b8ba1ba9a72963dd7de816e39d26efe5c313c1087daac8448 8 | 9 | name: distiller 10 | version: 0.1.0.0 11 | description: Please see the README on GitHub at 12 | homepage: https://github.com/poitin/distiller#readme 13 | bug-reports: https://github.com/poitin/distiller/issues 14 | author: Geoff Hamilton 15 | maintainer: hamilton@computing.dcu.ie 16 | copyright: 2021 Geoff Hamilton 17 | license: BSD-3-Clause 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | ChangeLog.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/poitin/distiller 27 | 28 | library 29 | exposed-modules: 30 | Exception 31 | Term 32 | Tree 33 | Trans 34 | other-modules: 35 | Paths_distiller 36 | hs-source-dirs: 37 | src 38 | build-depends: 39 | base >=4.7 && <5 40 | , parsec 41 | , pretty 42 | , directory 43 | , process 44 | default-language: Haskell2010 45 | 46 | executable distiller 47 | main-is: Main.hs 48 | other-modules: 49 | Exception 50 | Term 51 | Tree 52 | Trans 53 | hs-source-dirs: 54 | src 55 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 56 | build-depends: 57 | base >=4.7 && <5 58 | , parsec 59 | , pretty 60 | , directory 61 | , process 62 | , distiller 63 | default-language: Haskell2010 64 | 65 | -------------------------------------------------------------------------------- /inputs/issue11.pot: -------------------------------------------------------------------------------- 1 | import Bool 2 | import Nat 3 | 4 | main = map is_z_nut h (mAdd is_z_bool op m1 m2) 5 | ; 6 | 7 | is_z_nut x = eqNat x (Zero) 8 | ; 9 | 10 | is_z_bool x = eqBool x (False) 11 | ; 12 | 13 | op x y = or x y 14 | ; 15 | 16 | h x = (Succ(Zero)) 17 | ; 18 | 19 | map isZ g m = 20 | case m of 21 | Error -> Error 22 | | None -> None 23 | | Val (v) -> (mkNode isZ (g v)) 24 | | Node (q1, q2, q3, q4) -> (Node( 25 | (map isZ g q1) 26 | ,(map isZ g q2) 27 | ,(map isZ g q3) 28 | ,(map isZ g q4))) 29 | ; 30 | 31 | mAdd isZ g m1 m2 = 32 | case m1 of 33 | Error -> Error 34 | | None -> (m2) 35 | | Val (v1) -> (case m2 of 36 | Error -> Error 37 | | None -> m1 38 | | Val (v) -> (mkNode isZ (g v1 v)) 39 | | Node (t1, t2, t3, t4) -> Error) 40 | | Node (q1, q2, q3, q4) -> (case m2 of 41 | Error -> Error 42 | | None -> m1 43 | | Val (v) -> Error 44 | | Node (t1, t2, t3, t4) -> (Node( 45 | (mAdd isZ g q1 t1) 46 | ,(mAdd isZ g q2 t2) 47 | ,(mAdd isZ g q3 t3) 48 | ,(mAdd isZ g q4 t4)))) -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Distiller 2 | Implementation of the distillation algorithm as described in the paper ["Distillation: Extracting the Essence of Programs"](https://dl.acm.org/doi/10.1145/1244381.1244391). 3 | 4 | The implementation can be built and executed using stack. 5 | 6 | ## Execution 7 | The execution is a REPL, with the prompt "POT> " and the following commands: 8 | 9 | ``` 10 | POT> :help 11 | 12 | :load To load the given filename 13 | :prog To print the current program 14 | :term To print the current term 15 | :eval To evaluate the current program 16 | :distill To distill the current program. If the file name is provided, the result will be stored in the specified file. 17 | :quit To quit 18 | :help To print this message 19 | ``` 20 | The first thing to do is to load a program file: 21 | 22 | ``` 23 | POT> :load nrev 24 | ``` 25 | 26 | This will load the program nrev.pot (the.pot extension is assumed). 27 | 28 | To see the contents of this program: 29 | 30 | ``` 31 | POT> :prog 32 | main = nrev xs; 33 | append xs ys = case xs of 34 | Nil -> ys 35 | | Cons(x,xs) -> Cons(x,append xs ys); 36 | nrev xs = case xs of 37 | Nil -> [] 38 | | Cons(x,xs) -> (append (nrev xs) [x]) 39 | ``` 40 | 41 | To see the top-level term: 42 | 43 | ``` 44 | POT> :term 45 | nrev xs 46 | ``` 47 | 48 | To apply the distillation transformation to the current program: 49 | ``` 50 | POT> :distill 51 | main = case xs of 52 | Nil -> [] 53 | | Cons(x,xs) -> (f xs x []); 54 | f xs' x x'' = case xs' of 55 | Nil -> Cons(x,x'') 56 | | Cons(x',xs) -> (f xs x' Cons(x,x'')) 57 | ``` 58 | 59 | To evaluate the current program: 60 | ``` 61 | POT> :eval 62 | ``` 63 | This will prompt for values of the free variables: 64 | 65 | ``` 66 | xs = [1,2,3,4,5,6,7,8,9] 67 | [9,8,7,6,5,4,3,2,1] 68 | Reductions: 118 69 | Allocations: 10 70 | ``` 71 | 72 | To quit from the program: 73 | 74 | ``` 75 | POT> :quit 76 | ``` 77 | 78 | -------------------------------------------------------------------------------- /inputs/issue12.pot: -------------------------------------------------------------------------------- 1 | main = mMult is_zero op_add op_mult mtx1 mtx2; 2 | 3 | mMult isZ f_add f_mul m1 m2 = 4 | case m1 of 5 | Error -> Error 6 | | None -> None 7 | | Val (v1) -> 8 | (case m2 of 9 | Error -> Error 10 | | None -> None 11 | | Val (v) -> (mkNode isZ (f_mul v1 v)) 12 | | Node (t1, t2, t3, t4) -> Error) 13 | | Node (q1, q2, q3, q4) -> 14 | (case m2 of 15 | Error -> Error 16 | | None -> None 17 | | Val (v) -> Error 18 | | Node (t1, t2, t3, t4) -> 19 | (Node( 20 | (mAdd isZ f_add (mMult isZ f_add f_mul q1 t1)(mMult isZ f_add f_mul q2 t3)) 21 | ,(mAdd isZ f_add (mMult isZ f_add f_mul q1 t2)(mMult isZ f_add f_mul q2 t4)) 22 | ,(mAdd isZ f_add (mMult isZ f_add f_mul q3 t1)(mMult isZ f_add f_mul q4 t3)) 23 | ,(mAdd isZ f_add (mMult isZ f_add f_mul q3 t2)(mMult isZ f_add f_mul q4 t4)))) 24 | ) 25 | ; 26 | 27 | mAdd isZ f_add m1 m2 = 28 | case m1 of 29 | Error -> Error 30 | | None -> (m2) 31 | | Val (v1) -> (case m2 of 32 | Error -> Error 33 | | None -> m1 34 | | Val (v) -> (mkNode isZ (f_add v1 v)) 35 | | Node (t1, t2, t3, t4) -> Error) 36 | | Node (q1, q2, q3, q4) -> (case m2 of 37 | Error -> Error 38 | | None -> m1 39 | | Val (v) -> Error 40 | | Node (t1, t2, t3, t4) -> (Node( 41 | (mAdd isZ f_add q1 t1) 42 | ,(mAdd isZ f_add q2 t2) 43 | ,(mAdd isZ f_add q3 t3) 44 | ,(mAdd isZ f_add q4 t4)))) -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.4 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: 21 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/5.yaml 22 | 23 | # User packages to be built. 24 | # Various formats can be used as shown in the example below. 25 | # 26 | # packages: 27 | # - some-directory 28 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 29 | # subdirs: 30 | # - auto-update 31 | # - wai 32 | packages: 33 | - . 34 | # Dependency packages to be pulled from upstream that are not in the resolver. 35 | # These entries can reference officially published versions as well as 36 | # forks / in-progress versions pinned to a git hash. For example: 37 | # 38 | # extra-deps: 39 | # - acme-missiles-0.3 40 | # - git: https://github.com/commercialhaskell/stack.git 41 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 42 | # 43 | # extra-deps: [] 44 | 45 | # Override default flag values for local packages and extra-deps 46 | # flags: {} 47 | 48 | # Extra package databases containing global packages 49 | # extra-package-dbs: [] 50 | 51 | # Control whether we use the GHC we find on the path 52 | # system-ghc: true 53 | # 54 | # Require a specific version of stack, using version ranges 55 | # require-stack-version: -any # Default 56 | # require-stack-version: ">=2.3" 57 | # 58 | # Override the architecture used by stack, especially useful on Windows 59 | # arch: i386 60 | # arch: x86_64 61 | # 62 | # Extra directories used by stack for building 63 | # extra-include-dirs: [/path/to/dir] 64 | # extra-lib-dirs: [/path/to/dir] 65 | # 66 | # Allow a newer minor version of GHC than the snapshot specifies 67 | # compiler-check: newer-minor 68 | -------------------------------------------------------------------------------- /inputs/issue12distilled.pot: -------------------------------------------------------------------------------- 1 | main = f mtx1 mtx2 mkNode is_zero op_mult op_add; 2 | f mtx1 mtx2 mkNode is_zero op_mult op_add = case mtx1 of 3 | Error -> Error 4 | | None -> None 5 | | Val(v1) -> (case mtx2 of 6 | Error -> Error 7 | | None -> None 8 | | Val(v) -> (mkNode is_zero (op_mult v1 v)) 9 | | Node(t1,t2,t3,t4) -> Error) 10 | | Node(q1,q2,q3,q4) -> (case mtx2 of 11 | Error -> Error 12 | | None -> None 13 | | Val(v) -> Error 14 | | Node(t1,t2,t3,t4) -> Node(f' (f q1 t1 mkNode is_zero op_mult op_add) (f q2 t3 mkNode is_zero op_mult op_add) mkNode is_zero op_add,f' (f q1 t2 mkNode is_zero op_mult op_add) (f q2 t4 mkNode is_zero op_mult op_add) mkNode is_zero op_add,f' (f q3 t1 mkNode is_zero op_mult op_add) (f q4 t3 mkNode is_zero op_mult op_add) mkNode is_zero op_add,f' (f q3 t2 mkNode is_zero op_mult op_add) (f q4 t4 mkNode is_zero op_mult op_add) mkNode is_zero op_add)); 15 | f' x x' mkNode is_zero op_add = case x of 16 | Error -> Error 17 | | None -> x' 18 | | Val(v1) -> (case x' of 19 | Error -> Error 20 | | None -> Val(v1) 21 | | Val(v) -> (mkNode is_zero (op_add v1 v)) 22 | | Node(t1,t2,t3,t4) -> Error) 23 | | Node(q1,q2,q3,q4) -> (case x' of 24 | Error -> Error 25 | | None -> Node(q1,q2,q3,q4) 26 | | Val(v) -> Error 27 | | Node(t1,t2,t3,t4) -> Node(f' q1 t1 mkNode is_zero op_add,f' q2 t2 mkNode is_zero op_add,f' q3 t3 mkNode is_zero op_add,f' q4 t4 mkNode is_zero op_add)) -------------------------------------------------------------------------------- /examples/MasksDistilled.pot: -------------------------------------------------------------------------------- 1 | import Bool 2 | import QTree 3 | import Matrices 4 | 5 | main = f msk2 msk1 m1; 6 | f msk2 msk1 m1 = 7 | (case msk2 of 8 | MNone -> 9 | None 10 | | MVal -> 11 | f' msk1 m1 12 | | MNode(q1,q2,q3,q4) -> 13 | (case msk1 of 14 | MNone -> 15 | None 16 | | MVal -> 17 | (case m1 of 18 | Error -> 19 | Error 20 | | None -> 21 | None 22 | | Val(v) -> 23 | Error 24 | | Node(t1,t2,t3,t4) -> 25 | f'' q1 t1 q2 t2 q3 t3 q4 t4) 26 | | MNode(q1',q2',q3',q4') -> 27 | (case m1 of 28 | Error -> 29 | Error 30 | | None -> 31 | None 32 | | Val(v) -> 33 | Error 34 | | Node(t1,t2,t3,t4) -> 35 | Node(f q1 q1' t1, f q2 q2' t2, f q3 q3' t3, f q4 q4' t4)))); 36 | f'' q1 t1 q2 t2 q3 t3 q4 t4 = 37 | Node((case q1 of 38 | MNone -> 39 | None 40 | | MVal -> 41 | t1 42 | | MNode(q1,q2,q3,q4) -> 43 | (case t1 of 44 | Error -> 45 | Error 46 | | None -> 47 | None 48 | | Val(v) -> 49 | Error 50 | | Node(t1,t2,t3,t4) -> 51 | f'' q1 t1 q2 t2 q3 t3 q4 t4)), 52 | (case q2 of 53 | MNone -> 54 | None 55 | | MVal -> 56 | t2 57 | | MNode(q1,q2,q3,q4) -> 58 | (case t2 of 59 | Error -> 60 | Error 61 | | None -> 62 | None 63 | | Val(v) -> 64 | Error 65 | | Node(t1,t2,t3,t4) -> 66 | f'' q1 t1 q2 t2 q3 t3 q4 t4)), 67 | (case q3 of 68 | MNone -> 69 | None 70 | | MVal -> 71 | t3 72 | | MNode(q1,q2,q3,q4) -> 73 | (case t3 of 74 | Error -> 75 | Error 76 | | None -> 77 | None 78 | | Val(v) -> 79 | Error 80 | | Node(t1,t2,t3,t4) -> 81 | f'' q1 t1 q2 t2 q3 t3 q4 t4)), 82 | (case q4 of 83 | MNone -> 84 | None 85 | | MVal -> 86 | t4 87 | | MNode(q1,q2,q3,q4) -> 88 | (case t4 of 89 | Error -> 90 | Error 91 | | None -> 92 | None 93 | | Val(v) -> 94 | Error 95 | | Node(t1,t2,t3,t4) -> 96 | f'' q1 t1 q2 t2 q3 t3 q4 t4))); 97 | f' msk1 m1 = 98 | (case msk1 of 99 | MNone -> 100 | None 101 | | MVal -> 102 | m1 103 | | MNode(q1,q2,q3,q4) -> 104 | (case m1 of 105 | Error -> 106 | Error 107 | | None -> 108 | None 109 | | Val(v) -> 110 | Error 111 | | Node(t1,t2,t3,t4) -> 112 | Node(f' q1 t1, f' q2 t2, f' q3 t3, f' q4 t4))) 113 | 114 | -------------------------------------------------------------------------------- /examples/KronMaskDistilled.pot: -------------------------------------------------------------------------------- 1 | import QTree 2 | import Bool 3 | import Matrices 4 | 5 | 6 | main = f msk m1 m2 (not); 7 | f msk m1 m2 s = 8 | (case msk of 9 | MNone -> 10 | None 11 | | MVal -> 12 | (case m1 of 13 | Error -> 14 | Error 15 | | None -> 16 | None 17 | | Val(v) -> 18 | f' m2 v s 19 | | Node(q1,q2,q3,q4) -> 20 | f'' q1 m2 s q2 q3 q4) 21 | | MNode(q1,q2,q3,q4) -> 22 | (case m1 of 23 | Error -> 24 | Error 25 | | None -> 26 | None 27 | | Val(v) -> 28 | Error 29 | | Node(t1,t2,t3,t4) -> 30 | Node(f q1 t1 m2 s, f q2 t2 m2 s, f q3 t3 m2 s, f q4 t4 m2 s))); 31 | f'' q1 m2 s q2 q3 q4 = 32 | Node((case q1 of 33 | Error -> 34 | Error 35 | | None -> 36 | None 37 | | Val(v) -> 38 | f''' m2 v s 39 | | Node(q1,q2,q3,q4) -> 40 | f'' q1 m2 s q2 q3 q4), 41 | (case q2 of 42 | Error -> 43 | Error 44 | | None -> 45 | None 46 | | Val(v) -> 47 | f'''' m2 v s 48 | | Node(q1,q2,q3,q4) -> 49 | f'' q1 m2 s q2 q3 q4), 50 | (case q3 of 51 | Error -> 52 | Error 53 | | None -> 54 | None 55 | | Val(v) -> 56 | f''''' m2 v s 57 | | Node(q1,q2,q3,q4) -> 58 | f'' q1 m2 s q2 q3 q4), 59 | (case q4 of 60 | Error -> 61 | Error 62 | | None -> 63 | None 64 | | Val(v) -> 65 | f'''''' m2 v s 66 | | Node(q1,q2,q3,q4) -> 67 | f'' q1 m2 s q2 q3 q4)); 68 | f'''''' m2 v s = 69 | (case m2 of 70 | Error -> 71 | Error 72 | | None -> 73 | None 74 | | Val(v') -> 75 | (case v of 76 | True -> 77 | Val(True) 78 | | False -> 79 | (case s of 80 | True -> 81 | Val(True) 82 | | False -> 83 | None)) 84 | | Node(q1,q2,q3,q4) -> 85 | Node(f'''''' q1 v s, f'''''' q2 v s, f'''''' q3 v s, f'''''' q4 v s)); 86 | f''''' m2 v s = 87 | (case m2 of 88 | Error -> 89 | Error 90 | | None -> 91 | None 92 | | Val(v') -> 93 | (case v of 94 | True -> 95 | Val(True) 96 | | False -> 97 | (case s of 98 | True -> 99 | Val(True) 100 | | False -> 101 | None)) 102 | | Node(q1,q2,q3,q4) -> 103 | Node(f''''' q1 v s, f''''' q2 v s, f''''' q3 v s, f''''' q4 v s)); 104 | f'''' m2 v s = 105 | (case m2 of 106 | Error -> 107 | Error 108 | | None -> 109 | None 110 | | Val(v') -> 111 | (case v of 112 | True -> 113 | Val(True) 114 | | False -> 115 | (case s of 116 | True -> 117 | Val(True) 118 | | False -> 119 | None)) 120 | | Node(q1,q2,q3,q4) -> 121 | Node(f'''' q1 v s, f'''' q2 v s, f'''' q3 v s, f'''' q4 v s)); 122 | f''' m2 v s = 123 | (case m2 of 124 | Error -> 125 | Error 126 | | None -> 127 | None 128 | | Val(v') -> 129 | (case v of 130 | True -> 131 | Val(True) 132 | | False -> 133 | (case s of 134 | True -> 135 | Val(True) 136 | | False -> 137 | None)) 138 | | Node(q1,q2,q3,q4) -> 139 | Node(f''' q1 v s, f''' q2 v s, f''' q3 v s, f''' q4 v s)); 140 | f' m2 v s = 141 | (case m2 of 142 | Error -> 143 | Error 144 | | None -> 145 | None 146 | | Val(v') -> 147 | (case v of 148 | True -> 149 | Val(True) 150 | | False -> 151 | (case s of 152 | True -> 153 | Val(True) 154 | | False -> 155 | None)) 156 | | Node(q1,q2,q3,q4) -> 157 | Node(f' q1 v s, f' q2 v s, f' q3 v s, f' q4 v s)) -------------------------------------------------------------------------------- /examples/QTree.pot: -------------------------------------------------------------------------------- 1 | import Bool 2 | 3 | fT x = True; 4 | 5 | mkNode isZ x = case (isZ x) of True -> None | False -> Val(x); 6 | 7 | reduceTree n1 n2 n3 n4 = Node (n1, n2, n3, n4); 8 | 9 | reduceTree2 n1 n2 n3 n4 = 10 | let nd = Node (n1, n2, n3, n4) in 11 | (case n1 of 12 | None -> (case n2 of 13 | None -> (case n3 of 14 | None -> (case n4 of 15 | None -> None 16 | | Error -> Error 17 | | Val (v4) -> nd 18 | | Node (m1, m2, m3, m4) -> nd) 19 | | Error -> Error 20 | | Val (v3) -> nd 21 | | Node (l1, l2, l3, l4) -> nd) 22 | | Error -> Error 23 | | Val (v2) -> nd 24 | | Node (k1, k2, k3, k4) -> nd) 25 | | Error -> Error 26 | | Val (v1) -> nd 27 | | Node (j1, j2, j3, j4) -> nd) 28 | 29 | ; 30 | 31 | reduceTree1 n1 n2 n3 n4 = 32 | case n1 of 33 | None -> (case n2 of 34 | None -> (case n3 of 35 | None -> (case n4 of 36 | None -> None 37 | | Error -> Error 38 | | Val (v4) -> Node (n1, n2, n3, n4) 39 | | Node (m1, m2, m3, m4) -> Node (n1, n2, n3, n4)) 40 | | Error -> Error 41 | | Val (v3) -> Node (n1, n2, n3, n4) 42 | | Node (l1, l2, l3, l4) -> Node (n1, n2, n3, n4)) 43 | | Error -> Error 44 | | Val (v2) -> Node (n1, n2, n3, n4) 45 | | Node (k1, k2, k3, k4) -> Node (n1, n2, n3, n4)) 46 | | Error -> Error 47 | | Val (v1) -> Node (n1, n2, n3, n4) 48 | | Node (j1, j2, j3, j4) -> Node (n1, n2, n3, n4) 49 | ; 50 | 51 | mAdd isZ g m1 m2 = 52 | case m1 of 53 | Error -> Error 54 | | None -> (m2) 55 | | Val (v1) -> (case m2 of 56 | Error -> Error 57 | | None -> m1 58 | | Val (v) -> (mkNode isZ (g v1 v)) 59 | | Node (t1, t2, t3, t4) -> Error) 60 | | Node (q1, q2, q3, q4) -> (case m2 of 61 | Error -> Error 62 | | None -> m1 63 | | Val (v) -> Error 64 | | Node (t1, t2, t3, t4) -> (reduceTree 65 | (mAdd isZ g q1 t1) 66 | (mAdd isZ g q2 t2) 67 | (mAdd isZ g q3 t3) 68 | (mAdd isZ g q4 t4))); 69 | 70 | mask m msk = 71 | case msk of 72 | MNone -> None 73 | | MVal -> m 74 | | MNode (q1, q2, q3, q4) -> 75 | (case m of 76 | Error -> Error 77 | | None -> None 78 | | Val (v) -> Error 79 | | Node (t1, t2, t3, t4) -> (reduceTree (mask t1 q1) (mask t2 q2) (mask t3 q3) (mask t4 q4))); 80 | 81 | combine add mult q1 q2 q3 q4 t1 t2 t3 t4 = 82 | (reduceTree 83 | (add (mult q1 t1)(mult q2 t3)) 84 | (add (mult q1 t2)(mult q2 t4)) 85 | (add (mult q3 t1)(mult q4 t3)) 86 | (add (mult q3 t2)(mult q4 t4))) 87 | ; 88 | 89 | mMult isZ g h m1 m2 = 90 | case m1 of 91 | Error -> Error 92 | | None -> None 93 | | Val (v1) -> 94 | (case m2 of 95 | Error -> Error 96 | | None -> None 97 | | Val (v) -> (mkNode isZ (h v1 v)) 98 | | Node (t1, t2, t3, t4) -> Error) 99 | | Node (q1, q2, q3, q4) -> 100 | (case m2 of 101 | Error -> Error 102 | | None -> None 103 | | Val (v) -> Error 104 | | Node (t1, t2, t3, t4) -> (combine (mAdd isZ g) (mMult isZ g h) q1 q2 q3 q4 t1 t2 t3 t4)) 105 | ; 106 | 107 | map isZ f m = 108 | case m of 109 | Error -> Error 110 | | None -> None 111 | | Val (v) -> (mkNode isZ (f s)) 112 | | Node (q1, q2, q3, q4) -> (reduceTree 113 | (map isZ f q1) 114 | (map isZ f q2) 115 | (map isZ f q3) 116 | (map isZ f q4)); 117 | 118 | kron isZ g m1 m2 = 119 | case m1 of 120 | Error -> Error 121 | | None -> None 122 | | Val (v) -> (map isZ (g v) m2) 123 | | Node (q1, q2, q3, q4) -> (reduceTree 124 | (kron isZ g q1 m2) 125 | (kron isZ g q2 m2) 126 | (kron isZ g q3 m2) 127 | (kron isZ g q4 m2)) 128 | 129 | ; 130 | 131 | fold f s m = 132 | case m of 133 | None -> s 134 | | Error -> s 135 | | Val(v) -> (f s v) 136 | | Node (n1, n2, n3, n4) -> (fold f (fold f (fold f (fold f s n1) n2) n3) n4) -------------------------------------------------------------------------------- /examples/mAddAddDistilled.pot: -------------------------------------------------------------------------------- 1 | main = f m1 m2 m3 mkNode is_zero op_add; 2 | f m1 m2 m3 mkNode is_zero op_add = case m1 of 3 | Error -> Error 4 | | None -> (f' m2 m3 mkNode is_zero op_add) 5 | | Val(v1) -> (case m2 of 6 | Error -> Error 7 | | None -> (case m3 of 8 | Error -> Error 9 | | None -> Val(v1) 10 | | Val(v) -> (mkNode is_zero (op_add v1 v)) 11 | | Node(t1,t2,t3,t4) -> Error) 12 | | Val(v1') -> (case m3 of 13 | Error -> Error 14 | | None -> (mkNode is_zero (op_add v1 v1')) 15 | | Val(v) -> (case (mkNode is_zero (op_add v1' v)) of 16 | Error -> Error 17 | | None -> Val(v1) 18 | | Val(v) -> (mkNode is_zero (op_add v1 v)) 19 | | Node(t1,t2,t3,t4) -> Error) 20 | | Node(t1,t2,t3,t4) -> Error) 21 | | Node(q1,q2,q3,q4) -> (case m3 of 22 | Error -> Error 23 | | None -> Error 24 | | Val(v) -> Error 25 | | Node(t1,t2,t3,t4) -> Error)) 26 | | Node(q1,q2,q3,q4) -> (case m2 of 27 | Error -> Error 28 | | None -> (case m3 of 29 | Error -> Error 30 | | None -> Node(q1,q2,q3,q4) 31 | | Val(v) -> Error 32 | | Node(t1,t2,t3,t4) -> Node(f' q1 t1 mkNode is_zero op_add,f' q2 t2 mkNode is_zero op_add,f' q3 t3 mkNode is_zero op_add,f' q4 t4 mkNode is_zero op_add)) 33 | | Val(v1) -> (case m3 of 34 | Error -> Error 35 | | None -> Error 36 | | Val(v) -> (case (mkNode is_zero (op_add v1 v)) of 37 | Error -> Error 38 | | None -> Node(q1,q2,q3,q4) 39 | | Val(v) -> Error 40 | | Node(t1,t2,t3,t4) -> Node(f' q1 t1 mkNode is_zero op_add,f' q2 t2 mkNode is_zero op_add,f' q3 t3 mkNode is_zero op_add,f' q4 t4 mkNode is_zero op_add)) 41 | | Node(t1,t2,t3,t4) -> Error) 42 | | Node(q1',q2',q3',q4') -> (case m3 of 43 | Error -> Error 44 | | None -> Node(f' q1 q1' mkNode is_zero op_add,f' q2 q2' mkNode is_zero op_add,f' q3 q3' mkNode is_zero op_add,f' q4 q4' mkNode is_zero op_add) 45 | | Val(v) -> Error 46 | | Node(t1,t2,t3,t4) -> Node(f q1 q1' t1 mkNode is_zero op_add,f q2 q2' t2 mkNode is_zero op_add,f q3 q3' t3 mkNode is_zero op_add,f q4 q4' t4 mkNode is_zero op_add))); 47 | f' m2 m3 mkNode is_zero op_add = case m2 of 48 | Error -> Error 49 | | None -> m3 50 | | Val(v1) -> (case m3 of 51 | Error -> Error 52 | | None -> Val(v1) 53 | | Val(v) -> (mkNode is_zero (op_add v1 v)) 54 | | Node(t1,t2,t3,t4) -> Error) 55 | | Node(q1,q2,q3,q4) -> (case m3 of 56 | Error -> Error 57 | | None -> Node(q1,q2,q3,q4) 58 | | Val(v) -> Error 59 | | Node(t1,t2,t3,t4) -> Node(f' q1 t1 mkNode is_zero op_add,f' q2 t2 mkNode is_zero op_add,f' q3 t3 mkNode is_zero op_add,f' q4 t4 mkNode is_zero op_add)) -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main ( 2 | main 3 | ) where 4 | 5 | import Exception 6 | import Term 7 | import Trans 8 | 9 | import Text.ParserCombinators.Parsec 10 | import Debug.Trace 11 | import System.Directory 12 | import System.IO 13 | import Control.Monad 14 | import Data.List 15 | import System.Exit 16 | import System.Process 17 | 18 | data Command = Load String 19 | | Prog 20 | | Term 21 | | Eval 22 | | Distill (Maybe String) 23 | | Quit 24 | | Help 25 | | Unknown 26 | 27 | command str = let res = words str 28 | in case res of 29 | [":load",f] -> Load f 30 | [":prog"] -> Prog 31 | [":term"] -> Term 32 | [":eval"] -> Eval 33 | [":distill"] -> Distill Nothing 34 | [":distill", f] -> Distill (Just f) 35 | [":quit"] -> Quit 36 | [":help"] -> Help 37 | _ -> Unknown 38 | 39 | helpMessage = "\n:load filename\t\tTo load the given filename\n"++ 40 | ":prog\t\t\tTo print the current program\n"++ 41 | ":term\t\t\tTo print the current term\n"++ 42 | ":eval\t\t\tTo evaluate the current program\n"++ 43 | ":distill \tTo distill the current program. If the file name is provided, the distillation result will be stored in the specified file.\n"++ 44 | ":quit\t\t\tTo quit\n"++ 45 | ":help\t\t\tTo print this message\n" 46 | 47 | 48 | -- Entry point for main program 49 | 50 | main = toplevel Nothing 51 | 52 | toplevel :: Maybe Prog -> IO () 53 | toplevel p = do putStr "POT> " 54 | hFlush stdout 55 | x <- getLine 56 | case command x of 57 | Load f -> g [f] [] [] 58 | where 59 | g [] ys d = toplevel (Just (makeProg d)) 60 | g (x:xs) ys d = if x `elem` ys 61 | then g xs ys d 62 | else do r <- loadFile x 63 | case r of 64 | Nothing -> toplevel Nothing 65 | Just (fs,d') -> g (xs++fs) (x:ys) (d++d') 66 | Prog -> case p of 67 | Nothing -> do putStrLn "No program loaded" 68 | toplevel p 69 | Just (t,d) -> do putStrLn (showProg (t,d)) 70 | toplevel p 71 | Term -> case p of 72 | Nothing -> do putStrLn "No program loaded" 73 | toplevel p 74 | Just (t,d) -> do print t 75 | toplevel p 76 | Eval -> case p of 77 | Nothing -> do putStrLn "No program loaded" 78 | toplevel p 79 | Just (t,d) -> f (free t) t 80 | where 81 | f [] t = do let (v,r,a) = eval t EmptyCtx d 0 0 82 | print v 83 | putStrLn ("Reductions: " ++ show r) 84 | putStrLn ("Allocations: " ++ show a) 85 | toplevel p 86 | f (x:xs) t = do putStr (x++" = ") 87 | hFlush stdout 88 | l <- getLine 89 | case parseTerm l of 90 | Left s -> do putStrLn ("Could not parse term: "++ show s) 91 | f (x:xs) t 92 | Right u -> f xs (subst u (abstract t x)) 93 | Distill f -> case p of 94 | Nothing -> do putStrLn "No program loaded" 95 | toplevel p 96 | Just (t,d) -> do let p' = dist (t,d) 97 | putStrLn (showProg p') 98 | case f of 99 | Nothing -> return () 100 | Just f -> writeFile f (showProg p') 101 | toplevel (Just p') 102 | Quit -> return () 103 | Help -> do putStrLn helpMessage 104 | toplevel p 105 | Unknown -> do putStrLn "Err: Could not parse command, type ':help' for a list of commands" 106 | toplevel p 107 | 108 | loadFile :: String -> IO (Maybe ([String],[(String,([String],Term))])) 109 | 110 | loadFile f = do x <- doesFileExist (f++".pot") 111 | if x 112 | then do putStrLn ("Loading file: "++f++".pot") 113 | c <- readFile (f++".pot") 114 | case parseModule c of 115 | Left s -> do putStrLn ("Could not parse program in file "++f++".pot: "++ show s) 116 | return Nothing 117 | Right t -> return (Just t) 118 | else do putStrLn ("No such file: "++f++".pot") 119 | return Nothing 120 | -------------------------------------------------------------------------------- /inputs/linearAlgebra.pot: -------------------------------------------------------------------------------- 1 | import Bool 2 | 3 | main = 4 | 5 | kron isZ (or) (mask m1 msk) m2 6 | 7 | -- ??? 8 | -- mMult isZ f g m1 m2 9 | 10 | -- SLOW / DIV 11 | -- mMult isZ1 p1 mlt m2 (mask m3 msk) 12 | 13 | -- OK 14 | -- (mAdd isZ1 p1 m2 (mask m3 msk)) 15 | 16 | -- OK 17 | -- (mAdd isZ1 p1 (mask m3 msk) m2) 18 | 19 | -- OK 20 | -- mask (mAdd isZ1 p1 m2 m3) msk 21 | 22 | -- OK 23 | -- kron isZ p (mask m1 msk) m2 24 | 25 | -- OK 26 | -- kron isZ p m2 (mask m1 msk) 27 | 28 | -- OK 29 | -- mask (kron isZ1 p1 m2 m3) msk 30 | 31 | -- OK 32 | -- mAdd isZ2 p2 (mAdd isZ1 p1 m2 m3) m1 33 | 34 | -- OK but slow 35 | -- mAdd isZ2 p2 (mAdd isZ1 p1 m2 m3) (mAdd isZ2 p2 m1 m4) 36 | 37 | -- OK but slow 38 | -- mAdd isZ2 p2 (kron isZ1 p1 m2 m3) (mAdd isZ2 p2 m1 m4) 39 | 40 | -- OK 41 | -- mask (mask m1 msk1) msk2 42 | 43 | -- OK 44 | -- eWizeScalarOp isZ g s2 (eWizeScalarOp isZ g s m) 45 | 46 | -- OK 47 | -- eWizeScalarOp isZ1 g s2 (eWizeScalarOp isZ2 g2 s m) 48 | 49 | -- OK 50 | -- mAdd isZ1 p1 (kron isZ1 p1 m2 m3) m1 51 | 52 | -- OK 53 | -- map isZ fT (kron isZ op m1 m2) 54 | 55 | -- OK 56 | -- map isZ3 g (map isZ2 fT (kron isZ1 op m1 m2)) 57 | 58 | -- OK 59 | -- map isZ f (mAdd isZ op m1 m2) 60 | 61 | -- DIV or SLOW 62 | -- fold or (False) (map isZ fT (kron isZ op m1 m2)) 63 | 64 | -- OK 65 | -- mAdd isZ op m1 m1 66 | 67 | -- OK 68 | -- map isZ2 fT (kron isZ mlt m1 (Node ((Node (Val (x), None, Val (y), None)), 69 | -- None, 70 | -- (Node (Val (a), Val (b), None, None)), 71 | -- (Node (None, None, None, Val (c)))))) 72 | 73 | -- OK 74 | -- mAdd isZ pls (kron isZ mlt m1 (Node ((Node (Val (x), None, Val (y), None)), 75 | -- None, 76 | -- (Node (Val (a), Val (b), None, None)), 77 | -- (Node (None, None, None, Val (c)))))) 78 | -- (kron isZ mlt m2 (Node ((Node (Val (x), None, Val (y), None)), 79 | -- None, 80 | -- (Node (Val (a), Val (b), None, None)), 81 | -- (Node (None, None, None, Val (c)))))) 82 | 83 | -- OK 84 | -- mAdd isZ pls (kron isZ mlt m1 (Node ((Node (Val (x), None, Val (y), None)), 85 | -- None, 86 | -- (Node (Val (a), Val (b), None, None)), 87 | -- (Node (None, None, None, Val (c)))))) 88 | -- m2 89 | 90 | ; 91 | 92 | fT x = True; 93 | 94 | mkNode isZ x = case (isZ x) of True -> None | False -> Val(x); 95 | 96 | reduceTree n1 n2 n3 n4 = Node (n1, n2, n3, n4); 97 | 98 | reduceTree2 n1 n2 n3 n4 = 99 | let nd = Node (n1, n2, n3, n4) in 100 | (case n1 of 101 | None -> (case n2 of 102 | None -> (case n3 of 103 | None -> (case n4 of 104 | None -> None 105 | | Error -> Error 106 | | Val (v4) -> nd 107 | | Node (m1, m2, m3, m4) -> nd) 108 | | Error -> Error 109 | | Val (v3) -> nd 110 | | Node (l1, l2, l3, l4) -> nd) 111 | | Error -> Error 112 | | Val (v2) -> nd 113 | | Node (k1, k2, k3, k4) -> nd) 114 | | Error -> Error 115 | | Val (v1) -> nd 116 | | Node (j1, j2, j3, j4) -> nd) 117 | 118 | ; 119 | 120 | reduceTree1 n1 n2 n3 n4 = 121 | case n1 of 122 | None -> (case n2 of 123 | None -> (case n3 of 124 | None -> (case n4 of 125 | None -> None 126 | | Error -> Error 127 | | Val (v4) -> Node (n1, n2, n3, n4) 128 | | Node (m1, m2, m3, m4) -> Node (n1, n2, n3, n4)) 129 | | Error -> Error 130 | | Val (v3) -> Node (n1, n2, n3, n4) 131 | | Node (l1, l2, l3, l4) -> Node (n1, n2, n3, n4)) 132 | | Error -> Error 133 | | Val (v2) -> Node (n1, n2, n3, n4) 134 | | Node (k1, k2, k3, k4) -> Node (n1, n2, n3, n4)) 135 | | Error -> Error 136 | | Val (v1) -> Node (n1, n2, n3, n4) 137 | | Node (j1, j2, j3, j4) -> Node (n1, n2, n3, n4) 138 | ; 139 | 140 | mAdd isZ g m1 m2 = 141 | case m1 of 142 | Error -> Error 143 | | None -> (m2) 144 | | Val (v1) -> (case m2 of 145 | Error -> Error 146 | | None -> m1 147 | | Val (v) -> (mkNode isZ (g v1 v)) 148 | | Node (t1, t2, t3, t4) -> Error) 149 | | Node (q1, q2, q3, q4) -> (case m2 of 150 | Error -> Error 151 | | None -> m1 152 | | Val (v) -> Error 153 | | Node (t1, t2, t3, t4) -> (reduceTree 154 | (mAdd isZ g q1 t1) 155 | (mAdd isZ g q2 t2) 156 | (mAdd isZ g q3 t3) 157 | (mAdd isZ g q4 t4))); 158 | 159 | mask m msk = 160 | case msk of 161 | MNone -> None 162 | | MVal -> m 163 | | MNode (q1, q2, q3, q4) -> 164 | (case m of 165 | Error -> Error 166 | | None -> None 167 | | Val (v) -> Error 168 | | Node (t1, t2, t3, t4) -> (reduceTree (mask t1 q1) (mask t2 q2) (mask t3 q3) (mask t4 q4))); 169 | 170 | combine add mult q1 q2 q3 q4 t1 t2 t3 t4 = 171 | (reduceTree 172 | (add (mult q1 t1)(mult q2 t3)) 173 | (add (mult q1 t2)(mult q2 t4)) 174 | (add (mult q3 t1)(mult q4 t3)) 175 | (add (mult q3 t2)(mult q4 t4))) 176 | ; 177 | 178 | mMult isZ g h m1 m2 = 179 | case m1 of 180 | Error -> Error 181 | | None -> None 182 | | Val (v1) -> 183 | (case m2 of 184 | Error -> Error 185 | | None -> None 186 | | Val (v) -> (mkNode isZ (h v1 v)) 187 | | Node (t1, t2, t3, t4) -> Error) 188 | | Node (q1, q2, q3, q4) -> 189 | (case m2 of 190 | Error -> Error 191 | | None -> None 192 | | Val (v) -> Error 193 | | Node (t1, t2, t3, t4) -> (combine (mAdd isZ g) (mMult isZ g h) q1 q2 q3 q4 t1 t2 t3 t4)) 194 | ; 195 | 196 | map isZ f m = 197 | case m of 198 | Error -> Error 199 | | None -> None 200 | | Val (v) -> (mkNode isZ (f v)) 201 | | Node (q1, q2, q3, q4) -> (reduceTree 202 | (map isZ f q1) 203 | (map isZ f q2) 204 | (map isZ f q3) 205 | (map isZ f q4)); 206 | 207 | kron isZ g m1 m2 = 208 | case m1 of 209 | Error -> Error 210 | | None -> None 211 | | Val (v) -> (map isZ (g v) m2) 212 | | Node (q1, q2, q3, q4) -> (reduceTree 213 | (kron isZ g q1 m2) 214 | (kron isZ g q2 m2) 215 | (kron isZ g q3 m2) 216 | (kron isZ g q4 m2)) 217 | 218 | ; 219 | 220 | fold f s m = 221 | case m of 222 | None -> s 223 | | Error -> s 224 | | Val(v) -> (f s v) 225 | | Node (n1, n2, n3, n4) -> (fold f (fold f (fold f (fold f s n1) n2) n3) n4) -------------------------------------------------------------------------------- /src/Trans.hs: -------------------------------------------------------------------------------- 1 | module Trans where 2 | 3 | import Term 4 | import Tree 5 | import Exception 6 | import Prelude hiding ((<>)) 7 | import Data.Maybe 8 | import Data.List 9 | import Data.Tuple 10 | 11 | dist (t,d) = let t' = returnval (distill t EmptyCtx (free t) [] d) 12 | (t'',s,d') = residualise t' [] 13 | in (instantiate s t'',d') 14 | 15 | -- supercompiler 16 | 17 | super (Free x) (CaseCtx k bs) fv m d = do 18 | bs' <- mapM (\(c,xs,t) -> let t' = place t k 19 | fv' = renameVars fv xs 20 | xs' = take (length xs) fv' 21 | u = foldr concrete (subst (Con c (map Free xs')) (abstract t' x)) xs' 22 | in do 23 | u' <- super u EmptyCtx fv' m d 24 | return (c,xs',u')) bs 25 | return (Choice (Var x) bs') 26 | super (Free x) k fv m d = superCtx (Var x) k fv m d 27 | super (Lambda x t) EmptyCtx fv m d = let x' = renameVar fv x 28 | in do 29 | t' <- super (concrete x' t) EmptyCtx (x':fv) m d 30 | return (Abs x' t') 31 | super (Lambda x t) (ApplyCtx k u) fv m d = super (subst u t) k fv m d 32 | super (Lambda x t) (CaseCtx k bs) fv m d = error "Unapplied function in case selector" 33 | super (Con c ts) EmptyCtx fv m d = do 34 | ts' <- mapM (\t -> super t EmptyCtx fv m d) ts 35 | return (Cons c ts') 36 | super (Con c ts) (ApplyCtx k u) fv m d = error ("Constructor application is not saturated: "++show (place (Con c ts) (ApplyCtx k u))) 37 | super (Con c ts) (CaseCtx k bs) fv m d = case find (\(c',xs,t) -> c==c' && length xs == length ts) bs of 38 | Nothing -> error ("No matching pattern in case for term:\n\n"++show (Case (Con c ts) bs)) 39 | Just (c',xs,t) -> super (foldr subst t ts) k fv m d 40 | super (Apply t u) k fv m d = super t (ApplyCtx k u) fv m d 41 | super (Fun f) k fv m d = let t = place (Fun f) k 42 | in case [(f,t') | (f,t') <- m, embedding t' t] of 43 | [] -> let f = renameVar (map fst m) "f" 44 | handler (f',t') = if f==f' 45 | then let (u,s1,s2) = generalise t t' fv 46 | fv' = map fst s1 ++ fv 47 | in do 48 | s <- mapM (\(x,t) -> do 49 | t' <- super t EmptyCtx fv' m d 50 | return (x,t')) s1 51 | u' <- super u EmptyCtx fv' m d 52 | return (makeGen s u') 53 | else throw (f',t') 54 | in do 55 | u <- handle (super (unfold(t,d)) EmptyCtx fv ((f,t):m) d) handler 56 | return (if f `elem` folds u then Unfold f u else u) 57 | m'-> case [(f,s) | (f,t') <- m', s <- inst t' t] of 58 | ((f,s):_) -> do 59 | s' <- mapM (\(x,t) -> do 60 | t' <- super t EmptyCtx fv m d 61 | return (x,t')) s 62 | return (Fold f s') 63 | [] -> let (f,_) = head m' 64 | in throw (f,t) 65 | 66 | super (Case t bs) k fv m d = super t (CaseCtx k bs) fv m d 67 | super (Let x t u) k fv m d = super (subst t u) k fv m d 68 | 69 | superCtx t EmptyCtx fv m d = return t 70 | superCtx t (ApplyCtx k u) fv m d = do 71 | u' <- super u EmptyCtx fv m d 72 | superCtx (App t u') k fv m d 73 | superCtx t (CaseCtx k bs) fv m d = do 74 | bs' <- mapM (\(c,xs,t) -> let fv' = renameVars fv xs 75 | xs' = take (length xs) fv' 76 | in do 77 | t' <- super (foldr concrete t xs') k fv' m d 78 | return (c,xs',t')) bs 79 | return (Choice t bs') 80 | 81 | -- distiller 82 | 83 | distill (Free x) (CaseCtx k bs) fv m d = do 84 | bs' <- mapM (\(c,xs,t) -> let t' = place t k 85 | fv' = renameVars fv xs 86 | xs' = take (length xs) fv' 87 | u = foldr concrete (subst (Con c (map Free xs')) (abstract t' x)) xs' 88 | in do 89 | u' <- distill u EmptyCtx fv' m d 90 | return (c,xs',u')) bs 91 | return (Choice (Var x) bs') 92 | distill (Free x) k fv m d = distillCtx (Var x) k fv m d 93 | distill (Lambda x t) EmptyCtx fv m d = let x' = renameVar fv x 94 | in do 95 | t' <- distill (concrete x' t) EmptyCtx (x':fv) m d 96 | return (Abs x' t') 97 | distill (Lambda x t) (ApplyCtx k u) fv m d = distill (subst u t) k fv m d 98 | distill (Lambda x t) (CaseCtx k bs) fv m d = error "Unapplied function in case selector" 99 | distill (Con c ts) EmptyCtx fv m d = do 100 | ts' <- mapM (\t -> distill t EmptyCtx fv m d) ts 101 | return (Cons c ts') 102 | distill (Con c ts) (ApplyCtx k u) fv m d = error ("Constructor application is not saturated: "++show (place (Con c ts) (ApplyCtx k u))) 103 | distill (Con c ts) (CaseCtx k bs) fv m d = case find (\(c',xs,t) -> c==c' && length xs == length ts) bs of 104 | Nothing -> error ("No matching pattern in case for term:\n\n"++show (Case (Con c ts) bs)) 105 | Just (c',xs,t) -> distill (foldr subst t ts) k fv m d 106 | distill (Apply t u) k fv m d = distill t (ApplyCtx k u) fv m d 107 | distill (Fun f) k fv m d = let t = returnval (super (Fun f) k fv [] d) 108 | in case [(f,s) | (f,t') <- m, s <- instTree t' t] of 109 | ((f,s):_) -> return (Fold f s) 110 | [] -> case [f | (f,t') <- m, embeddingTree t' t] of 111 | (f:_) -> throw (f,t) 112 | [] -> let f = renameVar (map fst m) "f" 113 | (t',s',d') = residualise t [] 114 | handler (f',t') = if f==f' 115 | then let (u,s1,s2) = generaliseTree t t' 116 | in if null s1 117 | then return u 118 | else let (u',s',d') = residualise u s1 119 | fv' = map fst s1 ++ fv 120 | in do 121 | s'' <- mapM (\(x,t) -> do 122 | t' <- distill t EmptyCtx fv' m d' 123 | return (x,t')) s' 124 | u'' <- distill u' EmptyCtx fv' m d' 125 | return (makeGen s'' u'') 126 | else throw (f',t') 127 | in do 128 | u <- handle (distill (unfold(t',d')) EmptyCtx fv ((f,t):m) d') handler 129 | return (if f `elem` folds u then Unfold f u else u) 130 | distill (Case t bs) k fv m d = distill t (CaseCtx k bs) fv m d 131 | distill (Let x t u) k fv m d = distill (subst t u) k fv m d 132 | 133 | distillCtx t EmptyCtx fv m d = return t 134 | distillCtx t (ApplyCtx k u) fv m d = do 135 | u' <- distill u EmptyCtx fv m d 136 | distillCtx (App t u') k fv m d 137 | distillCtx t (CaseCtx k bs) fv m d = do 138 | bs' <- mapM (\(c,xs,t) -> let fv' = renameVars fv xs 139 | xs' = take (length xs) fv' 140 | in do 141 | t' <- distill (foldr concrete t xs') k fv' m d 142 | return (c,xs',t')) bs 143 | return (Choice t bs') -------------------------------------------------------------------------------- /src/Tree.hs: -------------------------------------------------------------------------------- 1 | module Tree where 2 | 3 | import Term 4 | import Prelude hiding ((<>)) 5 | import Data.Char 6 | import Data.Maybe 7 | import Data.List 8 | import Data.Tuple 9 | import Data.Foldable 10 | import Data.Bifunctor 11 | import Control.Monad 12 | import Text.PrettyPrint.HughesPJ as P 13 | import Text.ParserCombinators.Parsec hiding (labels) 14 | import Text.ParserCombinators.Parsec.Expr 15 | import qualified Text.ParserCombinators.Parsec.Token as T 16 | import Text.ParserCombinators.Parsec.Language 17 | import System.IO 18 | import System.Directory 19 | 20 | -- process trees 21 | 22 | data Tree = Var String -- variable 23 | | Abs String Tree -- lambda abstraction 24 | | Cons String [Tree] -- constructor 25 | | App Tree Tree -- application 26 | | Choice Tree [(String,[String],Tree)] -- case 27 | | Gen String Tree Tree -- generalisation node 28 | | Unfold String Tree -- unfold node 29 | | Fold String [(String,Tree)] -- fold node 30 | 31 | matchChoice bs bs' = length bs == length bs' && all (\((c,xs,t),(c',xs',t')) -> c == c' && length xs == length xs') (zip bs bs') 32 | 33 | -- equality of process trees 34 | 35 | instance Eq Tree where 36 | (==) t t' = eqTree [] t t' [] 37 | 38 | eqTree fs (Var x) (Var x') r | x `elem` map fst r = (x,x') `elem` r 39 | eqTree fs (Var x) (Var x') r = x==x' 40 | eqTree fs (Abs x t) (Abs x' t') r = eqTree fs t t' ((x,x'):r) 41 | eqTree fs (Cons c ts) (Cons c' ts') r | c==c' = all (\(t,t') -> eqTree fs t t' r) (zip ts ts') 42 | eqTree fs (App t u) (App t' u') r = eqTree fs t t' r && eqTree fs u u' r 43 | eqTree fs (Choice t bs) (Choice t' bs') r | matchChoice bs bs' = eqTree fs t t' r && all (\((c,xs,t),(c',xs',t')) -> eqTree fs t t' (zip xs xs'++r)) (zip bs bs') 44 | eqTree fs (Gen x t u) (Gen x' t' u') r = eqTree fs t t' r && eqTree fs u u' ((x,x'):r) 45 | eqTree fs (Unfold f t) (Unfold f' t') r = eqTree ((f,f'):fs) t t' r 46 | eqTree fs (Fold f _) (Fold f' _) r = (f,f') `elem` fs 47 | eqTree fs t t' r = False 48 | 49 | -- process tree renaming 50 | 51 | renamingTree t t' = renamingTree' [] t t' [] 52 | 53 | renamingTree' fs (Var x) (Var x') r = if x `elem` map fst r || x' `elem` map snd r 54 | then [r | (x,x') `elem` r] 55 | else [(x,x'):r] 56 | renamingTree' fs (Abs x t) (Abs x' t') r = renamingTree' fs t t' ((x,x'):r) 57 | renamingTree' fs (Cons c ts) (Cons c' ts') r | c==c' = foldr (\(t,t') rs -> concat [renamingTree' fs t t' r | r <- rs]) [r] (zip ts ts') 58 | renamingTree' fs (App t u) (App t' u') r = concat [renamingTree' fs u u' r' | r' <- renamingTree' fs t t' r] 59 | renamingTree' fs (Choice t bs) (Choice t' bs') r = foldr (\((c,xs,t),(c',xs',t')) rs -> concat [renamingTree' fs t t' (zip xs xs' ++ r) | r <- rs]) (renamingTree' fs t t' r) (zip bs bs') 60 | renamingTree' fs (Gen x t u) (Gen x' t' u') r = concat [renamingTree' fs u u' ((x,x'):r') | r' <- renamingTree' fs t t' r] 61 | renamingTree' fs (Unfold f u) (Unfold f' u') r = renamingTree' ((f,f'):fs) u u' r 62 | renamingTree' fs (Fold f s) (Fold f' s') r | (f,f') `elem` fs = foldr (\((x,t),(x',t')) rs -> concat [renamingTree' fs t t' r' | r' <- renamingTree' fs (Var x) (Var x') r]) [r] (zip s s') 63 | renamingTree' fs t t' r = [] 64 | 65 | -- process tree instance 66 | 67 | instTree t u = instTree' [] t u [] [] 68 | 69 | instTree' fs (Var x) (Var x') r s | x `elem` map fst r = [s | (x,x') `elem` r] 70 | instTree' fs (Var x) t r s | x `elem` map fst r = [] 71 | instTree' fs (Var x) t r s = if x `elem` map fst s 72 | then [s | (x,t) `elem` s] 73 | else [(x,t):s] 74 | instTree' fs (Abs x t) (Abs x' t') r s = instTree' fs t t' ((x,x'):r) s 75 | instTree' fs (Cons c ts) (Cons c' ts') r s | c==c' = foldr (\(t,t') ss -> concat [instTree' fs t t' r s | s <- ss]) [s] (zip ts ts') 76 | instTree' fs (App t u) (App t' u') r s = concat [instTree' fs u u' r s' | s' <- instTree' fs t t' r s] 77 | instTree' fs (Choice t bs) (Choice t' bs') r s | matchChoice bs bs' = foldr (\((c,xs,t),(c',xs',t')) ss -> concat [instTree' fs t t' (zip xs xs' ++ r) s | s <- ss]) (instTree' fs t t' r s) (zip bs bs') 78 | instTree' fs (Gen x t u) (Gen x' t' u') r s = concat [instTree' fs u u' ((x,x'):r) s' | s' <- instTree' fs t t' r s] 79 | instTree' fs (Unfold f t) (Unfold f' t') r s = instTree' ((f,f'):fs) t t' r s 80 | instTree' fs (Fold f _) (Fold f' _) r s = [s | (f,f') `elem` fs] 81 | instTree' fs t u r s | appInst t u' = let (x,t') = appInstVal t u' 82 | in instTree' fs (Var x) t' r s 83 | where u' = renameTree (map swap r) u 84 | instTree' fs t t' r s = [] 85 | 86 | -- homeomorphic embedding of process trees 87 | 88 | embeddingTree = coupleTree [] 89 | 90 | embedTree fs t u = coupleTree fs t u || diveTree fs t u 91 | 92 | coupleTree fs (Var x) (Var x') = True 93 | coupleTree fs (Abs x t) (Abs x' t') = embedTree fs t t' 94 | coupleTree fs (Cons c ts) (Cons c' ts') | c==c' = all (uncurry (embedTree fs)) (zip ts ts') 95 | coupleTree fs (App t u) (App t' u') = embedTree fs u u' && embedTree fs t t' 96 | coupleTree fs (Choice t bs) (Choice t' bs') | matchChoice bs bs' = embedTree fs t t' && all (\((c,xs,t),(c',xs',t'))-> embedTree fs t t') (zip bs bs') 97 | coupleTree fs (Gen x t u) (Gen x' t' u') = embedTree fs t t' && embedTree fs u u' 98 | coupleTree fs (Unfold f t) (Unfold f' t') = embedTree ((f,f'):fs) t t' 99 | coupleTree fs (Fold f _) (Fold f' _) = (f,f') `elem` fs 100 | coupleTree fs t t' = False 101 | 102 | diveTree fs t (Abs x t') = embedTree fs t t' 103 | diveTree fs t (Cons c ts) = any (embedTree fs t) ts 104 | diveTree fs t (App t' u) = embedTree fs t t' || embedTree fs t u 105 | diveTree fs t (Choice t' bs) = embedTree fs t t' || any (\(c,xs,t') -> embedTree fs t t') bs 106 | diveTree fs t (Gen x t' u) = embedTree fs t t' || embedTree fs t u 107 | diveTree fs t (Unfold t' u) = embedTree fs t u 108 | diveTree fs t t' = False 109 | 110 | -- generalisation of process trees 111 | 112 | generaliseTree t u = generaliseTree' [] t u (varsTree t) [] [] [] 113 | 114 | generaliseTree' fs (Var x) (Var x') fv r s1 s2 = (Var x,s1,s2) 115 | generaliseTree' fs t u fv r s1 s2 | appInst t u' = let (x,t') = appInstVal t u' 116 | in (t,s1,(x,t'):s2) 117 | where u' = renameTree (map swap r) u 118 | generaliseTree' fs t u fv r s1 s2 | coupleTree fs t u = generaliseTree'' fs t u fv r s1 s2 119 | generaliseTree' fs t u fv r s1 s2 = case [x | (x,t') <- s1, (x',u') <- s2, x==x' && t==t' && u==u'] of 120 | (x:_) -> (Var x,s1,s2) 121 | [] -> let x = renameVar (fv++map fst s1) "x" 122 | in (Var x,(x,t):s1,(x,u):s2) 123 | 124 | generaliseTree'' fs (Abs x t) (Abs x' t') fv r s1 s2 = let (t'',s1',s2') = generaliseTree' fs t t' fv ((x,x'):r) s1 s2 125 | in (Abs x t'',s1',s2') 126 | generaliseTree'' fs (Cons c ts) (Cons c' ts') fv r s1 s2 = let ((s1',s2'),ts'') = mapAccumL (\(s1,s2) (t,t') -> let (t'',s1',s2') = generaliseTree' fs t t' fv r s1 s2 127 | in ((s1',s2'),t'')) (s1,s2) (zip ts ts') 128 | in (Cons c ts'',s1',s2') 129 | generaliseTree'' fs (App t u) (App t' u') fv r s1 s2 = let (t'',s1',s2') = generaliseTree' fs t t' fv r s1 s2 130 | (u'',s1'',s2'') = generaliseTree' fs u u' fv r s1' s2' 131 | in (App t'' u'',s1'',s2'') 132 | generaliseTree'' fs (Choice t bs) (Choice t' bs') fv r s1 s2 = let (t'',s1',s2') = generaliseTree' fs t t' fv r s1 s2 133 | ((s1'',s2''),bs'') = mapAccumL (\(s1,s2) ((c,xs,t),(c',xs',t')) -> let (t'',s1',s2') = generaliseTree' fs t t' fv (zip xs xs' ++ r) s1 s2 134 | in ((s1',s2'),(c,xs,t''))) (s1',s2') (zip bs bs') 135 | in (Choice t'' bs'',s1'',s2'') 136 | generaliseTree'' fs (Gen x t u) (Gen x' t' u') fv r s1 s2 = let (u'',s1',s2') = generaliseTree' fs u (renameTree [(x',x)] u') fv ((x,x):r) s1 s2 137 | in if x `elem` map fst s2' 138 | then let x' = renameVar (fv++map fst s1') "x" 139 | in (Gen x (Var x') u'',(x',t):s1',s2') 140 | else (Gen x t u'',s1',s2') 141 | generaliseTree'' fs (Unfold f t) (Unfold f' t') fv r s1 s2 = let (t'',s1',s2') = generaliseTree' ((f,f'):fs) t t' fv r s1 s2 142 | in (Unfold f t'',s1',s2') 143 | generaliseTree'' fs (Fold f s) (Fold f' s') fv r s1 s2 | (f,f') `elem` fs = (Fold f s,s1,s2) 144 | 145 | makeGen s t = foldl (\u (x,t) -> Gen x t u) t s 146 | 147 | -- Final program residualisation 148 | 149 | residualise t s = let (t',s',d) = residualise' t (freeTree t) [] [] s [] 150 | in (t',s',[(f,(xs,t')) | (f,(xs,t,t')) <- d]) 151 | 152 | residualise' (Var x) fv bv m s d | x `elem` map fst s = let Just t = lookup x s 153 | (t',s',d') = residualise' t fv bv m s d 154 | xs = free t' `intersect` bv 155 | in (foldl (\t x -> Apply t (Free x)) (Free x) xs,(x,foldr (\x t->Lambda x (abstract t x)) t' xs):s',d') 156 | residualise' (Var x) fv bv m s d = (Free x,[],d) 157 | residualise' (Abs x t) fv bv m s d = let (t',s',d') = residualise' t fv (x:bv) m s d 158 | in (Lambda x (abstract t' x),s',d') 159 | residualise' (Cons c ts) fv bv m s d = let ((s',d'),ts') = mapAccumL (\(s',d) t -> let (t',s'',d') = residualise' t fv bv m s d 160 | in ((s'++s'',d'),t')) ([],d) ts 161 | in (Con c ts',s',d') 162 | residualise' (App t u) fv bv m s d = let (t',s',d') = residualise' t fv bv m s d 163 | (u',s'',d'') = residualise' u fv bv m s d' 164 | in (Apply t' u',s'++s'',d'') 165 | residualise' (Choice t bs) fv bv m s d = let (t',s',d') = residualise' t fv bv m s d 166 | ((s'',d''),bs') = mapAccumL (\(s',d) (c,xs,t) -> let (t',s'',d') = residualise' t fv (xs++bv) m s d 167 | in ((s'++s'',d'),(c,xs,foldl abstract t' xs))) (s',d') bs 168 | in (Case t' bs',s'++s'',d'') 169 | residualise' (Gen x t u) fv bv m s d = let (t',s',d') = residualise' t fv bv m s d 170 | (u',s'',d'') = residualise' u fv (x:bv) m s d' 171 | in (subst t' (abstract u' x),s'++s'',d'') 172 | residualise' (Unfold f t) fv bv m s d = case [(f',xs,r) | (f',(xs,t',u)) <- d, r <- renamingTree t' (Unfold f t)] of 173 | ((f',xs,r):_) -> (rename r (foldl (\t x -> Apply t (Free x)) (Fun f') xs),[],d) 174 | [] -> let f' = renameVar (fv++bv++map fst d) "f" 175 | xs = freeTree t 176 | t' = foldl (\t x -> Apply t (Free x)) (Fun f') xs 177 | (u,s',d') = residualise' t (f':fv) (xs++bv) ((f,t'):m) s d 178 | in (t',s',(f',(xs,Unfold f t,foldl abstract u xs)):d') 179 | residualise' (Fold f e) fv bv m s d = case [t | (f',t) <- m, f==f'] of 180 | (t:_) -> let ((s',d'),e') = mapAccumL (\(s',d) (x,t) -> let (t',s'',d') = residualise' t fv bv m s d 181 | in ((s'++s'',d'),(x,t'))) ([],d) e 182 | in (instantiate e' t,s',d') 183 | 184 | -- process tree renaming 185 | 186 | renameTree r (Var x) = case lookup x r of 187 | Just x' -> Var x' 188 | Nothing -> Var x 189 | renameTree r (Abs x t) = Abs x (renameTree r t) 190 | renameTree r (Cons c ts) = Cons c (map (renameTree r) ts) 191 | renameTree r (App t u) = App (renameTree r t) (renameTree r u) 192 | renameTree r (Choice t bs) = Choice (renameTree r t) (map (\(c,xs,t) -> (c,xs,renameTree r t)) bs) 193 | renameTree r (Gen x t u) = Gen x (renameTree r t) (renameTree r u) 194 | renameTree r (Unfold f t) = Unfold f (renameTree r t) 195 | renameTree r (Fold f s) = Fold f (map (Data.Bifunctor.second (renameTree r)) s) 196 | 197 | -- free variables in a process tree 198 | 199 | freeTree t = nub (freeTree' [] t) 200 | 201 | freeTree' bv (Var x) = [x | x `notElem` bv] 202 | freeTree' bv (Abs x t) = freeTree' (x:bv) t 203 | freeTree' bv (Cons c ts) = concatMap (freeTree' bv) ts 204 | freeTree' bv (App t u) = freeTree' bv t ++ freeTree' bv u 205 | freeTree' bv (Choice t bs) = freeTree' bv t ++ concatMap (\(c,xs,t) -> freeTree' (xs++bv) t) bs 206 | freeTree' bv (Gen x t u) = freeTree' bv t ++ freeTree' (x:bv) u 207 | freeTree' bv (Unfold f t) = freeTree' bv t 208 | freeTree' bv (Fold f s) = concatMap (\(x,t) -> freeTree' bv t) s 209 | 210 | -- variables in a process tree 211 | 212 | varsTree :: Tree -> [String] 213 | varsTree t = nub (varsTree' t) 214 | 215 | varsTree' (Var x) = [x] 216 | varsTree' (Abs x t) = x:varsTree' t 217 | varsTree' (Cons c ts) = concatMap varsTree' ts 218 | varsTree' (App t u) = varsTree' t ++ varsTree' u 219 | varsTree' (Choice t bs) = varsTree' t ++ concatMap (\(c,xs,t) -> xs++varsTree' t) bs 220 | varsTree' (Gen x t u) = varsTree' t ++ x:varsTree' u 221 | varsTree' (Unfold f t) = varsTree' t 222 | varsTree' (Fold f s) = concatMap (\(x,t) -> varsTree' t) s 223 | 224 | -- folds in a process tree 225 | 226 | folds (Var x) = [] 227 | folds (Abs x t) = folds t 228 | folds (Cons c ts) = concatMap folds ts 229 | folds (App t u) = folds t ++ folds u 230 | folds (Choice t bs) = folds t ++ concatMap (\(c,xs,t) -> folds t) bs 231 | folds (Gen x t u) = folds t ++ folds u 232 | folds (Unfold f t) = filter (/=f) (folds t) 233 | folds (Fold f s) = [f] 234 | 235 | appInst (Var x) u = x `elem` freeTree u 236 | appInst (App t (Var x)) u = appInst t (Abs x u) 237 | appInst t u = False 238 | 239 | appInstVal (Var x) u = (x,u) 240 | appInstVal (App t (Var x)) u = appInstVal t (Abs x u) -------------------------------------------------------------------------------- /examples/MAddsDistilled.pot: -------------------------------------------------------------------------------- 1 | import Bool 2 | import Matrices 3 | import QTree 4 | 5 | main = f (m1) (m2) (m3); 6 | f m1 m2 m3 = 7 | (case m1 of 8 | Error -> 9 | Error 10 | | None -> 11 | (case m2 of 12 | Error -> 13 | Error 14 | | None -> 15 | m3 16 | | Val(v1) -> 17 | (case m3 of 18 | Error -> 19 | Error 20 | | None -> 21 | Val(v1) 22 | | Val(v) -> 23 | (case v1 of 24 | True -> 25 | Val(True) 26 | | False -> 27 | (case v of 28 | True -> 29 | Val(True) 30 | | False -> 31 | None)) 32 | | Node(t1,t2,t3,t4) -> 33 | Error) 34 | | Node(q1,q2,q3,q4) -> 35 | (case m3 of 36 | Error -> 37 | Error 38 | | None -> 39 | Node(q1, q2, q3, q4) 40 | | Val(v) -> 41 | Error 42 | | Node(t1,t2,t3,t4) -> 43 | f' q1 t1 q2 t2 q3 t3 q4 t4)) 44 | | Val(v1) -> 45 | (case m2 of 46 | Error -> 47 | Error 48 | | None -> 49 | (case m3 of 50 | Error -> 51 | Error 52 | | None -> 53 | Val(v1) 54 | | Val(v) -> 55 | (case v1 of 56 | True -> 57 | Val(True) 58 | | False -> 59 | (case v of 60 | True -> 61 | Val(True) 62 | | False -> 63 | None)) 64 | | Node(t1,t2,t3,t4) -> 65 | Error) 66 | | Val(v) -> 67 | (case v1 of 68 | True -> 69 | (case m3 of 70 | Error -> 71 | Error 72 | | None -> 73 | Val(True) 74 | | Val(v) -> 75 | Val(True) 76 | | Node(t1,t2,t3,t4) -> 77 | Error) 78 | | False -> 79 | (case v of 80 | True -> 81 | (case m3 of 82 | Error -> 83 | Error 84 | | None -> 85 | Val(True) 86 | | Val(v) -> 87 | Val(True) 88 | | Node(t1,t2,t3,t4) -> 89 | Error) 90 | | False -> 91 | m3)) 92 | | Node(t1,t2,t3,t4) -> 93 | Error) 94 | | Node(q1,q2,q3,q4) -> 95 | (case m2 of 96 | Error -> 97 | Error 98 | | None -> 99 | (case m3 of 100 | Error -> 101 | Error 102 | | None -> 103 | Node(q1, q2, q3, q4) 104 | | Val(v) -> 105 | Error 106 | | Node(t1,t2,t3,t4) -> 107 | f'' q1 t1 q2 t2 q3 t3 q4 t4) 108 | | Val(v) -> 109 | Error 110 | | Node(t1,t2,t3,t4) -> 111 | (case m3 of 112 | Error -> 113 | Error 114 | | None -> 115 | f''' q1 t1 q2 t2 q3 t3 q4 t4 116 | | Val(v) -> 117 | Error 118 | | Node(t1',t2',t3',t4') -> 119 | Node(f q1 t1 t1', f q2 t2 t2', f q3 t3 t3', f q4 t4 t4')))); 120 | f''' q1 t1 q2 t2 q3 t3 q4 t4 = 121 | Node((case q1 of 122 | Error -> 123 | Error 124 | | None -> 125 | t1 126 | | Val(v1) -> 127 | (case t1 of 128 | Error -> 129 | Error 130 | | None -> 131 | Val(v1) 132 | | Val(v) -> 133 | (case v1 of 134 | True -> 135 | Val(True) 136 | | False -> 137 | (case v of 138 | True -> 139 | Val(True) 140 | | False -> 141 | None)) 142 | | Node(t1,t2,t3,t4) -> 143 | Error) 144 | | Node(q1,q2,q3,q4) -> 145 | (case t1 of 146 | Error -> 147 | Error 148 | | None -> 149 | Node(q1, q2, q3, q4) 150 | | Val(v) -> 151 | Error 152 | | Node(t1,t2,t3,t4) -> 153 | f''' q1 t1 q2 t2 q3 t3 q4 t4)), 154 | (case q2 of 155 | Error -> 156 | Error 157 | | None -> 158 | t2 159 | | Val(v1) -> 160 | (case t2 of 161 | Error -> 162 | Error 163 | | None -> 164 | Val(v1) 165 | | Val(v) -> 166 | (case v1 of 167 | True -> 168 | Val(True) 169 | | False -> 170 | (case v of 171 | True -> 172 | Val(True) 173 | | False -> 174 | None)) 175 | | Node(t1,t2,t3,t4) -> 176 | Error) 177 | | Node(q1,q2,q3,q4) -> 178 | (case t2 of 179 | Error -> 180 | Error 181 | | None -> 182 | Node(q1, q2, q3, q4) 183 | | Val(v) -> 184 | Error 185 | | Node(t1,t2,t3,t4) -> 186 | f''' q1 t1 q2 t2 q3 t3 q4 t4)), 187 | (case q3 of 188 | Error -> 189 | Error 190 | | None -> 191 | t3 192 | | Val(v1) -> 193 | (case t3 of 194 | Error -> 195 | Error 196 | | None -> 197 | Val(v1) 198 | | Val(v) -> 199 | (case v1 of 200 | True -> 201 | Val(True) 202 | | False -> 203 | (case v of 204 | True -> 205 | Val(True) 206 | | False -> 207 | None)) 208 | | Node(t1,t2,t3,t4) -> 209 | Error) 210 | | Node(q1,q2,q3,q4) -> 211 | (case t3 of 212 | Error -> 213 | Error 214 | | None -> 215 | Node(q1, q2, q3, q4) 216 | | Val(v) -> 217 | Error 218 | | Node(t1,t2,t3,t4) -> 219 | f''' q1 t1 q2 t2 q3 t3 q4 t4)), 220 | (case q4 of 221 | Error -> 222 | Error 223 | | None -> 224 | t4 225 | | Val(v1) -> 226 | (case t4 of 227 | Error -> 228 | Error 229 | | None -> 230 | Val(v1) 231 | | Val(v) -> 232 | (case v1 of 233 | True -> 234 | Val(True) 235 | | False -> 236 | (case v of 237 | True -> 238 | Val(True) 239 | | False -> 240 | None)) 241 | | Node(t1,t2,t3,t4) -> 242 | Error) 243 | | Node(q1,q2,q3,q4) -> 244 | (case t4 of 245 | Error -> 246 | Error 247 | | None -> 248 | Node(q1, q2, q3, q4) 249 | | Val(v) -> 250 | Error 251 | | Node(t1,t2,t3,t4) -> 252 | f''' q1 t1 q2 t2 q3 t3 q4 t4))); 253 | f'' q1 t1 q2 t2 q3 t3 q4 t4 = 254 | Node((case q1 of 255 | Error -> 256 | Error 257 | | None -> 258 | t1 259 | | Val(v1) -> 260 | (case t1 of 261 | Error -> 262 | Error 263 | | None -> 264 | Val(v1) 265 | | Val(v) -> 266 | (case v1 of 267 | True -> 268 | Val(True) 269 | | False -> 270 | (case v of 271 | True -> 272 | Val(True) 273 | | False -> 274 | None)) 275 | | Node(t1,t2,t3,t4) -> 276 | Error) 277 | | Node(q1,q2,q3,q4) -> 278 | (case t1 of 279 | Error -> 280 | Error 281 | | None -> 282 | Node(q1, q2, q3, q4) 283 | | Val(v) -> 284 | Error 285 | | Node(t1,t2,t3,t4) -> 286 | f'' q1 t1 q2 t2 q3 t3 q4 t4)), 287 | (case q2 of 288 | Error -> 289 | Error 290 | | None -> 291 | t2 292 | | Val(v1) -> 293 | (case t2 of 294 | Error -> 295 | Error 296 | | None -> 297 | Val(v1) 298 | | Val(v) -> 299 | (case v1 of 300 | True -> 301 | Val(True) 302 | | False -> 303 | (case v of 304 | True -> 305 | Val(True) 306 | | False -> 307 | None)) 308 | | Node(t1,t2,t3,t4) -> 309 | Error) 310 | | Node(q1,q2,q3,q4) -> 311 | (case t2 of 312 | Error -> 313 | Error 314 | | None -> 315 | Node(q1, q2, q3, q4) 316 | | Val(v) -> 317 | Error 318 | | Node(t1,t2,t3,t4) -> 319 | f'' q1 t1 q2 t2 q3 t3 q4 t4)), 320 | (case q3 of 321 | Error -> 322 | Error 323 | | None -> 324 | t3 325 | | Val(v1) -> 326 | (case t3 of 327 | Error -> 328 | Error 329 | | None -> 330 | Val(v1) 331 | | Val(v) -> 332 | (case v1 of 333 | True -> 334 | Val(True) 335 | | False -> 336 | (case v of 337 | True -> 338 | Val(True) 339 | | False -> 340 | None)) 341 | | Node(t1,t2,t3,t4) -> 342 | Error) 343 | | Node(q1,q2,q3,q4) -> 344 | (case t3 of 345 | Error -> 346 | Error 347 | | None -> 348 | Node(q1, q2, q3, q4) 349 | | Val(v) -> 350 | Error 351 | | Node(t1,t2,t3,t4) -> 352 | f'' q1 t1 q2 t2 q3 t3 q4 t4)), 353 | (case q4 of 354 | Error -> 355 | Error 356 | | None -> 357 | t4 358 | | Val(v1) -> 359 | (case t4 of 360 | Error -> 361 | Error 362 | | None -> 363 | Val(v1) 364 | | Val(v) -> 365 | (case v1 of 366 | True -> 367 | Val(True) 368 | | False -> 369 | (case v of 370 | True -> 371 | Val(True) 372 | | False -> 373 | None)) 374 | | Node(t1,t2,t3,t4) -> 375 | Error) 376 | | Node(q1,q2,q3,q4) -> 377 | (case t4 of 378 | Error -> 379 | Error 380 | | None -> 381 | Node(q1, q2, q3, q4) 382 | | Val(v) -> 383 | Error 384 | | Node(t1,t2,t3,t4) -> 385 | f'' q1 t1 q2 t2 q3 t3 q4 t4))); 386 | f' q1 t1 q2 t2 q3 t3 q4 t4 = 387 | Node((case q1 of 388 | Error -> 389 | Error 390 | | None -> 391 | t1 392 | | Val(v1) -> 393 | (case t1 of 394 | Error -> 395 | Error 396 | | None -> 397 | Val(v1) 398 | | Val(v) -> 399 | (case v1 of 400 | True -> 401 | Val(True) 402 | | False -> 403 | (case v of 404 | True -> 405 | Val(True) 406 | | False -> 407 | None)) 408 | | Node(t1,t2,t3,t4) -> 409 | Error) 410 | | Node(q1,q2,q3,q4) -> 411 | (case t1 of 412 | Error -> 413 | Error 414 | | None -> 415 | Node(q1, q2, q3, q4) 416 | | Val(v) -> 417 | Error 418 | | Node(t1,t2,t3,t4) -> 419 | f' q1 t1 q2 t2 q3 t3 q4 t4)), 420 | (case q2 of 421 | Error -> 422 | Error 423 | | None -> 424 | t2 425 | | Val(v1) -> 426 | (case t2 of 427 | Error -> 428 | Error 429 | | None -> 430 | Val(v1) 431 | | Val(v) -> 432 | (case v1 of 433 | True -> 434 | Val(True) 435 | | False -> 436 | (case v of 437 | True -> 438 | Val(True) 439 | | False -> 440 | None)) 441 | | Node(t1,t2,t3,t4) -> 442 | Error) 443 | | Node(q1,q2,q3,q4) -> 444 | (case t2 of 445 | Error -> 446 | Error 447 | | None -> 448 | Node(q1, q2, q3, q4) 449 | | Val(v) -> 450 | Error 451 | | Node(t1,t2,t3,t4) -> 452 | f' q1 t1 q2 t2 q3 t3 q4 t4)), 453 | (case q3 of 454 | Error -> 455 | Error 456 | | None -> 457 | t3 458 | | Val(v1) -> 459 | (case t3 of 460 | Error -> 461 | Error 462 | | None -> 463 | Val(v1) 464 | | Val(v) -> 465 | (case v1 of 466 | True -> 467 | Val(True) 468 | | False -> 469 | (case v of 470 | True -> 471 | Val(True) 472 | | False -> 473 | None)) 474 | | Node(t1,t2,t3,t4) -> 475 | Error) 476 | | Node(q1,q2,q3,q4) -> 477 | (case t3 of 478 | Error -> 479 | Error 480 | | None -> 481 | Node(q1, q2, q3, q4) 482 | | Val(v) -> 483 | Error 484 | | Node(t1,t2,t3,t4) -> 485 | f' q1 t1 q2 t2 q3 t3 q4 t4)), 486 | (case q4 of 487 | Error -> 488 | Error 489 | | None -> 490 | t4 491 | | Val(v1) -> 492 | (case t4 of 493 | Error -> 494 | Error 495 | | None -> 496 | Val(v1) 497 | | Val(v) -> 498 | (case v1 of 499 | True -> 500 | Val(True) 501 | | False -> 502 | (case v of 503 | True -> 504 | Val(True) 505 | | False -> 506 | None)) 507 | | Node(t1,t2,t3,t4) -> 508 | Error) 509 | | Node(q1,q2,q3,q4) -> 510 | (case t4 of 511 | Error -> 512 | Error 513 | | None -> 514 | Node(q1, q2, q3, q4) 515 | | Val(v) -> 516 | Error 517 | | Node(t1,t2,t3,t4) -> 518 | f' q1 t1 q2 t2 q3 t3 q4 t4))) -------------------------------------------------------------------------------- /src/Term.hs: -------------------------------------------------------------------------------- 1 | module Term where 2 | 3 | import Exception 4 | import Prelude hiding ((<>)) 5 | import Data.Char 6 | import Data.Maybe 7 | import Data.List 8 | import Data.Tuple 9 | import Data.Foldable 10 | import Control.Monad 11 | import Text.PrettyPrint.HughesPJ as P 12 | import Text.ParserCombinators.Parsec hiding (labels) 13 | import Text.ParserCombinators.Parsec.Expr 14 | import qualified Text.ParserCombinators.Parsec.Token as T 15 | import Text.ParserCombinators.Parsec.Language 16 | import System.IO 17 | import System.Directory 18 | 19 | -- terms 20 | 21 | data Term = Free String -- free variable 22 | | Bound Int -- bound variable with de Bruijn index 23 | | Lambda String Term -- lambda abstraction 24 | | Con String [Term] -- constructor application 25 | | Apply Term Term -- application 26 | | Fun String -- function call 27 | | Case Term [(String,[String],Term)] -- case expression 28 | | Let String Term Term -- let expression 29 | 30 | instance Show Term where 31 | show t = render $ prettyTerm t 32 | 33 | type Prog = (Term,[(String,([String],Term))]) 34 | 35 | showProg p = renderStyle (Style { lineLength = 100, ribbonsPerLine = 1.1, mode = PageMode }) $ prettyProg p 36 | 37 | -- equality of terms 38 | 39 | instance Eq Term where 40 | (==) (Free x) (Free x') = x==x' 41 | (==) (Bound i) (Bound i') = i==i' 42 | (==) (Lambda x t) (Lambda x' t') = t==t' 43 | (==) (Con c ts) (Con c' ts') = c==c' && all (uncurry (==)) (zip ts ts') 44 | (==) (Apply t u) (Apply t' u') = t==t' && u==u' 45 | (==) (Fun f) (Fun f') = f==f' 46 | (==) (Case t bs) (Case t' bs') | matchCase bs bs' = t==t' && all (\((_,_,t),(_,_,t')) -> t==t') (zip bs bs') 47 | (==) (Let x t u) (Let x' t' u') = t==t' && u==u' 48 | (==) t t' = False 49 | 50 | -- context surrounding redex 51 | 52 | data Context = EmptyCtx 53 | | ApplyCtx Context Term 54 | | CaseCtx Context [(String,[String],Term)] deriving Show 55 | 56 | -- place term in context 57 | 58 | place t EmptyCtx = t 59 | place t (ApplyCtx con u) = place (Apply t u) con 60 | place t (CaseCtx con bs) = place (Case t bs) con 61 | 62 | matchCase bs bs' = length bs == length bs' && all (\((c,xs,t),(c',xs',t')) -> c == c' && length xs == length xs') (zip bs bs') 63 | 64 | -- term instance 65 | 66 | inst t u = inst' t u [] 67 | 68 | inst' (Free x) t s = if x `elem` map fst s 69 | then [s | (x,t) `elem` s] 70 | else [(x,t):s] 71 | inst' (Bound i) (Bound i') s | i==i' = [s] 72 | inst' (Lambda x t) (Lambda x' t') s = inst' t t' s 73 | inst' (Con c ts) (Con c' ts') s | c==c' = foldr (\(t,t') ss -> concat [inst' t t' s | s <- ss]) [s] (zip ts ts') 74 | inst' (Apply t u) (Apply t' u') s = concat [inst' u u' s' | s' <- inst' t t' s] 75 | inst' (Fun f) (Fun f') s | f==f' = [s] 76 | inst' (Case t bs) (Case t' bs') s | matchCase bs bs' = foldr (\((c,xs,t),(c',xs',t')) ss -> concat [inst' t t' s | s <- ss]) (inst' t t' s) (zip bs bs') 77 | inst' (Let x t u) (Let x' t' u') s = concat [inst' u u' s' | s' <- inst' t t' s] 78 | inst' t t' s = [] 79 | 80 | -- homeomorphic embedding of terms 81 | 82 | embedding t u = not (null (couple t u [])) 83 | 84 | embed t u r = couple t u r ++ dive t u r 85 | 86 | couple (Free x) (Free x') r = if x `elem` map fst r || x' `elem` map snd r 87 | then [r | (x,x') `elem` r] 88 | else [(x,x'):r] 89 | couple (Bound i) (Bound i') r | i == i' = [r] 90 | couple (Lambda x t) (Lambda x' t') r = couple t t' r 91 | couple (Con c ts) (Con c' ts') r | c==c' = foldr (\(t,t') rs -> concat [embed t t' r | r <- rs]) [r] (zip ts ts') 92 | couple (Apply t u) (Apply t' u') r = concat [couple t t' r' | r' <- embed u u' r] 93 | couple (Fun f) (Fun f') r | f==f' = [r] 94 | couple (Case t bs) (Case t' bs') r | matchCase bs bs' = foldr (\((c,xs,t),(c',xs',t')) rs -> concat [embed t t' r | r <- rs]) (embed t t' r) (zip bs bs') 95 | couple (Let x t u) (Let x' t' u') r = concat [couple t t' r' | r' <- embed u u' r] 96 | couple t t' r = [] 97 | 98 | dive t (Lambda x t') r = embed t (concrete x t') r 99 | dive t (Con c ts) r = concat [embed t t' r | t' <- ts] 100 | dive t (Apply t' u) r = embed t t' r ++ embed t u r 101 | dive t (Case t' bs) r = embed t t' r ++ concatMap (\(c,xs,t') -> embed t (foldr concrete t' xs) r) bs 102 | dive t (Let x t' u) r = embed t t' r ++ embed t u r 103 | dive t t' r = [] 104 | 105 | -- generalisation of terms 106 | 107 | generalise t u fv = generalise' t u fv [] [] 108 | 109 | generalise' (Free x) (Free x') fv s1 s2 = (Free x,s1,s2) 110 | generalise' (Bound i) (Bound i') fv s1 s2 = (Bound i,s1,s2) 111 | generalise' (Lambda x t) (Lambda x' t') fv s1 s2 | embedding t t' = let (t'',s1',s2') = generalise' t t' fv s1 s2 112 | in (Lambda x t'',s1',s2') 113 | generalise' (Con c ts) (Con c' ts') fv s1 s2 | c==c' = let ((s1',s2'),ts'') = mapAccumL (\(s1,s2) (t,t') -> let (t'',s1',s2') = generalise' t t' fv s1 s2 114 | in ((s1',s2'),t'')) (s1,s2) (zip ts ts') 115 | in (Con c ts'',s1',s2') 116 | generalise' (Apply t u) (Apply t' u') fv s1 s2 | embedding t t' = let (t'',s1',s2') = generalise' t t' fv s1 s2 117 | (u'',s1'',s2'') = generalise' u u' fv s1' s2' 118 | in (Apply t'' u'',s1'',s2'') 119 | generalise' (Fun f) (Fun f') fv s1 s2 = (Fun f,s1,s2) 120 | generalise' (Case t bs) (Case t' bs') fv s1 s2 | matchCase bs bs' = let (t'',s1',s2') = generalise' t t' fv s1 s2 121 | ((s1'',s2''),bs'') = mapAccumL (\(s1,s2) ((c,xs,t),(c',xs',t')) -> let (t'',s1',s2') = generalise' t t' fv s1 s2 122 | in ((s1',s2'),(c,xs,t''))) (s1',s2') (zip bs bs') 123 | in (Case t'' bs'',s1'',s2'') 124 | generalise' (Let x t u) (Let x' t' u') fv s1 s2 = let (t'',s1',s2') = generalise' t t' fv s1 s2 125 | (u'',s1'',s2'') = generalise' u u' fv s1' s2' 126 | in (Let x t'' u'',s1'',s2'') 127 | generalise' t u fv s1 s2 = case [x | (x,t') <- s1, (x',u') <- s2, x==x' && t==t' && u==u'] of 128 | (x:_) -> (Free x,s1,s2) 129 | [] -> let x = renameVar (fv++map fst s1) "x" 130 | in (Free x,(x,t):s1,(x,u):s2) 131 | 132 | makeLet s t = foldl (\u (x,t) -> Let x t (abstract u x)) t s 133 | 134 | -- evaluate a program 135 | 136 | eval (Free x) k d r a = error ("Unbound identifier: "++x) 137 | eval (Lambda x t) EmptyCtx d r a = (Lambda x t,r,a) 138 | eval (Lambda x t) (ApplyCtx k u) d r a = eval (subst u t) k d (r+1) a 139 | eval (Lambda x t) (CaseCtx k bs) d r a = error ("Unapplied function in case selector: " ++ show (Lambda x t)) 140 | eval (Con c ts) EmptyCtx d r a = let ((r',a'),ts') = mapAccumL (\(r,a) t -> let (t',r',a') = eval t EmptyCtx d r a 141 | in ((r',a'),t')) (r,a) ts 142 | in (Con c ts',r'+1,a') 143 | eval (Con c ts) (ApplyCtx k u) d r a = error ("Constructor application is not saturated: "++show (place (Con c ts) (ApplyCtx k u))) 144 | eval (Con c ts) (CaseCtx k bs) d r a = case find (\(c',xs,t) -> c==c' && length xs == length ts) bs of 145 | Nothing -> error ("No matching pattern in case for term:\n\n"++show (Case (Con c ts) bs)) 146 | Just (c',xs,t) -> eval (foldr subst t ts) k d (r+length ts) (a+1) 147 | eval (Apply t u) k d r a = eval t (ApplyCtx k u) d r a 148 | eval (Fun f) k d r a = case lookup f d of 149 | Nothing -> error ("Undefined function: "++f) 150 | Just (xs,t) -> eval (foldr Lambda t xs) k d (r+1) a 151 | eval (Case t bs) k d r a = eval t (CaseCtx k bs) d r a 152 | eval (Let x t u) k d r a = eval (subst t u) k d (r+1) a 153 | 154 | -- free variables in a process tree 155 | 156 | free t = nub (free' t) 157 | 158 | free' (Free x) = [x] 159 | free' (Bound i) = [] 160 | free' (Lambda x t) = free' t 161 | free' (Con c ts) = concatMap free' ts 162 | free' (Apply t u) = free' t ++ free' u 163 | free' (Fun f) = [] 164 | free' (Case t bs) = free' t ++ concatMap (\(c,xs,t) -> free' t) bs 165 | free' (Let x t u) = free' t ++ free' u 166 | 167 | -- functions in a program 168 | 169 | funs (t,d) = funs' d t [] 170 | 171 | funs' d (Free x) fs = fs 172 | funs' d (Bound i) fs = fs 173 | funs' d (Lambda x t) fs = funs' d t fs 174 | funs' d (Con c ts) fs = foldr (funs' d) fs ts 175 | funs' d (Apply t u) fs = funs' d t (funs' d u fs) 176 | funs' d (Fun f) fs = if f `elem` fs 177 | then fs 178 | else case lookup f d of 179 | Nothing -> f:fs 180 | Just (xs,t) -> funs' d t (f:fs) 181 | funs' d (Case t bs) fs = foldr (\(_,_,t) fs -> funs' d t fs) (funs' d t fs) bs 182 | funs' d (Let x t u) fs = funs' d t (funs' d u fs) 183 | 184 | -- shift global de Bruijn indices by i, where current depth is d 185 | 186 | shift = shift' 0 187 | 188 | shift' d 0 u = u 189 | shift' d i (Free x) = Free x 190 | shift' d i (Bound i') = if i' >= d then Bound (i'+i) else Bound i' 191 | shift' d i (Lambda x t) = Lambda x (shift' (d+1) i t) 192 | shift' d i (Con c ts) = Con c (map (shift' d i) ts) 193 | shift' d i (Apply t u) = Apply (shift' d i t) (shift' d i u) 194 | shift' d i (Fun f) = Fun f 195 | shift' d i (Case t bs) = Case (shift' d i t) (map (\(c,xs,t) -> (c,xs,shift' (d+length xs) i t)) bs) 196 | shift' d i (Let x t u) = Let x (shift' d i t) (shift' (d+1) i u) 197 | 198 | -- substitute term t for variable with de Bruijn index i 199 | 200 | subst = subst' 0 201 | 202 | subst' i t (Free x) = Free x 203 | subst' i t (Bound i') 204 | | i' (c,xs,subst' (i+length xs) t u)) bs) 212 | subst' i t (Let x t' u) = Let x (subst' i t t') (subst' (i+1) t u) 213 | 214 | -- rename a term t using renaming r 215 | 216 | rename r (Free x) = case lookup x r of 217 | Just x' -> Free x' 218 | Nothing -> Free x 219 | rename r (Bound i) = Bound i 220 | rename r (Lambda x t) = Lambda x (rename r t) 221 | rename r (Con c ts) = Con c (map (rename r) ts) 222 | rename r (Apply t u) = Apply (rename r t) (rename r u) 223 | rename r (Fun f) = Fun f 224 | rename r (Case t bs) = Case (rename r t) (map (\(c,xs,t) -> (c,xs,rename r t)) bs) 225 | rename r (Let x t u) = Let x (rename r t) (rename r u) 226 | 227 | -- instantiate a term t using substitution s 228 | 229 | instantiate = instantiate' 0 230 | 231 | instantiate' d s (Free x) = case lookup x s of 232 | Just t -> shift d t 233 | Nothing -> Free x 234 | instantiate' d s (Bound i) = Bound i 235 | instantiate' d s (Lambda x t) = Lambda x (instantiate' (d+1) s t) 236 | instantiate' d s (Con c ts) = Con c (map (instantiate' d s) ts) 237 | instantiate' d s (Apply t u) = Apply (instantiate' d s t) (instantiate' d s u) 238 | instantiate' d s (Fun f) = Fun f 239 | instantiate' d s (Case t bs) = Case (instantiate' d s t) (map (\(c,xs,t) -> (c,xs,instantiate' (d+length xs) s t)) bs) 240 | instantiate' d s (Let x t u) = Let x (instantiate' d s t) (instantiate' (d+1) s u) 241 | 242 | -- replace variable x with de Bruijn index 243 | 244 | abstract = abstract' 0 245 | 246 | abstract' i (Free x') x = if x==x' then Bound i else Free x' 247 | abstract' i (Bound i') x = if i'>=i then Bound (i'+1) else Bound i' 248 | abstract' i (Lambda x' t) x = Lambda x' (abstract' (i+1) t x) 249 | abstract' i (Con c ts) x = Con c (map (\t -> abstract' i t x) ts) 250 | abstract' i (Apply t u) x = Apply (abstract' i t x) (abstract' i u x) 251 | abstract' i (Fun f) x = Fun f 252 | abstract' i (Case t bs) x = Case (abstract' i t x) (map (\(c,xs,t) -> (c,xs,abstract' (i+length xs) t x)) bs) 253 | abstract' i (Let x' t u) x = Let x' (abstract' i t x) (abstract' (i+1) u x) 254 | 255 | -- replace de Bruijn index 0 with variable x 256 | 257 | concrete = concrete' 0 258 | 259 | concrete' i x (Free x') = Free x' 260 | concrete' i x (Bound i') 261 | | i' (c,xs,concrete' (i+length xs) x t)) bs) 269 | concrete' i x (Let x' t u) = Let x' (concrete' i x t) (concrete' (i+1) x u) 270 | 271 | -- rename variable x so it does not clash with any of fv 272 | 273 | renameVar fv x = if x `elem` fv 274 | then renameVar fv (x++"'") 275 | else x 276 | 277 | renameVars = foldr (\x fv -> let x' = renameVar fv x in x':fv) 278 | 279 | -- unfold function in term redex 280 | 281 | unfold (Apply t u,d) = let t' = unfold (t,d) 282 | in Apply t' u 283 | unfold (Case t bs,d) = let t' = unfold (t,d) 284 | in Case t' bs 285 | unfold (Fun f,d) = case lookup f d of 286 | Nothing -> error ("Undefined function: "++f) 287 | Just (xs,t) -> foldr Lambda t xs 288 | unfold (t,d) = t 289 | 290 | -- pretty printing 291 | 292 | stripLambda (Lambda x t) = let x' = renameVar (free t) x 293 | (xs,u) = stripLambda $ concrete x' t 294 | in (x':xs,u) 295 | stripLambda t = ([],t) 296 | 297 | blank = P.space 298 | 299 | prettyCon t@(Con c ts) 300 | | isNat t = int $ con2nat t 301 | | isList t = brackets $ hcat $ punctuate comma $ map prettyTerm $ con2list t 302 | | null ts = text c 303 | | otherwise = text c <> parens (hcat $ punctuate comma $ map prettyTerm ts) 304 | 305 | prettyTerm (Free x) = text x 306 | prettyTerm (Bound i) = text "#" <> int i 307 | prettyTerm t@(Lambda _ _) = let (xs,t') = stripLambda t 308 | in text "\\" <> hsep (map text xs) <> text "->" <> prettyTerm t' 309 | prettyTerm t@(Con c ts) = prettyCon t 310 | prettyTerm t@(Apply _ _) = prettyApp t where 311 | prettyApp (Apply t u) = prettyApp t <+> prettyAtom u 312 | prettyApp t = prettyAtom t 313 | prettyTerm (Fun f) = text f 314 | prettyTerm (Case t (b:bs)) = 315 | hang (text "case" <+> prettyAtom t <+> text "of") 1 (blank <+> prettyBranch b $$ vcat (map ((text "|" <+>).prettyBranch) bs)) where 316 | prettyBranch (c,[],t) = text c <+> text "->" <+> prettyAtom t 317 | prettyBranch (c,xs,t) = let fv = renameVars (free t) xs 318 | xs' = take (length xs) fv 319 | t' = foldr concrete t xs' 320 | in text c <> parens(hcat $ punctuate comma $ map text xs') <+> text "->" <+> prettyAtom t' $$ empty 321 | prettyTerm (Let x t u) = let x' = renameVar (free u) x 322 | in (text "let" <+> text x' <+> text "=" <+> prettyTerm t) $$ (text "in" <+> prettyTerm (concrete x' u)) 323 | 324 | prettyAtom (Free x) = text x 325 | prettyAtom t@(Con c ts) = prettyCon t 326 | prettyAtom (Fun f) = text f 327 | prettyAtom t = parens $ prettyTerm t 328 | 329 | prettyProg (t,d) = let d' = [f | f <- d, fst f `elem` funs (t,d)] 330 | in prettyEnv (("main",([],t)):d') 331 | 332 | prettyEnv xs = vcat (punctuate semi $ map (\(f,(xs,t)) -> text f <+> hsep (map text xs) <+> equals <+> prettyTerm (foldr concrete t xs)) xs) 333 | 334 | isList (Con "Nil" []) = True 335 | isList (Con "Cons" [h,t]) = isList t 336 | isList _ = False 337 | 338 | list2con [] = Con "Nil" [] 339 | list2con (h:t) = Con "Cons" [h,list2con t] 340 | 341 | con2list (Con "Nil" []) = [] 342 | con2list (Con "Cons" [h,t]) = h:con2list t 343 | 344 | range2con m n = if m > n 345 | then Con "Nil" [] 346 | else Con "Cons" [nat2con m,range2con (m+1) n] 347 | 348 | isNat (Con "Zero" []) = True 349 | isNat (Con "Succ" [n]) = isNat n 350 | isNat _ = False 351 | 352 | nat2con 0 = Con "Zero" [] 353 | nat2con n = Con "Succ" [nat2con $ n-1] 354 | 355 | con2nat (Con "Zero" []) = 0 356 | con2nat (Con "Succ" [n]) = 1+con2nat n 357 | 358 | -- lexing and parsing 359 | 360 | potDef = emptyDef 361 | { commentStart = "/*" 362 | , commentEnd = "*/" 363 | , commentLine = "--" 364 | , nestedComments = True 365 | , identStart = lower 366 | , identLetter = letter <|> digit <|> oneOf "_'" 367 | , reservedNames = ["import", "case","of","let","in","letrec","ALL","EX","ANY"] 368 | , reservedOpNames = ["~","/\\","\\/","<=>","=>"] 369 | , caseSensitive = True 370 | } 371 | 372 | lexer = T.makeTokenParser potDef 373 | 374 | symbol = T.symbol lexer 375 | bracks = T.parens lexer 376 | semic = T.semi lexer 377 | comm = T.comma lexer 378 | identifier = T.identifier lexer 379 | reserved = T.reserved lexer 380 | reservedOp = T.reservedOp lexer 381 | natural = T.natural lexer 382 | 383 | con = do 384 | c <- upper 385 | cs <- many letter 386 | spaces 387 | return (c:cs) 388 | 389 | makeProg ds = let fs = map fst ds 390 | ds' = map (\(f,(xs,t)) -> (f,(xs,foldl abstract (makeFun fs t) xs))) ds 391 | in case lookup "main" ds' of 392 | Nothing -> error "No main function" 393 | Just (xs,t) -> (t,delete ("main",(xs,t)) ds') 394 | 395 | makeFun fs (Free x) = if x `elem` fs then Fun x else Free x 396 | makeFun fs (Bound i) = Bound i 397 | makeFun fs (Lambda x t) = Lambda x (makeFun fs t) 398 | makeFun fs (Con c ts) = Con c (map (makeFun fs) ts) 399 | makeFun fs (Apply t u) = Apply (makeFun fs t) (makeFun fs u) 400 | makeFun fs (Fun f) = Fun f 401 | makeFun fs (Case t bs) = Case (makeFun fs t) (map (\(c,xs,t) -> (c,xs,makeFun fs t)) bs) 402 | makeFun fs (Let x t u) = Let x (makeFun fs t) (makeFun fs u) 403 | 404 | modul = do 405 | fs <- many imp 406 | ds <- sepBy1 fundef semic 407 | eof 408 | return (fs,ds) 409 | 410 | imp = do 411 | reserved "import" 412 | con 413 | 414 | fundef = do 415 | f <- identifier 416 | xs <- many identifier 417 | symbol "=" 418 | e <- term 419 | return (f,(xs,e)) 420 | 421 | term = do 422 | a <- atom 423 | as <- many atom 424 | return (foldl Apply a as) 425 | <|> do 426 | symbol "\\" 427 | xs <- many1 identifier 428 | symbol "->" 429 | t <- term 430 | return (foldr (\x t->Lambda x (abstract t x)) t xs) 431 | <|> do 432 | reserved "case" 433 | t <- term 434 | reserved "of" 435 | bs <- sepBy1 branch (symbol "|") 436 | return (Case t bs) 437 | <|> do 438 | reserved "let" 439 | x <- identifier 440 | symbol "=" 441 | t <- term 442 | reserved "in" 443 | u <- term 444 | return (Let x t (abstract u x)) 445 | 446 | atom = do Free <$> identifier 447 | <|> do 448 | c <- con 449 | ts <- option [] (bracks (sepBy1 term comm)) 450 | return (Con c ts) 451 | <|> do 452 | m <- natural 453 | option (nat2con m) (do symbol ".." 454 | range2con m <$> natural) 455 | <|> do 456 | symbol "[" 457 | ts <- sepBy term comm 458 | symbol "]" 459 | return (list2con ts) 460 | <|> bracks term 461 | 462 | branch = do 463 | c <- con 464 | xs <- option [] (bracks (sepBy1 identifier comm)) 465 | symbol "->" 466 | t <- term 467 | return (c,xs,foldl abstract t xs) 468 | 469 | parseTerm = parse term "Parse error" 470 | 471 | parseModule = parse modul "Parse error" --------------------------------------------------------------------------------