177 lines
4.7 KiB
Haskell
177 lines
4.7 KiB
Haskell
module Research where
|
|
|
|
import Data.List (intercalate)
|
|
import Data.Map (Map)
|
|
import Data.Text (Text, replace)
|
|
import System.Console.CmdArgs (Data, Typeable)
|
|
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Text as T
|
|
|
|
-- Tree Calculus Types
|
|
data T = Leaf | Stem T | Fork T T
|
|
deriving (Show, Eq, Ord)
|
|
|
|
-- Abstract Syntax Tree for tricu
|
|
data TricuAST
|
|
= SVar String
|
|
| SInt Integer
|
|
| SStr String
|
|
| SList [TricuAST]
|
|
| SDef String [String] TricuAST
|
|
| SApp TricuAST TricuAST
|
|
| TLeaf
|
|
| TStem TricuAST
|
|
| TFork TricuAST TricuAST
|
|
| SLambda [String] TricuAST
|
|
| SEmpty
|
|
| SImport String String
|
|
deriving (Show, Eq, Ord)
|
|
|
|
-- Lexer Tokens
|
|
data LToken
|
|
= LKeywordT
|
|
| LIdentifier String
|
|
| LNamespace String
|
|
| LIntegerLiteral Integer
|
|
| LStringLiteral String
|
|
| LAssign
|
|
| LColon
|
|
| LDot
|
|
| LOpenParen
|
|
| LCloseParen
|
|
| LOpenBracket
|
|
| LCloseBracket
|
|
| LNewline
|
|
| LImport String String
|
|
deriving (Show, Eq, Ord)
|
|
|
|
-- Output formats
|
|
data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii | Decode
|
|
deriving (Show, Data, Typeable)
|
|
|
|
-- Environment containing previously evaluated TC terms
|
|
type Env = Map.Map String T
|
|
|
|
-- Tree Calculus Reduction Rules
|
|
{-
|
|
The t operator is left associative.
|
|
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
|
|
-}
|
|
apply :: T -> T -> T
|
|
apply (Fork Leaf a) _ = a
|
|
apply (Fork (Stem a) b) c = apply (apply a c) (apply b c)
|
|
apply (Fork (Fork a b) c) Leaf = a
|
|
apply (Fork (Fork a b) c) (Stem u) = apply b u
|
|
apply (Fork (Fork a b) c) (Fork u v) = apply (apply c u) v
|
|
-- Left associative `t`
|
|
apply Leaf b = Stem b
|
|
apply (Stem a) b = Fork a b
|
|
|
|
-- Booleans
|
|
_false :: T
|
|
_false = Leaf
|
|
|
|
_true :: T
|
|
_true = Stem Leaf
|
|
|
|
_not :: T
|
|
_not = Fork (Fork _true (Fork Leaf _false)) Leaf
|
|
|
|
-- Marshalling
|
|
ofString :: String -> T
|
|
ofString str = ofList $ map (ofNumber . toInteger . fromEnum) str
|
|
|
|
ofNumber :: Integer -> T
|
|
ofNumber 0 = Leaf
|
|
ofNumber n =
|
|
Fork
|
|
(if odd n then Stem Leaf else Leaf)
|
|
(ofNumber (n `div` 2))
|
|
|
|
ofList :: [T] -> T
|
|
ofList = foldr Fork Leaf
|
|
|
|
toNumber :: T -> Either String Integer
|
|
toNumber Leaf = Right 0
|
|
toNumber (Fork Leaf rest) = case toNumber rest of
|
|
Right n -> Right (2 * n)
|
|
Left err -> Left err
|
|
toNumber (Fork (Stem Leaf) rest) = case toNumber rest of
|
|
Right n -> Right (1 + 2 * n)
|
|
Left err -> Left err
|
|
toNumber _ = Left "Invalid Tree Calculus number"
|
|
|
|
toString :: T -> Either String String
|
|
toString tc = case toList tc of
|
|
Right list -> traverse (fmap (toEnum . fromInteger) . toNumber) list
|
|
Left err -> Left "Invalid Tree Calculus string"
|
|
|
|
toList :: T -> Either String [T]
|
|
toList Leaf = Right []
|
|
toList (Fork x rest) = case toList rest of
|
|
Right xs -> Right (x : xs)
|
|
Left err -> Left err
|
|
toList _ = Left "Invalid Tree Calculus list"
|
|
|
|
-- Outputs
|
|
formatT :: EvaluatedForm -> T -> String
|
|
formatT TreeCalculus = toSimpleT . show
|
|
formatT FSL = show
|
|
formatT AST = show . toAST
|
|
formatT Ternary = toTernaryString
|
|
formatT Ascii = toAscii
|
|
formatT Decode = decodeResult
|
|
|
|
toSimpleT :: String -> String
|
|
toSimpleT s = T.unpack
|
|
$ replace "Fork" "t"
|
|
$ replace "Stem" "t"
|
|
$ replace "Leaf" "t"
|
|
$ T.pack s
|
|
|
|
toTernaryString :: T -> String
|
|
toTernaryString Leaf = "0"
|
|
toTernaryString (Stem t) = "1" ++ toTernaryString t
|
|
toTernaryString (Fork t1 t2) = "2" ++ toTernaryString t1 ++ toTernaryString t2
|
|
|
|
toAST :: T -> TricuAST
|
|
toAST Leaf = TLeaf
|
|
toAST (Stem a) = TStem (toAST a)
|
|
toAST (Fork a b) = TFork (toAST a) (toAST b)
|
|
|
|
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
|
|
|
|
decodeResult :: T -> String
|
|
decodeResult Leaf = "t"
|
|
decodeResult tc =
|
|
case (toString tc, toList tc, toNumber tc) of
|
|
(Right s, _, _) | all isCommonChar s -> "\"" ++ s ++ "\""
|
|
(_, _, Right n) -> show n
|
|
(_, Right xs@(_:_), _) -> "[" ++ intercalate ", " (map decodeResult xs) ++ "]"
|
|
(_, Right [], _) -> "[]"
|
|
_ -> formatT TreeCalculus tc
|
|
where
|
|
isCommonChar c =
|
|
let n = fromEnum c
|
|
in (n >= 32 && n <= 126)
|
|
|| n == 9
|
|
|| n == 10
|
|
|| n == 13
|