James/tricu
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Picking development back up

Browse Source 
Merge Kiselyov optimizations and De Bruijn indices
General clean up
This commit is contained in:
James Eversole
2026-05-05 14:51:42 -05:00
parent c008126b14 0cdc0bfc34
commit 2627627493
7 changed files with 483 additions and 123 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
README.md
View File

@@ -10,6 +10,10 @@ tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)
Tree Calculus was discovered by [Barry Jay](https://github.com/barry-jay-personal/blog). The addition of Triage rules were suggested by [Johannes Bader](https://johannes-bader.com/). Johannes is also the creator of [treecalcul.us](https://treecalcul.us) which has a great intuitive code playground using his language LambAda. Tree Calculus was discovered by [Barry Jay](https://github.com/barry-jay-personal/blog). The addition of Triage rules were suggested by [Johannes Bader](https://johannes-bader.com/). Johannes is also the creator of [treecalcul.us](https://treecalcul.us) which has a great intuitive code playground using his language LambAda.
## Versioning
This really is a repo for experimentation so I'm not doing anything sane with the versioning for now. If I decide to stabilize the project we'll start anew at 2.0.
## REPL examples ## REPL examples
``` ```

45
flake.nix
View File

@@ -11,24 +11,40 @@
let let
pkgs = nixpkgs.legacyPackages.${system}; pkgs = nixpkgs.legacyPackages.${system};
packageName = "tricu"; packageName = "tricu";
containerPackageName = "${packageName}-container";
customGHC = pkgs.haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [
megaparsec
]);
haskellPackages = pkgs.haskellPackages; haskellPackages = pkgs.haskellPackages;
hsLib = pkgs.haskell.lib;
enableSharedExecutables = false; tricuPackage =
enableSharedLibraries = false; haskellPackages.callCabal2nix packageName self {};
tricu = pkgs.haskell.lib.justStaticExecutables self.packages.${system}.default; tricuTests =
hsLib.overrideCabal tricuPackage (old: {
doCheck = true;
configureFlags = (old.configureFlags or []) ++ [
"--enable-tests"
];
checkPhase = ''
runHook preCheck
./Setup test tricu-tests --show-details=direct
runHook postCheck
'';
});
customGHC = haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [
megaparsec
]);
in { in {
packages.${packageName} = tricuPackage;
packages.default = tricuPackage;
packages.${packageName} = packages.test = tricuTests;
haskellPackages.callCabal2nix packageName self rec {};
checks.${packageName} = tricuTests;
checks.default = tricuTests;
packages.default = self.packages.${system}.${packageName};
defaultPackage = self.packages.${system}.default; defaultPackage = self.packages.${system}.default;
devShells.default = pkgs.mkShell { devShells.default = pkgs.mkShell {
@@ -39,9 +55,10 @@
customGHC customGHC
upx upx
]; ];
inputsFrom = builtins.attrValues self.packages.${system};
};
devShell = self.devShells.${system}.default;
inputsFrom = [
tricuPackage
];
};
}); });
} }

27
src/ContentStore.hs
View File

@@ -3,17 +3,17 @@ module ContentStore where
import Research import Research
import Parser import Parser
import Control.Monad (foldM, forM) import Control.Monad (foldM, forM_, void)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.List (nub, sort) import Data.List (nub, sort)
import Data.Maybe (catMaybes, fromJust) import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text) import Data.Text (Text)
import Database.SQLite.Simple import Database.SQLite.Simple
import Database.SQLite.Simple.FromRow (FromRow(..), field) import Database.SQLite.Simple.FromRow (FromRow(..), field)
import System.Directory (createDirectoryIfMissing, getXdgDirectory, XdgDirectory(..)) import System.Directory (createDirectoryIfMissing, getXdgDirectory, XdgDirectory(..))
import System.FilePath ((</>), takeDirectory) import System.FilePath ((</>), takeDirectory)
import qualified Data.ByteString as BS
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Text as T import qualified Data.Text as T
@@ -47,7 +47,6 @@ initContentStore = do
execute_ conn "CREATE TABLE IF NOT EXISTS terms (\ execute_ conn "CREATE TABLE IF NOT EXISTS terms (\
\hash TEXT PRIMARY KEY, \ \hash TEXT PRIMARY KEY, \
\names TEXT, \ \names TEXT, \
\term_data BLOB, \
\metadata TEXT, \ \metadata TEXT, \
\created_at INTEGER DEFAULT (strftime('%s','now')), \ \created_at INTEGER DEFAULT (strftime('%s','now')), \
\tags TEXT DEFAULT '')" \tags TEXT DEFAULT '')"
@@ -83,8 +82,8 @@ storeTerm conn newNamesStrList term = do
[] -> do [] -> do
let allNamesToStore = serializeNameList newNamesTextList let allNamesToStore = serializeNameList newNamesTextList
execute conn execute conn
"INSERT INTO terms (hash, names, term_data, metadata, tags) VALUES (?, ?, ?, ?, ?)" "INSERT INTO terms (hash, names, metadata, tags) VALUES (?, ?, ?, ?)"
(termHashText, allNamesToStore, BS.pack [], metadataText, T.pack "") (termHashText, allNamesToStore, metadataText, T.pack "")
[(Only currentNamesText)] -> do [(Only currentNamesText)] -> do
let currentNamesList = parseNameList currentNamesText let currentNamesList = parseNameList currentNamesText
let combinedNamesList = currentNamesList ++ newNamesTextList let combinedNamesList = currentNamesList ++ newNamesTextList
@@ -92,7 +91,7 @@ storeTerm conn newNamesStrList term = do
execute conn execute conn
"UPDATE terms SET names = ?, metadata = ? WHERE hash = ?" "UPDATE terms SET names = ?, metadata = ? WHERE hash = ?"
(allNamesToStore, metadataText, termHashText) (allNamesToStore, metadataText, termHashText)
_ -> error $ "Multiple terms with same hash? " ++ show (length existingNamesQuery) _ -> errorWithoutStackTrace $ "Multiple terms with same hash? " ++ show (length existingNamesQuery)
return termHashText return termHashText
@@ -108,11 +107,11 @@ loadTree conn h
where where
buildTree :: Node -> IO T buildTree :: Node -> IO T
buildTree (NStem childHash) = do buildTree (NStem childHash) = do
child <- fromJust <$> loadTree conn childHash child <- fromMaybe (errorWithoutStackTrace "BUG: stored hash not found") <$> loadTree conn childHash
return (Stem child) return (Stem child)
buildTree (NFork lHash rHash) = do buildTree (NFork lHash rHash) = do
left <- fromJust <$> loadTree conn lHash left <- fromMaybe (errorWithoutStackTrace "BUG: stored hash not found") <$> loadTree conn lHash
right <- fromJust <$> loadTree conn rHash right <- fromMaybe (errorWithoutStackTrace "BUG: stored hash not found") <$> loadTree conn rHash
return (Fork left right) return (Fork left right)
-- | Store all nodes of a Merkle DAG by traversing the Term and building/storing nodes. -- | Store all nodes of a Merkle DAG by traversing the Term and building/storing nodes.
@@ -161,14 +160,14 @@ listStoredTerms :: Connection -> IO [StoredTerm]
listStoredTerms conn = listStoredTerms conn =
query_ conn (selectStoredTermFields <> " ORDER BY created_at DESC") query_ conn (selectStoredTermFields <> " ORDER BY created_at DESC")
storeEnvironment :: Connection -> Env -> IO [(String, Text)] storeEnvironment :: Connection -> Env -> IO ()
storeEnvironment conn env = do storeEnvironment conn env = do
let defs = Map.toList $ Map.delete "!result" env let defs = Map.toList $ Map.delete "!result" env
let groupedDefs = Map.toList $ Map.fromListWith (++) [(term, [name]) | (name, term) <- defs] let groupedDefs = Map.toList $ Map.fromListWith (++) [(term, [name]) | (name, term) <- defs]
forM groupedDefs $ \(term, namesList) -> do forM_ groupedDefs $ \(term, namesList) -> case namesList of
hashVal <- storeTerm conn namesList term n:ns -> void $ storeTerm conn namesList term
return (head namesList, hashVal) _ -> errorWithoutStackTrace "storeEnvironment: empty names list"
loadTerm :: Connection -> String -> IO (Maybe T) loadTerm :: Connection -> String -> IO (Maybe T)
loadTerm conn identifier = do loadTerm conn identifier = do

392
src/Eval.hs
View File

@@ -4,14 +4,32 @@ import ContentStore
import Parser import Parser
import Research import Research
import Control.Monad (forM_, foldM) import Control.Monad (foldM)
import Data.List (partition, (\\)) import Data.List (partition, (\\), elemIndex, foldl')
import Data.Map (Map) import Data.Map (Map)
import Data.Set (Set)
import Database.SQLite.Simple import Database.SQLite.Simple
import qualified Data.Foldable as F
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Text as T import qualified Data.Text as T
import Data.List (foldl')
data DB
= BVar Int -- bound (0 = nearest binder)
| BFree String -- free/global
| BLam DB
| BApp DB DB
| BLeaf
| BStem DB
| BFork DB DB
| BStr String
| BInt Integer
| BList [DB]
| BEmpty
deriving (Eq, Show)
type Uses = [Bool]
evalSingle :: Env -> TricuAST -> Env evalSingle :: Env -> TricuAST -> Env
evalSingle env term evalSingle env term
@@ -119,45 +137,59 @@ resolveTermFromStore conn selectedVersions name mhash = case mhash of
case versions of case versions of
[] -> return Nothing [] -> return Nothing
[(_, term, _)] -> return $ Just term [(_, term, _)] -> return $ Just term
_ -> return $ Just $ (\(_, t, _) -> t) $ head versions _ -> return $ Just $ (\(_, t, _) -> t) $ case versions of (_:_) -> head versions; _ -> error "resolveTermFromStore: unexpected empty versions list"
elimLambda :: TricuAST -> TricuAST elimLambda :: TricuAST -> TricuAST
elimLambda = go elimLambda = go
where where
go term go term
| etaReduction term = elimLambda $ etaReduceResult term | etaReduction term = go (etaReduceResult term)
| triagePattern term = _TRI | triagePattern term = _TRI
| composePattern term = _B | composePattern term = _B
| lambdaList term = elimLambda $ lambdaListResult term | lambdaList term = go (lambdaListResult term)
| nestedLambda term = nestedLambdaResult term | nestedLambda term = nestedLambdaResult term
| application term = applicationResult term | application term = applicationResult term
| isSList term = slistTransform term | isSList term = slistTransform term
| otherwise = term | otherwise = term
etaReduction (SLambda [v] (SApp f (SVar x Nothing))) = v == x && not (isFree v f) etaReduction (SLambda [v] (SApp f (SVar x Nothing))) = v == x && not (usesBinder v f)
etaReduction _ = False etaReduction _ = False
etaReduceResult (SLambda [_] (SApp f _)) = f
triagePattern (SLambda [a] (SLambda [b] (SLambda [c] body))) = body == triageBody a b c -- triage: \a b c -> TLeaf (TLeaf a b) c (checked in DB with a↦2, b↦1, c↦0)
triagePattern (SLambda [a] (SLambda [b] (SLambda [c] body))) =
toDB [c,b,a] body == triageBodyDB
triagePattern _ = False triagePattern _ = False
composePattern (SLambda [f] (SLambda [g] (SLambda [x] body))) = body == composeBody f g x -- compose: \f g x -> f (g x) (checked in DB with f↦2, g↦1, x↦0)
composePattern (SLambda [f] (SLambda [g] (SLambda [x] body))) =
toDB [x,g,f] body == composeBodyDB
composePattern _ = False composePattern _ = False
lambdaList (SLambda [_] (SList _)) = True lambdaList (SLambda [_] (SList _)) = True
lambdaList _ = False lambdaList _ = False
lambdaListResult (SLambda [v] (SList xs)) = SLambda [v] (foldr wrapTLeaf TLeaf xs)
wrapTLeaf m r = SApp (SApp TLeaf m) r
nestedLambda (SLambda (_:_) _) = True nestedLambda (SLambda (_:_) _) = True
nestedLambda _ = False nestedLambda _ = False
nestedLambdaResult (SLambda (v:vs) body)
| null vs = toSKI v (go body) -- Changed elimLambda to go
| otherwise = go (SLambda [v] (SLambda vs body)) -- Changed elimLambda to go
application (SApp _ _) = True application (SApp _ _) = True
application _ = False application _ = False
applicationResult (SApp f g) = SApp (go f) (go g) -- Changed elimLambda to go
-- rewrites
etaReduceResult (SLambda [_] (SApp f _)) = f
lambdaListResult (SLambda [v] (SList xs)) =
SLambda [v] (foldr wrapTLeaf TLeaf xs)
where
wrapTLeaf m r = SApp (SApp TLeaf m) r
nestedLambdaResult (SLambda (v:vs) body)
| null vs =
let body' = go body
db = toDB [v] body'
in toSKIKiselyov db
| otherwise = go (SLambda [v] (SLambda vs body))
applicationResult (SApp f g) = SApp (go f) (go g)
isSList (SList _) = True isSList (SList _) = True
isSList _ = False isSList _ = False
@@ -166,27 +198,23 @@ elimLambda = go
slistTransform (SList xs) = foldr (\m r -> SApp (SApp TLeaf (go m)) r) TLeaf xs slistTransform (SList xs) = foldr (\m r -> SApp (SApp TLeaf (go m)) r) TLeaf xs
slistTransform ast = ast -- Should not be reached if isSList is the guard slistTransform ast = ast -- Should not be reached if isSList is the guard
toSKI x (SVar y Nothing) _S = parseSingle "t (t (t t t)) t"
| x == y = _I _K = parseSingle "t t"
| otherwise = SApp _K (SVar y Nothing) _I = parseSingle "t (t (t t)) t"
toSKI x (SApp m n) = SApp (SApp _S (toSKI x m)) (toSKI x n) _R = parseSingle "(t (t (t t (t (t (t (t (t (t (t t (t (t (t t t)) t))) (t (t (t t (t t))) (t (t (t t t)) t)))) (t t (t t))))))) (t t))"
toSKI x (SLambda [y] body) = toSKI x (toSKI y body) -- This should ideally not happen if lambdas are fully eliminated first _C = parseSingle "(t (t (t (t (t t (t (t (t t t)) t))) (t (t (t t (t t))) (t (t (t t t)) t)))) (t t (t t)))"
toSKI _ sl@(SList _) = SApp _K (go sl) -- Ensure SList itself is transformed if somehow passed to toSKI directly _B = parseSingle "t (t (t t (t (t (t t t)) t))) (t t)"
toSKI _ term = SApp _K term _T = SApp _C _I
_TRI = parseSingle "t (t (t t (t (t (t t t))))) t"
_S = parseSingle "t (t (t t t)) t" triageBody a b c = SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a Nothing)) (SVar b Nothing))) (SVar c Nothing)
_K = parseSingle "t t" composeBody f g x = SApp (SVar f Nothing) (SApp (SVar g Nothing) (SVar x Nothing))
_I = parseSingle "t (t (t t)) t"
_B = parseSingle "t (t (t t (t (t (t t t)) t))) (t t)"
_TRI = parseSingle "t (t (t t (t (t (t t t))))) t"
triageBody a b c = SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a Nothing)) (SVar b Nothing))) (SVar c Nothing)
composeBody f g x = SApp (SVar f Nothing) (SVar g Nothing) -- Note: This might not be the standard B combinator body f(g x)
isFree :: String -> TricuAST -> Bool isFree :: String -> TricuAST -> Bool
isFree x = Set.member x . freeVars isFree x t = Set.member x (freeVars t)
freeVars :: TricuAST -> Set.Set String -- Keep old freeVars for compatibility with reorderDefs which still uses TricuAST
freeVars :: TricuAST -> Set String
freeVars (SVar v Nothing) = Set.singleton v freeVars (SVar v Nothing) = Set.singleton v
freeVars (SVar v (Just _)) = Set.singleton v freeVars (SVar v (Just _)) = Set.singleton v
freeVars (SApp t u) = Set.union (freeVars t) (freeVars u) freeVars (SApp t u) = Set.union (freeVars t) (freeVars u)
@@ -273,22 +301,6 @@ mainResult r = case Map.lookup "main" r of
Just a -> a Just a -> a
Nothing -> errorWithoutStackTrace "No valid definition for `main` found." Nothing -> errorWithoutStackTrace "No valid definition for `main` found."
evalWithEnv :: Env -> Maybe Connection -> Map.Map String T.Text -> TricuAST -> IO T
evalWithEnv env mconn selectedVersions ast = do
let varNames = findVarNames ast
resolvedEnv <- case mconn of
Just conn -> foldM (\e name ->
if Map.member name e
then return e
else do
mterm <- resolveTermFromStore conn selectedVersions name Nothing
case mterm of
Just term -> return $ Map.insert name term e
Nothing -> return e
) env varNames
Nothing -> return env
return $ evalASTSync resolvedEnv ast
findVarNames :: TricuAST -> [String] findVarNames :: TricuAST -> [String]
findVarNames ast = case ast of findVarNames ast = case ast of
SVar name _ -> [name] SVar name _ -> [name]
@@ -296,3 +308,285 @@ findVarNames ast = case ast of
SLambda args body -> findVarNames body \\ args SLambda args body -> findVarNames body \\ args
SDef name args body -> name : (findVarNames body \\ args) SDef name args body -> name : (findVarNames body \\ args)
_ -> [] _ -> []
-- Convert named TricuAST to De Bruijn form
toDB :: [String] -> TricuAST -> DB
toDB env = \case
SVar v _ -> maybe (BFree v) BVar (elemIndex v env)
SLambda vs b ->
let env' = reverse vs ++ env
body = toDB env' b
in foldr (\_ acc -> BLam acc) body vs
SApp f a -> BApp (toDB env f) (toDB env a)
TLeaf -> BLeaf
TStem t -> BStem (toDB env t)
TFork l r -> BFork (toDB env l) (toDB env r)
SStr s -> BStr s
SInt n -> BInt n
SList xs -> BList (map (toDB env) xs)
SEmpty -> BEmpty
SDef{} -> error "toDB: unexpected SDef at this stage"
SImport _ _ -> BEmpty
-- Does a term depend on the current binder (level 0)?
dependsOnLevel :: Int -> DB -> Bool
dependsOnLevel lvl = \case
BVar k -> k == lvl
BLam t -> dependsOnLevel (lvl + 1) t
BApp f a -> dependsOnLevel lvl f || dependsOnLevel lvl a
BStem t -> dependsOnLevel lvl t
BFork l r -> dependsOnLevel lvl l || dependsOnLevel lvl r
BList xs -> any (dependsOnLevel lvl) xs
_ -> False
-- Collect free *global* names (i.e., unbound)
freeDBNames :: DB -> Set String
freeDBNames = \case
BFree s -> Set.singleton s
BVar _ -> mempty
BLam t -> freeDBNames t
BApp f a -> freeDBNames f <> freeDBNames a
BLeaf -> mempty
BStem t -> freeDBNames t
BFork l r -> freeDBNames l <> freeDBNames r
BStr _ -> mempty
BInt _ -> mempty
BList xs -> foldMap freeDBNames xs
BEmpty -> mempty
-- Helper: “is the binder named v used in body?”
usesBinder :: String -> TricuAST -> Bool
usesBinder v body = dependsOnLevel 0 (toDB [v] body)
-- Expected DB bodies for the named special patterns (under env [a,b,c] -> indices 2,1,0)
triageBodyDB :: DB
triageBodyDB =
BApp (BApp BLeaf (BApp (BApp BLeaf (BVar 2)) (BVar 1))) (BVar 0)
composeBodyDB :: DB
composeBodyDB =
BApp (BVar 2) (BApp (BVar 1) (BVar 0))
-- Convert DB -> TricuAST for subterms that contain NO binders (no BLam, no BVar)
fromDBClosed :: DB -> TricuAST
fromDBClosed = \case
BFree s -> SVar s Nothing
BApp f a -> SApp (fromDBClosed f) (fromDBClosed a)
BLeaf -> TLeaf
BStem t -> TStem (fromDBClosed t)
BFork l r -> TFork (fromDBClosed l) (fromDBClosed r)
BStr s -> SStr s
BInt n -> SInt n
BList xs -> SList (map fromDBClosed xs)
BEmpty -> SEmpty
-- Anything bound would be a logic error if we call this correctly.
BLam _ -> error "fromDBClosed: unexpected BLam"
BVar _ -> error "fromDBClosed: unexpected bound variable"
-- DB-native bracket abstraction over the innermost binder (level 0).
-- This mirrors your old toSKI, but is purely index-driven.
toSKIDB :: DB -> TricuAST
toSKIDB t
| not (dependsOnLevel 0 t) = SApp _K (fromDBClosed t)
toSKIDB (BVar 0) = _I
toSKIDB (BApp n u) = SApp (SApp _S (toSKIDB n)) (toSKIDB u)
toSKIDB (BList xs) =
let anyUses = any (dependsOnLevel 0) xs
in if not anyUses
then SApp _K (SList (map fromDBClosed xs))
else SList (map toSKIDB xs)
toSKIDB other
| not (dependsOnLevel 0 other) = SApp _K (fromDBClosed other)
toSKIDB other = _K `SApp` TLeaf
app2 :: TricuAST -> TricuAST -> TricuAST
app2 f x = SApp f x
app3 :: TricuAST -> TricuAST -> TricuAST -> TricuAST
app3 f x y = SApp (SApp f x) y
-- Core converter that *does not* perform the λ-step; it just returns (Γ, d).
-- Supported shapes: variables, applications, closed literals (Leaf/Int/Str/Empty),
-- closed lists. For anything where the binder occurs under structural nodes
-- (Stem/Fork/List-with-use), we deliberately bail so the caller can fall back.
kisConv :: DB -> Either String (Uses, TricuAST)
kisConv = \case
BVar 0 -> Right ([True], _I)
BVar n | n > 0 -> do
(g,d) <- kisConv (BVar (n - 1))
Right (False:g, d)
BApp e1 e2 -> do
(g1,d1) <- kisConv e1
(g2,d2) <- kisConv e2
let g = zipWithDefault False (||) g1 g2 -- <— propagate Γ outside (#)
d = kisHash (g1,d1) (g2,d2) -- <— (#) yields only the term
Right (g, d)
-- Treat closed constants as free 'combinator leaves' (no binder use).
BLeaf -> Right ([], TLeaf)
BStr s -> Right ([], SStr s)
BInt n -> Right ([], SInt n)
BEmpty -> Right ([], SEmpty)
-- Closed list: allowed. If binder is used anywhere, we punt to fallback.
BList xs
| any (dependsOnLevel 0) xs -> Left "List with binder use: fallback"
| otherwise -> Right ([], SList (map fromDBClosed xs))
-- For structural nodes, only allow if *closed* wrt the binder.
BStem t
| dependsOnLevel 0 t -> Left "Stem with binder use: fallback"
| otherwise -> Right ([], TStem (fromDBClosed t))
BFork l r
| dependsOnLevel 0 l || dependsOnLevel 0 r -> Left "Fork with binder use: fallback"
| otherwise -> Right ([], TFork (fromDBClosed l) (fromDBClosed r))
-- We shouldn’t see BLam under elim; treat as unsupported so we fallback.
BLam _ -> Left "Nested lambda under body: fallback"
BFree s -> Right ([], SVar s Nothing)
-- Application combiner with K-optimization (lazy weakening).
-- Mirrors Lynn’s 'optK' rules: choose among S, B, C, R based on leading flags.
-- η-aware (#) with K-optimization (adapted from TS kiselyov_eta)
kisHash :: (Uses, TricuAST) -> (Uses, TricuAST) -> TricuAST
kisHash (g1, d1) (g2, d2) =
case g1 of
[] -> case g2 of
[] -> SApp d1 d2
True:gs2 -> if isId2 (g2, d2)
then d1
else kisHash ([], SApp _B d1) (gs2, d2)
False:gs2 -> kisHash ([], d1) (gs2, d2)
True:gs1 -> case g2 of
[] -> if isId2 (g1, d1)
then SApp _T d2
else kisHash ([], SApp _R d2) (gs1, d1)
_ ->
if isId2 (g1, d1) && case g2 of { False:_ -> True; _ -> False }
then kisHash ([], _T) (drop1 g2, d2)
else
-- NEW: coalesce the longest run of identical head pairs and apply bulk op once
let ((h1, h2), count) = headPairRun g1 g2
g1' = drop count g1
g2' = drop count g2
in case (h1, h2) of
(False, False) ->
kisHash (g1', d1) (g2', d2)
(False, True) ->
let d1' = kisHash ([], bulkB count) (g1', d1)
in kisHash (g1', d1') (g2', d2)
(True, False) ->
let d1' = kisHash ([], bulkC count) (g1', d1)
in kisHash (g1', d1') (g2', d2)
(True, True) ->
let d1' = kisHash ([], bulkS count) (g1', d1)
in kisHash (g1', d1') (g2', d2)
False:gs1 -> case g2 of
[] -> kisHash (gs1, d1) ([], d2)
_ ->
if isId2 (g1, d1) && case g2 of { False:_ -> True; _ -> False }
then kisHash ([], _T) (drop1 g2, d2)
else case g2 of
True:gs2 ->
let d1' = kisHash ([], _B) (gs1, d1)
in kisHash (gs1, d1') (gs2, d2)
False:gs2 ->
kisHash (gs1, d1) (gs2, d2)
where
drop1 (_:xs) = xs
drop1 [] = []
toSKIKiselyov :: DB -> TricuAST
toSKIKiselyov body =
case kisConv body of
Right ([], d) -> SApp _K d
Right (True:_ , d) -> d
Right (False:g, d) -> kisHash ([], _K) (g, d) -- no snd
Left _ -> starSKIBCOpEtaDB body -- was: toSKIDB body
zipWithDefault :: a -> (a -> a -> a) -> [a] -> [a] -> [a]
zipWithDefault d f [] ys = map (f d) ys
zipWithDefault d f xs [] = map (\x -> f x d) xs
zipWithDefault d f (x:xs) (y:ys) = f x y : zipWithDefault d f xs ys
isNode :: TricuAST -> Bool
isNode t = case t of
TLeaf -> True
_ -> False
isApp2 :: TricuAST -> Maybe (TricuAST, TricuAST)
isApp2 (SApp a b) = Just (a, b)
isApp2 _ = Nothing
isKop :: TricuAST -> Bool
isKop t = case isApp2 t of
Just (a,b) -> isNode a && isNode b
_ -> False
-- detects the two canonical I-shapes in the tree calculus:
-- △ (△ (△ △)) x OR △ (△ △ △) △
isId :: TricuAST -> Bool
isId t = case isApp2 t of
Just (ab, c) -> case isApp2 ab of
Just (a, b) | isNode a ->
case isApp2 b of
Just (b1, b2) ->
(isNode b1 && isKop b2) ||
(isKop b1 && isNode b2 && isNode c)
_ -> False
_ -> False
_ -> False
-- head-True only, tail empty, and term is identity
isId2 :: (Uses, TricuAST) -> Bool
isId2 (True:[], t) = isId t
isId2 _ = False
-- Bulk helpers built from SKI (no new primitives)
bPrime :: TricuAST
bPrime = SApp _B _B -- B' = B B
cPrime :: TricuAST
cPrime = SApp (SApp _B (SApp _B _C)) _B -- C' = B (B C) B
sPrime :: TricuAST
sPrime = SApp (SApp _B (SApp _B _S)) _B -- S' = B (B S) B
bulkB :: Int -> TricuAST
bulkB n | n <= 1 = _B
| otherwise = SApp bPrime (bulkB (n - 1))
bulkC :: Int -> TricuAST
bulkC n | n <= 1 = _C
| otherwise = SApp cPrime (bulkC (n - 1))
bulkS :: Int -> TricuAST
bulkS n | n <= 1 = _S
| otherwise = SApp sPrime (bulkS (n - 1))
-- Count how many leading pairs (a,b) repeat at the head of zip g1 g2
headPairRun :: [Bool] -> [Bool] -> ((Bool, Bool), Int)
headPairRun g1 g2 =
case zip g1 g2 of
[] -> ((False, False), 0)
(h:rest) -> (h, 1 + length (takeWhile (== h) rest))
-- DB-native star_skibc_op_eta (adapted from strategies.mts), binder = level 0
starSKIBCOpEtaDB :: DB -> TricuAST
starSKIBCOpEtaDB t
| not (dependsOnLevel 0 t) = SApp _K (fromDBClosed t)
starSKIBCOpEtaDB (BVar 0) = _I
starSKIBCOpEtaDB (BApp e1 e2)
-- if binder not in right: use C
| not (dependsOnLevel 0 e2)
= SApp (SApp _C (starSKIBCOpEtaDB e1)) (fromDBClosed e2)
-- if binder not in left:
| not (dependsOnLevel 0 e1)
= case e2 of
-- η case: \x. f x ==> f
BVar 0 -> fromDBClosed e1
_ -> SApp (SApp _B (fromDBClosed e1)) (starSKIBCOpEtaDB e2)
-- otherwise: S
| otherwise
= SApp (SApp _S (starSKIBCOpEtaDB e1)) (starSKIBCOpEtaDB e2)
-- Structural nodes with binder underneath: fall back to plain SKI (rare)
starSKIBCOpEtaDB other = toSKIDB other

53
src/Research.hs
View File

@@ -1,11 +1,11 @@
module Research where module Research where
import Data.ByteArray (convert) import Data.ByteArray (convert)
import Data.Char (chr, ord) import Data.ByteString.Base16 (decode, encode)
import Data.List (intercalate) import Data.List (intercalate)
import Data.Map (Map) import Data.Map (Map)
import Data.Text (Text, replace, unpack) import Data.Text (Text, replace, pack)
import Data.Word (Word8) import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import System.Console.CmdArgs (Data, Typeable) import System.Console.CmdArgs (Data, Typeable)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
@@ -76,36 +76,21 @@ data Node
-- Fork: 0x02 || left_hash (32 bytes) || right_hash (32 bytes) -- Fork: 0x02 || left_hash (32 bytes) || right_hash (32 bytes)
serializeNode :: Node -> BS.ByteString serializeNode :: Node -> BS.ByteString
serializeNode NLeaf = BS.pack [0x00] serializeNode NLeaf = BS.pack [0x00]
serializeNode (NStem h) = BS.pack [0x01] <> hexToBytes h serializeNode (NStem h) = BS.pack [0x01] <> go (decode (encodeUtf8 h))
serializeNode (NFork l r) = BS.pack [0x02] <> hexToBytes l <> hexToBytes r where go (Left _) = error "Research.serializeNode: invalid hex hash"
go (Right bs) = bs
serializeNode (NFork l r) = BS.pack [0x02] <> go (decode (encodeUtf8 l)) <> go (decode (encodeUtf8 r))
where go (Left _) = error "Research.serializeNode: invalid hex hash"
go (Right bs) = bs
-- | Hash a node per the Merkle content-addressing spec. -- | Hash a node per the Merkle content-addressing spec.
-- hash = SHA256( "tricu.merkle.node.v1" <> 0x00 <> node_payload ) -- hash = SHA256( "tricu.merkle.node.v1" <> 0x00 <> node_payload )
nodeHash :: Node -> MerkleHash nodeHash :: Node -> MerkleHash
nodeHash node = bytesToHex (sha256WithPrefix (serializeNode node)) nodeHash node = decodeUtf8 (encode (sha256WithPrefix (serializeNode node)))
where sha256WithPrefix payload = where sha256WithPrefix payload =
convert . (hash :: BS.ByteString -> Digest SHA256) $ utf8Tag <> BS.pack [0x00] <> payload convert . (hash :: BS.ByteString -> Digest SHA256) $ utf8Tag <> BS.pack [0x00] <> payload
utf8Tag = BS.pack $ map fromIntegral $ BS.unpack "tricu.merkle.node.v1" utf8Tag = BS.pack $ map fromIntegral $ BS.unpack "tricu.merkle.node.v1"
-- | Convert a Hex Text hash into raw ByteString (2 hex chars per byte)
hexToBytes :: Text -> BS.ByteString
hexToBytes h = BS.pack $ map combinePair pairs
where
chars = unpack h
pairs = chunkPairs chars
chunkPairs :: String -> [(Char, Char)]
chunkPairs (c1:c2:rest) = (c1, c2) : chunkPairs rest
chunkPairs [] = []
chunkPairs _ = error "hexToBytes: odd number of hex digits"
combinePair :: (Char, Char) -> Word8
combinePair (c1, c2) = fromIntegral (hexDigitToInt c1 * 16 + hexDigitToInt c2)
hexDigitToInt :: Char -> Int
hexDigitToInt c
| '0' <= c && c <= '9' = ord c - ord '0'
| 'a' <= c && c <= 'f' = ord c - ord 'a' + 10
| 'A' <= c && c <= 'F' = ord c - ord 'A' + 10
| otherwise = error $ "Invalid hex digit: " ++ show c
-- | Deserialize a Node from canonical bytes. -- | Deserialize a Node from canonical bytes.
deserializeNode :: BS.ByteString -> Node deserializeNode :: BS.ByteString -> Node
deserializeNode bs = deserializeNode bs =
@@ -115,26 +100,14 @@ deserializeNode bs =
Just (0x01, rest) Just (0x01, rest)
| BS.length rest == 32 -> | BS.length rest == 32 ->
NStem $ bytesToHex rest NStem $ decodeUtf8 (encode rest)
Just (0x02, rest) Just (0x02, rest)
| BS.length rest == 64 -> | BS.length rest == 64 ->
let (l, r) = BS.splitAt 32 rest let (l, r) = BS.splitAt 32 rest
in NFork (bytesToHex l) (bytesToHex r) in NFork (decodeUtf8 (encode l)) (decodeUtf8 (encode r))
_ -> error "invalid merkle node payload" _ -> errorWithoutStackTrace "invalid merkle node payload"
-- | Convert 32-byte ByteString back to hex Text
bytesToHex :: BS.ByteString -> Text
bytesToHex bs = T.pack $ concatMap byteToHexChars $ BS.unpack bs
where
byteToHexChars :: Word8 -> String
byteToHexChars w = [hexDigit (fromIntegral w `div` 16), hexDigit (fromIntegral w `mod` 16)]
hexDigit :: Int -> Char
hexDigit n
| n < 10 = chr (ord '0' + n)
| otherwise = chr (ord 'a' + n - 10)
-- | Build a Merkle DAG from a Tree Calculus term. -- | Build a Merkle DAG from a Tree Calculus term.
buildMerkle :: T -> Node buildMerkle :: T -> Node

75
test/Spec.hs
View File

@@ -32,8 +32,10 @@ tests = testGroup "Tricu Tests"
, providedLibraries , providedLibraries
, fileEval , fileEval
, modules , modules
-- , demos , demos
, decoding , decoding
, elimLambdaSingle
, stressElimLambda
] ]
lexer :: TestTree lexer :: TestTree
@@ -532,7 +534,7 @@ demos = testGroup "Test provided demo functionality"
decodeResult res @?= "\"(t (t (t t) (t t t)) (t t (t t t)))\"" decodeResult res @?= "\"(t (t (t t) (t t t)) (t t (t t t)))\""
, testCase "Determining the size of functions" $ do , testCase "Determining the size of functions" $ do
res <- liftIO $ evaluateFileResult "./demos/size.tri" res <- liftIO $ evaluateFileResult "./demos/size.tri"
decodeResult res @?= "454" decodeResult res @?= "321"
, testCase "Level Order Traversal demo" $ do , testCase "Level Order Traversal demo" $ do
res <- liftIO $ evaluateFileResult "./demos/levelOrderTraversal.tri" res <- liftIO $ evaluateFileResult "./demos/levelOrderTraversal.tri"
decodeResult res @?= "\"\n1 \n2 3 \n4 5 6 7 \n8 11 10 9 12 \"" decodeResult res @?= "\"\n1 \n2 3 \n4 5 6 7 \n8 11 10 9 12 \""
@@ -569,3 +571,72 @@ decoding = testGroup "Decoding Tests"
let input = ofList [ofList [ofString "nested"], ofString "string"] let input = ofList [ofList [ofString "nested"], ofString "string"]
decodeResult input @?= "[[\"nested\"], \"string\"]" decodeResult input @?= "[[\"nested\"], \"string\"]"
] ]
elimLambdaSingle :: TestTree
elimLambdaSingle = testCase "elimLambda preserves eval, fires eta, and SDef binds" $ do
-- 1) eta reduction, purely structural and parsed from source
let [etaIn] = parseTricu "x : f x"
[fRef ] = parseTricu "f"
elimLambda etaIn @?= fRef
-- 2) SDef binds its own name and parameters
let [defFXY] = parseTricu "f x y : f x"
fv = freeVars defFXY
assertBool "f should be bound in SDef" ("f" `Set.notMember` fv)
assertBool "x should be bound in SDef" ("x" `Set.notMember` fv)
assertBool "y should be bound in SDef" ("y" `Set.notMember` fv)
-- 3) semantics preserved on a small program that exercises compose and triage
let src =
unlines
[ "false = t"
, "_ = t"
, "true = t t"
, "id = a : a"
, "const = a b : a"
, "compose = f g x : f (g x)"
, "triage = leaf stem fork : t (t leaf stem) fork"
, "test = triage \"Leaf\" (_ : \"Stem\") (_ _ : \"Fork\")"
, "main = compose id id test"
]
prog = parseTricu src
progElim = map elimLambda prog
evalBefore = result (evalTricu Map.empty prog)
evalAfter = result (evalTricu Map.empty progElim)
evalAfter @?= evalBefore
stressElimLambda :: TestTree
stressElimLambda = testCase "stress elimLambda on wide list under deep curried lambda" $ do
let numVars = 200
numBody = 800
vars = [ "x" ++ show i | i <- [1..numVars] ]
body = "(" ++ unwords (replicate numBody "t") ++ ")"
etaOne = "h : f h"
etaTwo = "k : id k"
defId = "id = a : a"
lambda = unwords vars ++ " : " ++ body
src = unlines
[ defId
, etaOne
, "compose = f g x : f (g x)"
, "f = t t"
, etaTwo
, lambda
, "main = compose id id (" ++ head vars ++ " : f " ++ head vars ++ ")"
]
prog = parseTricu src
let out = map elimLambda prog
let noLambda term = case term of
SLambda _ _ -> False
SApp f g -> noLambda f && noLambda g
SList xs -> all noLambda xs
TFork l r -> noLambda l && noLambda r
TStem u -> noLambda u
_ -> True
assertBool "all lambdas eliminated" (all noLambda out)
let before = result (evalTricu Map.empty prog)
after = result (evalTricu Map.empty out)
after @?= before

6
tricu.cabal
View File

@@ -1,8 +1,8 @@
cabal-version: 1.12 cabal-version: 1.12
name: tricu name: tricu
version: 1.0.0 version: 1.1.0
description: A micro-language for exploring Tree Calculus description: A language for exploring Tree Calculus
author: James Eversole author: James Eversole
maintainer: james@eversole.co maintainer: james@eversole.co
copyright: James Eversole copyright: James Eversole
@@ -27,6 +27,7 @@ executable tricu
base >=4.7 base >=4.7
, aeson , aeson
, ansi-terminal , ansi-terminal
, base16-bytestring
, base64-bytestring , base64-bytestring
, bytestring , bytestring
, cereal , cereal
@@ -71,6 +72,7 @@ test-suite tricu-tests
base >=4.7 base >=4.7
, aeson , aeson
, ansi-terminal , ansi-terminal
, base16-bytestring
, base64-bytestring , base64-bytestring
, bytestring , bytestring
, cereal , cereal