Initial commit

1 files changed, 86 insertions, 0 deletions

diff --git a/pf.icl b/pf.icl
new file mode 100644
index 0000000..c2e0ccb
--- /dev/null
+++ b/pf.icl
@@ -0,0 +1,86 @@
+module pf
+
+import StdEnv
+import Data.List
+
+:: Expr
+	= Lambda Ident Expr
+	| Ident Ident
+	| Literal Literal
+	| App Expr Expr
+
+:: Literal
+	= LitInt Int
+	| LitBool Bool
+
+:: Ident :== String
+
+hasIdent :: Ident Expr -> Bool
+hasIdent id (Ident n) = id == n
+hasIdent id (Literal _) = False
+hasIdent id (Lambda n e) = id <> n && hasIdent id e
+hasIdent id (App f x) = hasIdent id f || hasIdent id x
+
+print :: Expr -> String
+print e = foldl (+++) "" (pr False e [])
+where
+	pr :: Bool Expr [String] -> [String]
+	pr p l=:(Lambda _ _) st =
+		[if p "(\\" "\\":intersperse " " vars] ++
+		[" -> ":pr False rhs [if p ")" "":st]]
+	where
+		(vars,rhs) = getLambdas l
+
+		getLambdas :: Expr -> ([Ident], Expr)
+		getLambdas (Lambda x rhs) = let (is,e) = getLambdas rhs in ([x:is],e)
+		getLambdas e = ([], e)
+
+	pr _ (Ident id)   st = [id:st]
+	pr _ (Literal l)  st = pLit l st
+	pr p (App f x)    st = [if p "(" "":pr False f [" ":pr True x [if p ")" "":st]]]
+
+	pLit :: Literal [String] -> [String]
+	pLit (LitInt i)  st = [toString i:st]
+	pLit (LitBool b) st = [toString b:st]
+
+optim :: Expr -> Expr
+optim (Lambda id e)
+| hasIdent id e = case optim e of
+	Ident id` -> if (id == id`) (Ident "id") (App (Ident "const") e)
+	App f x -> case moveOutside id (App f x) of
+		a=:(App f (Ident id`)) -> if (id == id`) f (App (Ident "const") a)
+		a                      -> App (Ident "const") a
+	e -> Lambda id e
+| otherwise = App (Ident "const") (optim e)
+optim e = e
+
+moveOutside :: Ident Expr -> Expr
+moveOutside _ (Ident id) = Ident id
+moveOutside _ (Literal l) = Literal l
+moveOutside id (App f x)
+| hasIdent id f = case moveOutside id f of
+	Ident id -> App (App (App (Ident "flip") (Ident "id")) x) (Ident id)
+	App g (Ident id) -> App (App (App (Ident "flip") g) x) (Ident id)
+| hasIdent id x = case moveOutside id x of
+	e=:(Ident id) -> App f e
+	App g e=:(Ident id) -> App (App (App (Ident "(o)") f) g) e
+moveOutside _ (Lambda x e) = Lambda x e // TODO
+
+Start = map do
+	[ Lambda "x" (Literal (LitInt 5))
+	, Lambda "x" (Ident "x")
+	, Lambda "x" (Ident "y")
+	, Lambda "x" (Lambda "y" (Ident "x"))
+	, Lambda "x" (Lambda "y" (Ident "y"))
+	, Lambda "x" (Lambda "y" (Literal (LitInt 37)))
+	, Lambda "x" (Lambda "y" (Lambda "z" (Ident "x")))
+	, Lambda "x" (Lambda "y" (Lambda "z" (Ident "y")))
+	, Lambda "x" (Lambda "y" (Lambda "z" (Ident "z")))
+	, Lambda "x" (Lambda "y" (Lambda "z" (Literal (LitInt 37))))
+	, Lambda "x" (Lambda "y" (App (Ident "x") (Ident "y")))
+	, Lambda "x" (Lambda "y" (App (Ident "y") (Ident "x")))
+	, Lambda "x" (Lambda "y" (App (Ident "y") (Literal (LitInt 10))))
+	, Lambda "f" (Lambda "a" (Lambda "b" (Lambda "c" (Lambda "d" (App (App (App (App (Ident "f") (Ident "b")) (Ident "c")) (Ident "d")) (Ident "a"))))))
+	]
+where
+	do e = (print e, " ==> ", print (optim e), "\n")