From 2bd388c871d2ee3bc8a55519a1f9993f9120f09f Mon Sep 17 00:00:00 2001 From: James Eversole Date: Sat, 25 Jan 2025 09:18:13 -0600 Subject: [PATCH] Eval optimization! Tests for demos --- demos/equality.tri | 18 +++++------ demos/levelOrderTraversal.tri | 20 ++++++------ demos/size.tri | 2 ++ demos/toSource.tri | 2 +- src/Eval.hs | 13 ++++---- test/Spec.hs | 60 ++++++++++++++++++++++++----------- 6 files changed, 70 insertions(+), 45 deletions(-) diff --git a/demos/equality.tri b/demos/equality.tri index 9e14672..9c8d5c8 100644 --- a/demos/equality.tri +++ b/demos/equality.tri @@ -1,19 +1,19 @@ -- We represent `false` with a Leaf and `true` with a Stem Leaf -false = t -true = t t +demo_false = t +demo_true = t t -- Tree Calculus representation of the Boolean `not` function not_TC? = t (t (t t) (t t t)) (t t (t t t)) -- /demos/toSource.tri contains an explanation of `triage` -triage = (\a b c : t (t a b) c) -matchBool = (\ot of : triage +demo_triage = (\a b c : t (t a b) c) +demo_matchBool = (\ot of : demo_triage of (\_ : ot) (\_ _ : ot) ) -- Lambda representation of the Boolean `not` function -not_Lambda? = matchBool false true +not_Lambda? = demo_matchBool demo_false demo_true -- Since tricu eliminates Lambda terms to SKI combinators, the tree form of many -- functions defined via Lambda terms are larger than the most efficient TC @@ -25,11 +25,11 @@ not_Lambda? = matchBool false true lambdaEqualsTC = equal? not_TC? not_Lambda? -- Here are some checks to verify their extensional behavior is the same: -true_TC? = not_TC? false -false_TC? = not_TC? true +true_TC? = not_TC? demo_false +false_TC? = not_TC? demo_true -true_Lambda? = not_Lambda? false -false_Lambda? = not_Lambda? true +true_Lambda? = not_Lambda? demo_false +false_Lambda? = not_Lambda? demo_true bothTrueEqual? = equal? true_TC? true_Lambda? bothFalseEqual? = equal? false_TC? false_Lambda? diff --git a/demos/levelOrderTraversal.tri b/demos/levelOrderTraversal.tri index 63a11e8..0ad3b4f 100644 --- a/demos/levelOrderTraversal.tri +++ b/demos/levelOrderTraversal.tri @@ -4,7 +4,7 @@ -- NOTICE: This demo relies on tricu base library functions -- -- We model labelled binary trees as sublists where values act as labels. We --- require explicit notation of empty nodes. Empty nodes can be represented +-- require explicit not?ation of empty nodes. Empty nodes can be represented -- with an empty list, `[]`, which is equivalent to a single node `t`. -- -- Example tree inputs: @@ -19,33 +19,33 @@ label = (\node : head node) -left = (\node : if (emptyList node) +left = (\node : if (emptyList? node) [] - (if (emptyList (tail node)) + (if (emptyList? (tail node)) [] (head (tail node)))) -right = (\node : if (emptyList node) +right = (\node : if (emptyList? node) [] - (if (emptyList (tail node)) + (if (emptyList? (tail node)) [] - (if (emptyList (tail (tail node))) + (if (emptyList? (tail (tail node))) [] (head (tail (tail node)))))) -processLevel = y (\self queue : if (emptyList queue) +processLevel = y (\self queue : if (emptyList? queue) [] (pair (map label queue) (self (filter - (\node : not (emptyList node)) + (\node : not? (emptyList? node)) (lconcat (map left queue) (map right queue)))))) levelOrderTraversal_ = (\a : processLevel (t a t)) -toLineString = y (\self levels : if (emptyList levels) +toLineString = y (\self levels : if (emptyList? levels) "" (lconcat (lconcat (map (\x : lconcat x " ") (head levels)) "") - (if (emptyList (tail levels)) "" (lconcat (t (t 10 t) t) (self (tail levels)))))) + (if (emptyList? (tail levels)) "" (lconcat (t (t 10 t) t) (self (tail levels)))))) levelOrderToString = (\s : toLineString (levelOrderTraversal_ s)) diff --git a/demos/size.tri b/demos/size.tri index d21bfef..55743c9 100644 --- a/demos/size.tri +++ b/demos/size.tri @@ -17,3 +17,5 @@ size = (\x : self (\x y : compose (self x) (self y)) x)) x 0)) + +size size diff --git a/demos/toSource.tri b/demos/toSource.tri index b9574cd..e686cc3 100644 --- a/demos/toSource.tri +++ b/demos/toSource.tri @@ -8,7 +8,7 @@ -- the Tree Calculus term, `triage` enables branching logic based on the term's -- shape, making it possible to perform structure-specific operations such as -- reconstructing the terms' source code representation. -triage = (\leaf stem fork : t (t leaf stem) fork) +-- triage = (\leaf stem fork : t (t leaf stem) fork) -- Base case of a single Leaf sourceLeaf = t (head "t") diff --git a/src/Eval.hs b/src/Eval.hs index eb2b718..dcfda2a 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -24,7 +24,7 @@ evalSingle env term | SVar name <- term = case Map.lookup name env of Just v -> Map.insert "__result" v env - Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined" + Nothing -> errorWithoutStackTrace $ "Variable `" ++ name ++ "` not defined" | otherwise = Map.insert "__result" (evalAST env term) env @@ -59,11 +59,13 @@ evalAST env term elimLambda :: TricuAST -> TricuAST elimLambda = go where + go (SLambda [v] (SApp f (SVar x))) + | v == x && not (isFree v f) = elimLambda f go (SLambda (v:vs) body) - | null vs = toSKI v (elimLambda body) - | otherwise = elimLambda (SLambda [v] (SLambda vs body)) - go (SApp f g) = SApp (elimLambda f) (elimLambda g) - go x = x + | null vs = toSKI v (elimLambda body) + | otherwise = elimLambda (SLambda [v] (SLambda vs body)) + go (SApp f g) = SApp (elimLambda f) (elimLambda g) + go x = x toSKI x (SVar y) | x == y = _I @@ -73,7 +75,6 @@ elimLambda = go | otherwise = SApp (SApp _S (toSKI x n)) (toSKI x u) toSKI x t | not (isFree x t) = SApp _K t - | otherwise = SApp (SApp _S (toSKI x t)) TLeaf _S = parseSingle "t (t (t t t)) t" _K = parseSingle "t t" diff --git a/test/Spec.hs b/test/Spec.hs index f9bc5fe..71ec7f5 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -25,16 +25,17 @@ runTricu s = show $ result (evalTricu Map.empty $ parseTricu s) tests :: TestTree tests = testGroup "Tricu Tests" - [ lexerTests - , parserTests - , evaluationTests - , lambdaEvalTests - , libraryTests - , fileEvaluationTests + [ lexer + , parser + , simpleEvaluation + , lambdas + , baseLibrary + , fileEval + , demos ] -lexerTests :: TestTree -lexerTests = testGroup "Lexer Tests" +lexer :: TestTree +lexer = testGroup "Lexer Tests" [ testCase "Lex simple identifiers" $ do let input = "x a b = a" expect = Right [LIdentifier "x", LIdentifier "a", LIdentifier "b", LAssign, LIdentifier "a"] @@ -74,8 +75,8 @@ lexerTests = testGroup "Lexer Tests" Right _ -> assertFailure "Expected failure when trying to assign the value of __result" ] -parserTests :: TestTree -parserTests = testGroup "Parser Tests" +parser :: TestTree +parser = testGroup "Parser Tests" [ testCase "Error when assigning a value to T" $ do let tokens = lexTricu "t = x" case parseSingleExpr tokens of @@ -175,8 +176,8 @@ parserTests = testGroup "Parser Tests" parseTricu input @?= expect ] -evaluationTests :: TestTree -evaluationTests = testGroup "Evaluation Tests" +simpleEvaluation :: TestTree +simpleEvaluation = testGroup "Evaluation Tests" [ testCase "Evaluate single Leaf" $ do let input = "t" let ast = parseSingle input @@ -244,7 +245,7 @@ evaluationTests = testGroup "Evaluation Tests" (result env) @?= (Stem (Stem Leaf)) - , testCase "Evaluate variable shadowing" $ do + , testCase "Immutable definitions" $ do let input = "x = t t\nx = t\nx" env = evalTricu Map.empty (parseTricu input) result <- try (evaluate (runTricu input)) :: IO (Either SomeException String) @@ -260,8 +261,8 @@ evaluationTests = testGroup "Evaluation Tests" result env @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf ] -lambdaEvalTests :: TestTree -lambdaEvalTests = testGroup "Lambda Evaluation Tests" +lambdas :: TestTree +lambdas = testGroup "Lambda Evaluation Tests" [ testCase "Lambda Identity Function" $ do let input = "id = (\\x : x)\nid t" runTricu input @?= "Leaf" @@ -340,8 +341,8 @@ lambdaEvalTests = testGroup "Lambda Evaluation Tests" runTricu input @?= "Fork Leaf (Fork (Stem Leaf) Leaf)" ] -libraryTests :: TestTree -libraryTests = testGroup "Library Tests" +baseLibrary :: TestTree +baseLibrary = testGroup "Library Tests" [ testCase "K combinator 1" $ do library <- evaluateFile "./lib/base.tri" let input = "k (t) (t t)" @@ -476,8 +477,8 @@ libraryTests = testGroup "Library Tests" result env @?= Stem Leaf ] -fileEvaluationTests :: TestTree -fileEvaluationTests = testGroup "Evaluation tests" +fileEval :: TestTree +fileEval = testGroup "File evaluation tests" [ testCase "Forks" $ do res <- liftIO $ evaluateFileResult "./test/fork.tri" res @?= Fork Leaf Leaf @@ -495,3 +496,24 @@ fileEvaluationTests = testGroup "Evaluation tests" res <- liftIO $ evaluateFileWithContext library "./test/string.tri" decodeResult (result res) @?= "\"String test!\"" ] + + +demos :: TestTree +demos = testGroup "Test provided demo functionality" + [ testCase "Structural equality demo" $ do + library <- liftIO $ evaluateFile "./lib/base.tri" + res <- liftIO $ evaluateFileWithContext library "./demos/equality.tri" + decodeResult (result res) @?= "t t" + , testCase "Convert values back to source code demo" $ do + library <- liftIO $ evaluateFile "./lib/base.tri" + res <- liftIO $ evaluateFileWithContext library "./demos/toSource.tri" + decodeResult (result res) @?= "\"(t (t (t t) (t t t)) (t t (t t t)))\"" + , testCase "Determining the size of functions" $ do + library <- liftIO $ evaluateFile "./lib/base.tri" + res <- liftIO $ evaluateFileWithContext library "./demos/size.tri" + decodeResult (result res) @?= "2071" + , testCase "Level Order Traversal demo" $ do + library <- liftIO $ evaluateFile "./lib/base.tri" + res <- liftIO $ evaluateFileWithContext library "./demos/levelOrderTraversal.tri" + decodeResult (result res) @?= "\"\n1 \n2 3 \n4 5 6 7 \n8 11 10 9 12 \"" + ]