Initialize Repo

Working (but likely buggy!) lexing, parsing, and evaluation of Tree Calculus terms

src/Eval.hs

@@ -0,0 +1,10 @@
+module Eval where
+
+import Parser
+import Research
+
+evalSapling :: SaplingAST -> T
+evalSapling TLeaf = Leaf
+evalSapling (TStem t) = Stem (evalSapling t)
+evalSapling (TFork t1 t2) = Fork (evalSapling t1) (evalSapling t2)
+evalSapling _ = error "Evaluation currently only supported for Tree Calculus terms."

src/Lexer.hs

@@ -0,0 +1,77 @@
+module Lexer where
+
+import Research
+import Text.Megaparsec
+import Text.Megaparsec.Char
+import Data.Void
+
+type Lexer = Parsec Void String
+data LToken
+  = LKeywordT
+  | LIdentifier String
+  | LIntegerLiteral Int
+  | LStringLiteral String
+  | LAssign
+  | LOpenParen
+  | LCloseParen
+  | LOpenBracket
+  | LCloseBracket
+  | LNewline
+  deriving (Show, Eq, Ord)
+
+keywordT :: Lexer LToken
+keywordT = string "t" *> notFollowedBy alphaNumChar *> pure LKeywordT
+
+identifier :: Lexer LToken
+identifier = do
+  name <- some (letterChar <|> char '_' <|> char '-')
+  if name == "t"
+    then fail "Keyword 't' cannot be used as an identifier"
+    else return (LIdentifier name)
+
+integerLiteral :: Lexer LToken
+integerLiteral = do
+  num <- some digitChar
+  return (LIntegerLiteral (read num))
+
+stringLiteral :: Lexer LToken
+stringLiteral = do
+  char '"'
+  content <- many (noneOf ['"'])
+  char '"' --"
+  return (LStringLiteral content)
+
+assign :: Lexer LToken
+assign = char '=' *> pure LAssign
+
+openParen :: Lexer LToken
+openParen = char '(' *> pure LOpenParen
+
+closeParen :: Lexer LToken
+closeParen = char ')' *> pure LCloseParen
+
+openBracket :: Lexer LToken
+openBracket = char '[' *> pure LOpenBracket
+
+closeBracket :: Lexer LToken
+closeBracket = char ']' *> pure LCloseBracket
+
+lnewline :: Lexer LToken
+lnewline = char '\n' *> pure LNewline
+
+sc :: Lexer ()
+sc = skipMany (char ' ' <|> char '\t')
+
+saplingLexer :: Lexer [LToken]
+saplingLexer = many (sc *> choice
+  [ try keywordT
+  , try identifier
+  , try integerLiteral
+  , try stringLiteral
+  , assign
+  , openParen
+  , closeParen
+  , openBracket
+  , closeBracket
+  , lnewline
+  ]) <* eof

src/Main.hs

@@ -0,0 +1,11 @@
+module Main where
+
+import Eval
+import Lexer
+import Parser
+import Research
+
+import Text.Megaparsec (runParser)
+
+main :: IO ()
+main = putStr $ show $ parseSapling "false = t"

src/Parser.hs

@@ -0,0 +1,131 @@
+module Parser where
+
+import Lexer
+import Research
+import Text.Megaparsec
+import Text.Megaparsec.Char
+import Data.Void
+
+type Parser = Parsec Void [LToken]
+data SaplingAST
+  = SVar String
+  | SInt Int
+  | SStr String
+  | SList [SaplingAST]
+  | SFunc String [String] SaplingAST
+  | SApp SaplingAST [SaplingAST]
+  | TLeaf
+  | TStem SaplingAST
+  | TFork SaplingAST SaplingAST
+  deriving (Show, Eq, Ord)
+
+parseSapling :: String -> SaplingAST
+parseSapling input = case runParser saplingLexer "" input of
+  Left err -> error "RIP"
+  Right tokens -> case runParser parseExpression "" tokens of
+    Left err -> error "RIP"
+    Right ast -> ast
+
+scnParser :: Parser ()
+scnParser = skipMany (satisfy isNewline)
+
+parseExpression :: Parser SaplingAST
+parseExpression = choice
+  [ try parseFunction
+  , try parseApplication
+  , parseTreeTerm
+  , parseLiteral
+  , parseListLiteral
+  ]
+
+parseFunction :: Parser SaplingAST
+parseFunction = do
+  LIdentifier name <- satisfy isIdentifier
+  args <- many (satisfy isIdentifier)
+  satisfy (== LAssign)
+  body <- parseExpression
+  return (SFunc name (map getIdentifier args) body)
+
+parseApplication :: Parser SaplingAST
+parseApplication = do
+  func <- parseAtomic
+  args <- many parseAtomic
+  return (SApp func args)
+
+getIdentifier :: LToken -> String
+getIdentifier (LIdentifier name) = name
+getIdentifier _ = error "Expected identifier"
+
+parseTreeTerm :: Parser SaplingAST
+parseTreeTerm = do
+  base <- parseTreeLeafOrParenthesized
+  rest <- many parseTreeLeafOrParenthesized
+  pure $ foldl combine base rest
+  where
+    combine acc next = case acc of
+      TLeaf     -> TStem next
+      TStem t   -> TFork t next
+      TFork _ _ -> TFork acc next
+
+parseTreeLeafOrParenthesized :: Parser SaplingAST
+parseTreeLeafOrParenthesized = choice
+  [ between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseTreeTerm
+  , satisfy isKeywordT *> pure TLeaf
+  ]
+
+foldTree :: [SaplingAST] -> SaplingAST
+foldTree [] = TLeaf
+foldTree [x] = x
+foldTree (x:y:rest) = TFork x (foldTree (y:rest))
+
+parseAtomic :: Parser SaplingAST
+parseAtomic = choice
+  [ parseVar
+  , parseLiteral
+  , parseListLiteral
+  , between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression
+  ]
+
+parseLiteral :: Parser SaplingAST
+parseLiteral = choice
+  [ parseIntLiteral
+  , parseStrLiteral
+  ]
+
+parseListLiteral :: Parser SaplingAST
+parseListLiteral = do
+  satisfy (== LOpenBracket) 
+  elements <- sepEndBy parseExpression scnParser
+  satisfy (== LCloseBracket)
+  return (SList elements)
+
+parseVar :: Parser SaplingAST
+parseVar = do 
+  LIdentifier name <- satisfy isIdentifier
+  return (SVar name)
+
+parseIntLiteral :: Parser SaplingAST
+parseIntLiteral = do
+  LIntegerLiteral value <- satisfy isIntegerLiteral
+  return (SInt value)
+
+parseStrLiteral :: Parser SaplingAST
+parseStrLiteral = do
+  LStringLiteral value <- satisfy isStringLiteral
+  return (SStr value)
+
+isKeywordT        (LKeywordT)        = True
+isKeywordT                        _  = False
+
+isIdentifier      (LIdentifier    _) = True
+isIdentifier                      _  = False
+
+isIntegerLiteral (LIntegerLiteral _) = True
+isIntegerLiteral                  _  = False
+
+isStringLiteral  (LStringLiteral  _) = True
+isStringLiteral                   _  = False
+
+isNewline        (LNewline)          = True
+isNewline                         _  = False
+

src/Research.hs

@@ -0,0 +1,142 @@
+module Research where
+
+import Data.List (intercalate)
+import Control.Monad.State
+import qualified Data.Map as Map
+import Data.Map (Map)
+
+data T
+  = Leaf     -- t
+  | Stem T   -- t t
+  | Fork T T -- t a b
+  deriving (Show, Eq, Ord)
+
+apply :: T -> T -> T
+apply Leaf b                            = Stem b
+apply (Stem a) b                        = Fork a b
+apply (Fork Leaf a) _                   = a
+apply (Fork (Stem a1) a2) b             = apply (apply a1 b) (apply a2 b)
+apply (Fork (Fork a1 a2) a3) Leaf       = a1
+apply (Fork (Fork a1 a2) a3) (Stem u)   = apply a2 u
+apply (Fork (Fork a1 a2) a3) (Fork u v) = apply (apply a3 u) v
+
+reduce :: T -> T
+reduce expr =
+  let next = step expr
+  in if next == expr then expr else reduce next
+
+step :: T -> T
+step (Fork left right) = reduce (apply (reduce left) (reduce right))
+step (Stem inner) = Stem (reduce inner) 
+step t = t 
+
+-- SKI Combinators
+_S :: T
+_S = Fork (Stem (Fork Leaf Leaf)) Leaf
+
+_K :: T
+_K = Stem Leaf
+
+_I :: T
+_I = apply (apply _S _K) _K -- Fork (Stem (Stem Leaf)) (Stem Leaf)
+
+-- Lambda
+data Lambda
+  = Var String
+  | App Lambda Lambda
+  | Lam String Lambda
+  | TC T
+  deriving (Show, Eq)
+
+-- Booleans
+_false :: T
+_false = Leaf
+
+_true :: T
+_true = Stem Leaf
+
+_not :: T
+_not = Fork (Fork _true (Fork Leaf _false)) Leaf
+
+-- Marshalling
+toString :: String -> T
+toString str = toList (map toNumber (map fromEnum str))
+
+ofString :: T -> String
+ofString tc = map (toEnum . ofNumber) (ofList tc)
+
+toNumber :: Int -> T 
+toNumber 0 = Leaf
+toNumber n =
+  Fork
+    (if odd n then Stem Leaf else Leaf)
+    (toNumber (n `div` 2)) 
+
+ofNumber :: T -> Int
+ofNumber Leaf = 0
+ofNumber (Fork Leaf rest) = 2 * ofNumber rest
+ofNumber (Fork (Stem Leaf) rest) = 1 + 2 * ofNumber rest
+ofNumber _ = error "Invalid Tree Calculus number" 
+
+toList :: [T] -> T 
+toList [] = Leaf
+toList (x:xs) = Fork x (toList xs)
+
+ofList :: T -> [T]
+ofList Leaf = []
+ofList (Fork x rest) = x : ofList rest
+ofList _ = error "Invalid Tree Calculus list"
+
+-- Utility
+toAscii :: T -> String
+toAscii tree = go tree "" True
+  where
+    go :: T -> String -> Bool -> String
+    go Leaf prefix isLast =
+      prefix ++ (if isLast then "`-- " else "|-- ") ++ "Leaf\n"
+    go (Stem t) prefix isLast =
+      prefix ++ (if isLast then "`-- " else "|-- ") ++ "Stem\n"
+        ++ go t (prefix ++ (if isLast then "    " else "|   ")) True
+    go (Fork left right) prefix isLast =
+      prefix ++ (if isLast then "`-- " else "|-- ") ++ "Fork\n"
+        ++ go left (prefix ++ (if isLast then "    " else "|   ")) False
+        ++ go right (prefix ++ (if isLast then "    " else "|   ")) True
+
+rules :: IO ()
+rules = putStr $ header 
+              ++ (unlines $ tcRules) 
+              ++ (unlines $ haskellRules)
+              ++ footer
+  where
+    tcRules :: [String]
+    tcRules = 
+      [ "|                                                                               |"
+      , "|                  ┌--------- | Tree Calculus | ---------┐                      |"
+      , "|                  | 1.  t  t      a b       -> a        |                      |"
+      , "|                  | 2.  t (t a)   b c       -> a c (b c)|                      |"
+      , "|                  | 3a. t (t a b) c t       -> a        |                      |"
+      , "|                  | 3b. t (t a b) c (t u)   -> b u      |                      |"
+      , "|                  | 3c. t (t a b) c (t u v) -> c u v    |                      |"
+      , "|                  └-------------------------------------┘                      |"
+      , "|                                                                               |"
+      ]
+    haskellRules :: [String]
+    haskellRules =
+      [ "| ┌------------------------------ | Haskell | --------------------------------┐ |"
+      , "| |                                                                           | |"
+      , "| | data T = Leaf | Stem T | Fork TT                                          | |"
+      , "| |                                                                           | |"
+      , "| | apply :: T -> T -> T                                                      | |"
+      , "| | apply Leaf b                            = Stem b                          | |"
+      , "| | apply (Stem a) b                        = Fork a b                        | |"
+      , "| | apply (Fork Leaf a) _                   = a                               | |"
+      , "| | apply (Fork (Stem a1) a2) b             = apply (apply a1 b) (apply a2 b) | |"
+      , "| | apply (Fork (Fork a1 a2) a3) Leaf       = a1                              | |"
+      , "| | apply (Fork (Fork a1 a2) a3) (Stem u)   = apply a2 u                      | |"
+      , "| | apply (Fork (Fork a1 a2) a3) (Fork u v) = apply (apply a3 u) v            | |"
+      , "| └---------------------------------------------------------------------------┘ |"
+      ]
+    header :: String
+    header = "┌-------------------- | Rules for evaluating Tree Calculus | -------------------┐\n"
+    footer :: String
+    footer = "└-------------------- | Rules for evaluating Tree Calculus | -------------------┘\n"