3 Commits

Author SHA1 Message Date
a64b3f0829 Definition dependency analysis
All checks were successful
Test, Build, and Release / test (push) Successful in 1m34s
Test, Build, and Release / build (push) Successful in 1m21s
tricu now allows defining terms in any order and will resolve
dependencies to ensure that they're evaluated in the right order.
Undefined terms are detected and throw errors during dependency
ordering.
For now we can't define top-level mutually recursive terms.
2025-01-26 14:50:39 -06:00
e2621bc09d Allow lambda expressions without explicit paren
All checks were successful
Test, Build, and Release / test (push) Successful in 1m41s
Test, Build, and Release / build (push) Successful in 1m19s
2025-01-26 08:52:28 -06:00
ea128929da Add optimization cases for triage and composition 2025-01-25 15:12:28 -06:00
13 changed files with 256 additions and 180 deletions

View File

@ -2,7 +2,7 @@
## Introduction
tricu (pronounced "tree-shoe") is a purely functional interpreted language implemented in Haskell. It is fundamentally based on the application of [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf) terms, but minimal syntax sugar is included to provide a useful programming tool.
tricu (pronounced "tree-shoe") is a purely functional interpreted language implemented in Haskell. It is fundamentally based on the application of [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf) terms, but minimal syntax sugar is included to provide a useful programming tool. tricu is under active development and you can expect breaking changes with nearly every commit.
tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)`.

View File

@ -6,7 +6,7 @@ demo_true = t t
not_TC? = t (t (t t) (t t t)) (t t (t t t))
-- /demos/toSource.tri contains an explanation of `triage`
demo_triage = (\a b c : t (t a b) c)
demo_triage = \a b c : t (t a b) c
demo_matchBool = (\ot of : demo_triage
of
(\_ : ot)

View File

@ -1,11 +1,9 @@
-- Level Order Traversal of a labelled binary tree
-- Objective: Print each "level" of the tree on a separate line
--
-- NOTICE: This demo relies on tricu base library functions
--
-- We model labelled binary trees as sublists where values act as labels. We
-- require explicit not?ation of empty nodes. Empty nodes can be represented
-- with an empty list, `[]`, which is equivalent to a single node `t`.
-- We model labelled binary trees as nested lists where values act as labels. We
-- require explicit notation of empty nodes. Empty nodes can be represented
-- with an empty list, `[]`, which evaluates to a single node `t`.
--
-- Example tree inputs:
-- [("1") [("2") [("4") t t] t] [("3") [("5") t t] [("6") t t]]]]
@ -15,11 +13,10 @@
-- 2 3
-- / / \
-- 4 5 6
--
label = (\node : head node)
label = \node : head node
left = (\node : if (emptyList? node)
left = (\node : if (emptyList? node)
[]
(if (emptyList? (tail node))
[]
@ -39,7 +36,7 @@ processLevel = y (\self queue : if (emptyList? queue)
(\node : not? (emptyList? node))
(lconcat (map left queue) (map right queue))))))
levelOrderTraversal_ = (\a : processLevel (t a t))
levelOrderTraversal_ = \a : processLevel (t a t)
toLineString = y (\self levels : if (emptyList? levels)
""
@ -47,11 +44,11 @@ toLineString = y (\self levels : if (emptyList? levels)
(lconcat (map (\x : lconcat x " ") (head levels)) "")
(if (emptyList? (tail levels)) "" (lconcat (t (t 10 t) t) (self (tail levels))))))
levelOrderToString = (\s : toLineString (levelOrderTraversal_ s))
levelOrderToString = \s : toLineString (levelOrderTraversal_ s)
flatten = foldl (\acc x : lconcat acc x) ""
levelOrderTraversal = (\s : lconcat (t 10 t) (flatten (levelOrderToString s)))
levelOrderTraversal = \s : lconcat (t 10 t) (flatten (levelOrderToString s))
exampleOne = levelOrderTraversal [("1")
[("2") [("4") t t] t]

View File

@ -1,21 +1,21 @@
compose = (\f g x : f (g x))
compose = \f g x : f (g x)
succ = y (\self :
triage
1
t
(triage
(t (t t))
(\_ tail : t t (self tail))
succ = y (\self :
triage
1
t
(triage
(t (t t))
(\_ tail : t t (self tail))
t))
size = (\x :
(y (\self x :
compose succ
(triage
(\x : x)
self
(\x y : compose (self x) (self y))
size = (\x :
(y (\self x :
compose succ
(triage
(\x : x)
self
(\x y : compose (self x) (self y))
x)) x 0))
size size

View File

@ -40,7 +40,7 @@ toSource_ = y (\self arg :
arg) -- The term to be inspected
-- toSource takes a single TC term and returns a String
toSource = (\v : toSource_ v "")
toSource = \v : toSource_ v ""
exampleOne = toSource true -- OUT: "(t t)"
exampleTwo = toSource not? -- OUT: "(t (t (t t) (t t t)) (t t (t t t)))"

View File

@ -7,37 +7,26 @@ s = t (t (k t)) t
m = s i i
b = s (k s) k
c = s (s (k s) (s (k k) s)) (k k)
iC = (\a b c : s a (k c) b)
iD = b (b iC) iC
iE = b (b iD) iC
yi = (\i : b m (c b (i m)))
y = yi iC
yC = yi iD
yD = yi iE
id = (\a : a)
id = \a : a
pair = t
if = (\cond then else : t (t else (t t then)) t cond)
if = \cond then else : t (t else (t t then)) t cond
triage = (\leaf stem fork : t (t leaf stem) fork)
y = ((\mut wait fun : wait mut (\x : fun (wait mut x)))
(\x : x x)
(\a0 a1 a2 : t (t a0) (t t a2) a1))
triage = \leaf stem fork : t (t leaf stem) fork
test = triage "Leaf" (\_ : "Stem") (\_ _ : "Fork")
matchBool = (\ot of : triage
of
(\_ : ot)
matchBool = (\ot of : triage
of
(\_ : ot)
(\_ _ : ot)
)
matchList = (\oe oc : triage
oe
_
oc
)
matchList = \a b : triage a _ b
matchPair = (\op : triage
_
_
op
)
matchPair = \a : triage _ _ a
not? = matchBool false true
and? = matchBool id (\_ : false)
@ -46,51 +35,49 @@ emptyList? = matchList true (\_ _ : false)
head = matchList t (\head _ : head)
tail = matchList t (\_ tail : tail)
lconcat = y (\self : matchList
(\k : k)
lconcat = y (\self : matchList
(\k : k)
(\h r k : pair h (self r k)))
lAnd = (triage
(\_ : false)
(\_ x : x)
(\_ _ x : x)
)
lAnd = (triage
(\_ : false)
(\_ x : x)
(\_ _ x : x))
lOr = (triage
(\x : x)
(\_ _ : true)
(\_ _ _ : true)
)
lOr = (triage
(\x : x)
(\_ _ : true)
(\_ _ _ : true))
map_ = y (\self :
matchList
(\_ : t)
map_ = y (\self :
matchList
(\_ : t)
(\head tail f : pair (f head) (self tail f)))
map = (\f l : map_ l f)
map = \f l : map_ l f
equal? = y (\self : triage
(triage
true
(\_ : false)
(\_ _ : false))
(\ax :
triage
false
(self ax)
(\_ _ : false))
(\ax ay :
triage
false
(\_ : false)
equal? = y (\self : triage
(triage
true
(\_ : false)
(\_ _ : false))
(\ax :
triage
false
(self ax)
(\_ _ : false))
(\ax ay :
triage
false
(\_ : false)
(\bx by : lAnd (self ax bx) (self ay by))))
filter_ = y (\self : matchList
(\_ : t)
filter_ = y (\self : matchList
(\_ : t)
(\head tail f : matchBool (t head) i (f head) (self tail f)))
filter = (\f l : filter_ l f)
filter = \f l : filter_ l f
foldl_ = y (\self f l x : matchList (\acc : acc) (\head tail acc : self f tail (f acc head)) l x)
foldl = (\f x l : foldl_ f l x)
foldl = \f x l : foldl_ f l x
foldr_ = y (\self x f l : matchList x (\head tail : f (self x f tail) head) l)
foldr = (\f x l : foldr_ x f l)
foldr = \f x l : foldr_ x f l

View File

@ -3,19 +3,19 @@ module Eval where
import Parser
import Research
import Data.List (partition)
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
evalSingle :: Env -> TricuAST -> Env
evalSingle env term
| SFunc name [] body <- term =
| SDef name [] body <- term =
if
| Map.member name env ->
errorWithoutStackTrace $
| Map.member name env ->
errorWithoutStackTrace $
"Error: Identifier '" ++ name ++ "' is already defined."
| otherwise ->
| otherwise ->
let res = evalAST env body
in Map.insert "__result" res (Map.insert name res env)
| SApp func arg <- term =
@ -23,18 +23,23 @@ evalSingle env term
in Map.insert "__result" res env
| SVar name <- term =
case Map.lookup name env of
Just v -> Map.insert "__result" v env
Nothing -> errorWithoutStackTrace $ "Variable `" ++ name ++ "` not defined"
Just v ->
Map.insert "__result" v env
Nothing ->
errorWithoutStackTrace $ "Variable `" ++ name ++ "` not defined\n\
\This error should never occur here. Please report this as an issue."
| otherwise =
Map.insert "__result" (evalAST env term) env
evalTricu :: Env -> [TricuAST] -> Env
evalTricu env [] = env
evalTricu env [x] =
let updatedEnv = evalSingle env x
in Map.insert "__result" (result updatedEnv) updatedEnv
evalTricu env (x:xs) =
evalTricu (evalSingle env x) xs
evalTricu env x = go env (reorderDefs env x)
where
go env [] = env
go env [x] =
let updatedEnv = evalSingle env x
in Map.insert "__result" (result updatedEnv) updatedEnv
go env (x:xs) =
evalTricu (evalSingle env x) xs
evalAST :: Env -> TricuAST -> T
evalAST env term
@ -54,13 +59,24 @@ evalAST env term
(errorWithoutStackTrace $ "Variable " ++ name ++ " not defined")
name env
-- https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf
-- Chapter 4: Lambda-Abstraction
elimLambda :: TricuAST -> TricuAST
elimLambda = go
where
-- η-reduction
go (SLambda [v] (SApp f (SVar x)))
| v == x && not (isFree v f) = elimLambda f
-- Triage optimization
go (SLambda [a] (SLambda [b] (SLambda [c] body)))
| body == triageBody = _TRIAGE
where
triageBody =
(SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a)) (SVar b))) (SVar c))
-- Composition optimization
go (SLambda [f] (SLambda [g] (SLambda [x] body)))
| body == composeBody = _COMPOSE
where
composeBody = SApp (SVar f) (SApp (SVar g) (SVar x))
-- General elimination
go (SLambda (v:vs) body)
| null vs = toSKI v (elimLambda body)
| otherwise = elimLambda (SLambda [v] (SLambda vs body))
@ -75,24 +91,91 @@ elimLambda = go
| otherwise = SApp (SApp _S (toSKI x n)) (toSKI x u)
toSKI x t
| not (isFree x t) = SApp _K t
| otherwise = errorWithoutStackTrace "Unhandled toSKI conversion"
_S = parseSingle "t (t (t t t)) t"
_K = parseSingle "t t"
_I = parseSingle "t (t (t t)) t"
isFree x = Set.member x . freeVars
freeVars (SVar v ) = Set.singleton v
freeVars (SInt _ ) = Set.empty
freeVars (SStr _ ) = Set.empty
freeVars (SList s ) = foldMap freeVars s
freeVars (SApp f a ) = freeVars f <> freeVars a
freeVars (TLeaf ) = Set.empty
freeVars (SFunc _ _ b) = freeVars b
freeVars (TStem t ) = freeVars t
freeVars (TFork l r ) = freeVars l <> freeVars r
freeVars (SLambda v b ) = foldr Set.delete (freeVars b) v
_S = parseSingle "t (t (t t t)) t"
_K = parseSingle "t t"
_I = parseSingle "t (t (t t)) t"
_TRIAGE = parseSingle "t (t (t t (t (t (t t t))))) t"
_COMPOSE = parseSingle "t (t (t t (t (t (t t t)) t))) (t t)"
isFree :: String -> TricuAST -> Bool
isFree x = Set.member x . freeVars
freeVars :: TricuAST -> Set.Set String
freeVars (SVar v ) = Set.singleton v
freeVars (SInt _ ) = Set.empty
freeVars (SStr _ ) = Set.empty
freeVars (SList s ) = foldMap freeVars s
freeVars (SApp f a ) = freeVars f <> freeVars a
freeVars (TLeaf ) = Set.empty
freeVars (SDef _ _ b) = freeVars b
freeVars (TStem t ) = freeVars t
freeVars (TFork l r ) = freeVars l <> freeVars r
freeVars (SLambda v b ) = foldr Set.delete (freeVars b) v
reorderDefs :: Env -> [TricuAST] -> [TricuAST]
reorderDefs env defs
| not (null missingDeps) =
errorWithoutStackTrace $
"Missing dependencies detected: " ++ show missingDeps
| otherwise = orderedDefs ++ others
where
(defsOnly, others) = partition isDef defs
graph = buildDepGraph defsOnly
sortedDefs = sortDeps graph
defMap = Map.fromList [(name, def) | def@(SDef name _ _) <- defsOnly]
orderedDefs = map (\name -> defMap Map.! name) sortedDefs
topDefNames = Set.fromList (Map.keys defMap)
envNames = Set.fromList (Map.keys env)
freeVarsDefs = foldMap (\(SDef _ _ body) -> freeVars body) defsOnly
freeVarsOthers = foldMap freeVars others
allFreeVars = freeVarsDefs <> freeVarsOthers
validNames = topDefNames `Set.union` envNames
missingDeps = Set.toList (allFreeVars `Set.difference` validNames)
isDef (SDef _ _ _) = True
isDef _ = False
buildDepGraph :: [TricuAST] -> Map.Map String (Set.Set String)
buildDepGraph topDefs
| not (null duplicateNames) =
errorWithoutStackTrace $
"Duplicate definitions detected: " ++ show duplicateNames
| otherwise =
Map.fromList
[ (name, depends topDefs (SDef name [] body))
| SDef name _ body <- topDefs]
where
names = [name | SDef name _ _ <- topDefs]
duplicateNames =
[ name | (name, count) <- Map.toList (countOccurrences names) , count > 1]
countOccurrences = foldr (\x -> Map.insertWith (+) x 1) Map.empty
sortDeps :: Map.Map String (Set.Set String) -> [String]
sortDeps graph = go [] (Map.keys graph)
where
go sorted [] = sorted
go sorted remaining
| null ready =
errorWithoutStackTrace
"ERROR: Top-level cyclic dependency detected and prohibited\n\
\RESOLVE: Use nested lambdas"
| otherwise = go (sorted ++ ready) notReady
where
ready = [ name | name <- remaining
, all (`elem` sorted) (Set.toList (graph Map.! name))]
notReady =
[ name | name <- remaining , name `notElem` ready]
depends :: [TricuAST] -> TricuAST -> Set.Set String
depends topDefs (SDef _ _ body) =
Set.intersection
(Set.fromList [n | SDef n _ _ <- topDefs])
(freeVars body)
depends _ _ = Set.empty
result :: Env -> T
result r = case Map.lookup "__result" r of
Just a -> a
Nothing -> errorWithoutStackTrace "No __result field found in provided environment"
Nothing -> errorWithoutStackTrace "No __result field found in provided env"

View File

@ -85,13 +85,10 @@ scnParserM :: ParserM ()
scnParserM = skipMany $ do
t <- lookAhead anySingle
st <- get
if | (parenDepth st > 0 || bracketDepth st > 0) && case t of
LNewline -> True
_ -> False -> void $ satisfyM $ \case
LNewline -> True
_ -> False
| otherwise -> fail "In nested context or no space token" <|> empty
if | (parenDepth st > 0 || bracketDepth st > 0) && (t == LNewline) ->
void $ satisfyM (== LNewline)
| otherwise ->
fail "In nested context or no space token" <|> empty
eofM :: ParserM ()
eofM = lift eof
@ -109,32 +106,23 @@ parseExpressionM = choice
parseFunctionM :: ParserM TricuAST
parseFunctionM = do
LIdentifier name <- satisfyM $ \case
LIdentifier _ -> True
_ -> False
args <- many $ satisfyM $ \case
LIdentifier _ -> True
_ -> False
let ident = (\case LIdentifier _ -> True; _ -> False)
LIdentifier name <- satisfyM ident
args <- many $ satisfyM ident
_ <- satisfyM (== LAssign)
scnParserM
body <- parseExpressionM
pure (SFunc name (map getIdentifier args) body)
pure (SDef name (map getIdentifier args) body)
parseLambdaM :: ParserM TricuAST
parseLambdaM =
between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) $ do
_ <- satisfyM (== LBackslash)
param <- satisfyM $ \case
LIdentifier _ -> True
_ -> False
rest <- many $ satisfyM $ \case
LIdentifier _ -> True
_ -> False
_ <- satisfyM (== LColon)
scnParserM
body <- parseLambdaExpressionM
let nested = foldr (\v acc -> SLambda [getIdentifier v] acc) body rest
pure (SLambda [getIdentifier param] nested)
parseLambdaM = do
let ident = (\case LIdentifier _ -> True; _ -> False)
_ <- satisfyM (== LBackslash)
params <- some (satisfyM ident)
_ <- satisfyM (== LColon)
scnParserM
body <- parseLambdaExpressionM
pure $ foldr (\param acc -> SLambda [getIdentifier param] acc) body params
parseLambdaExpressionM :: ParserM TricuAST
parseLambdaExpressionM = choice
@ -180,9 +168,8 @@ parseAtomicBaseM = choice
parseTreeLeafM :: ParserM TricuAST
parseTreeLeafM = do
_ <- satisfyM $ \case
LKeywordT -> True
_ -> False
let keyword = (\case LKeywordT -> True; _ -> False)
_ <- satisfyM keyword
notFollowedBy $ lift $ satisfy (== LAssign)
pure TLeaf
@ -248,37 +235,38 @@ parseGroupedItemM = do
parseSingleItemM :: ParserM TricuAST
parseSingleItemM = do
token <- satisfyM $ \case
LIdentifier _ -> True
LKeywordT -> True
_ -> False
case token of
LIdentifier name -> pure (SVar name)
LKeywordT -> pure TLeaf
_ -> fail "Unexpected token in list item"
token <- satisfyM (\case LIdentifier _ -> True; LKeywordT -> True; _ -> False)
if | LIdentifier name <- token -> pure (SVar name)
| token == LKeywordT -> pure TLeaf
| otherwise -> fail "Unexpected token in list item"
parseVarM :: ParserM TricuAST
parseVarM = do
LIdentifier name <- satisfyM $ \case
LIdentifier _ -> True
_ -> False
if name == "t" || name == "__result"
then fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
else pure (SVar name)
satisfyM (\case LIdentifier _ -> True; _ -> False) >>= \case
LIdentifier name
| name == "t" || name == "__result" ->
fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
| otherwise ->
pure (SVar name)
_ -> fail "Unexpected token while parsing variable"
parseIntLiteralM :: ParserM TricuAST
parseIntLiteralM = do
LIntegerLiteral value <- satisfyM $ \case
LIntegerLiteral _ -> True
_ -> False
pure (SInt value)
let intL = (\case LIntegerLiteral _ -> True; _ -> False)
token <- satisfyM intL
if | LIntegerLiteral value <- token ->
pure (SInt value)
| otherwise ->
fail "Unexpected token while parsing integer literal"
parseStrLiteralM :: ParserM TricuAST
parseStrLiteralM = do
LStringLiteral value <- satisfyM $ \case
LStringLiteral _ -> True
_ -> False
pure (SStr value)
let strL = (\case LStringLiteral _ -> True; _ -> False)
token <- satisfyM strL
if | LStringLiteral value <- token ->
pure (SStr value)
| otherwise ->
fail "Unexpected token while parsing string literal"
getIdentifier :: LToken -> String
getIdentifier (LIdentifier name) = name

View File

@ -19,7 +19,7 @@ data TricuAST
| SInt Int
| SStr String
| SList [TricuAST]
| SFunc String [String] TricuAST
| SDef String [String] TricuAST
| SApp TricuAST TricuAST
| TLeaf
| TStem TricuAST

View File

@ -85,7 +85,7 @@ parser = testGroup "Parser Tests"
, testCase "Parse function definitions" $ do
let input = "x = (\\a b c : a)"
expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SLambda ["c"] (SVar "a"))))
expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SLambda ["c"] (SVar "a"))))
parseSingle input @?= expect
, testCase "Parse nested Tree Calculus terms" $ do
@ -105,7 +105,7 @@ parser = testGroup "Parser Tests"
, testCase "Parse function with applications" $ do
let input = "f = (\\x : t x)"
expect = SFunc "f" [] (SLambda ["x"] (SApp TLeaf (SVar "x")))
expect = SDef "f" [] (SLambda ["x"] (SApp TLeaf (SVar "x")))
parseSingle input @?= expect
, testCase "Parse nested lists" $ do
@ -147,7 +147,7 @@ parser = testGroup "Parser Tests"
, testCase "Parse nested parentheses in function body" $ do
let input = "f = (\\x : t (t (t t)))"
expect = SFunc "f" [] (SLambda ["x"] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))))
expect = SDef "f" [] (SLambda ["x"] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))))
parseSingle input @?= expect
, testCase "Parse lambda abstractions" $ do
@ -157,12 +157,12 @@ parser = testGroup "Parser Tests"
, testCase "Parse multiple arguments to lambda abstractions" $ do
let input = "x = (\\a b : a)"
expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a")))
expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a")))
parseSingle input @?= expect
, testCase "Grouping T terms with parentheses in function application" $ do
let input = "x = (\\a : a)\nx (t)"
expect = [SFunc "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf]
expect = [SDef "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf]
parseTricu input @?= expect
, testCase "Comments 1" $ do
@ -497,7 +497,6 @@ fileEval = testGroup "File evaluation tests"
decodeResult (result res) @?= "\"String test!\""
]
demos :: TestTree
demos = testGroup "Test provided demo functionality"
[ testCase "Structural equality demo" $ do
@ -511,7 +510,7 @@ demos = testGroup "Test provided demo functionality"
, testCase "Determining the size of functions" $ do
library <- liftIO $ evaluateFile "./lib/base.tri"
res <- liftIO $ evaluateFileWithContext library "./demos/size.tri"
decodeResult (result res) @?= "2071"
decodeResult (result res) @?= "454"
, testCase "Level Order Traversal demo" $ do
library <- liftIO $ evaluateFile "./lib/base.tri"
res <- liftIO $ evaluateFileWithContext library "./demos/levelOrderTraversal.tri"

21
test/size.tri Normal file
View File

@ -0,0 +1,21 @@
compose = \f g x : f (g x)
succ = y (\self :
triage
1
t
(triage
(t (t t))
(\_ tail : t t (self tail))
t))
size = (\x :
(y (\self x :
compose succ
(triage
(\x : x)
self
(\x y : compose (self x) (self y))
x)) x 0))
size size

1
test/undefined.tri Normal file
View File

@ -0,0 +1 @@
namedTerm = undefinedForTesting

View File

@ -1,7 +1,7 @@
cabal-version: 1.12
name: tricu
version: 0.7.0
version: 0.10.0
description: A micro-language for exploring Tree Calculus
author: James Eversole
maintainer: james@eversole.co