I will use the dotted-pair notation for clarity. In particular, it highlights certain ways Parenthesis Hell differs from Lisp. However, it must be translated to list notation to be legal Parenthesis Hell.
A Parenthesis Hell program consists of a single expression. Its argument is the program's input. The program's output is the value of the expression.
An expression is either nil, written as (), or a cons pair.
nil, or (), evaluates to the current argument.
A cons pair, (head . tail), is evaluated by looking up head in the current scope, with tail as its argument.
The initial scope defines 7 functions.
| () | quote | (() . expr) |
| (()) | letrec | ((()) (definition-list) . expr) |
| (()()) | cdr | ((()()) . expr) |
| (()()()) | if | ((()()()) cond expr1 . expr2) |
| ((())) | car | (((())) . expr) |
| ((())()) | cons | ((()()) expr1 . expr2) |
| (((()))) | eval | ((((()))) . expr) |
quote, (() . expr), evaluates to the literal expr.
letrec, ((()) (definition-list) . expr), creates a new scope with given definitions, which may shadow definitions in the enclosing scopes, including those in the initial scope, and evalutes to the evaluation of expr in the new scope.
cdr, ((()()) . expr), evaluates to the tail of the evaluation of expr in the current scope. If expr evaluates to nil, the value is nil.
if, ((()()()) cond expr1 . expr2), evaluates to the evaluation of expr1 in the current scope if the evaluation of cond in the current scope is not nil, otherwise it evaluates to the evaluation of expr2 in the current scope. If (cond expr1 . expr2) is nil or if (expr1 . expr2) is nil, the value is nil.
car, (((())) . expr), evaluates to the head of the evaluation of expr in the current scope. If expr evaluates to nil, the value is nil.
cons, (((())()) expr1 . expr2), evaluates to the cons of the evaluation of expr1 and the evaluation of expr2 in the current scope.
If (expr1 . expr2) is nil, the value is nil.
eval, ((((()))) . expr), evaluates to the evaluation of the evaluation of expr in the current scope. Obligatory in languages where code is data.
Creating new scopes
In a new letrec scope, ((()) (definition-list) . expr), definition-list is a list of (name . body), where name is defined
within the scope, which includes the bodies in the definition-list. When name is invoked as (name . expr), the evaluation of expr in the current scope becomes the argument, referred to by (), in scope of name's body. The value of (name . expr) is value of body evaluated in the scope of name's body. nils in the definition-list are ignored.
Extensions
The initial scope can optionally define additional functions.
concat
concat, ((()(())) expr1 . expr2), takes the evaluation of expr1 and the evaluation expr2 in the current scope as output, and returns a value that would output the bits of expr1, followed by the bits of expr2. An approximate implementation in Parenthesis Hell, which does not evaluate expr1 and expr2 separately, is
((())(((())(()()())(((())))((()()())(((()))((())))(((())())(((
))((())())(((()))((())))(()()))())(()()())((()())((())))(((())
())(())(())((())())((()())((())))(()()))(()()))(()())))(()))
(ph-concat . (((())()) expr1 . expr2)), or (ph-concat . (cons expr1 . expr2)), is equivalent to (concat expr1 . expr2). The Parenthesis Hell implementation can use huge amounts of memory, having implementing concat in the interpreter enables some code that would otherwise cause out of memory errors.
Example code
cat:
()
Hello world:
(()()(()()(()()()()((()()(()(()((()((()()()((()((()()()((()((((()()(()(
)()()()()(((()(((()((()((((()(((()()(()()((()((()()()((()()(()()()()(()
()()()(()()()()(()(())))))))))))))))))))))))))))))))))))))))))))))))))
quine:
((())(((())()((())())(()())((())())(((())())(((())())(()())((())())(())(()))()
)(())))((())())(()())((())())(((())())(((())())(()())((())())(())(()))())(()))
An interpreter, written in Haskell
I wrote it in multiple modules, but crammed everything into a single module for this post.
module Main(main) where
import Data.Bits(bit,testBit)
import Data.Char(chr,ord)
import Prelude hiding (lookup,head,tail)
import System.Environment(getArgs)
data Value = Nil | Cons Value Value
instance Show Value where
show a = '(' : shows a ")" where
shows Nil s = s
shows (Cons a b) s = '(' : shows a (')' : shows b s)
isNil :: Value -> Bool
isNil Nil = True
isNil _ = False
car :: Value -> Value
car (Cons a _) = a
car Nil = Nil
cdr :: Value -> Value
cdr (Cons _ b) = b
cdr Nil = Nil
instance Read Value where
readsPrec p s@('(':_) = [readNext s]
readsPrec p (_:s) = readsPrec p s
readsPrec p [] = []
readNext :: String -> (Value,String)
readNext ('(':s) = readNext' s
where
readNext' ('(':s) =
let (car,s') = readNext' s
(cdr,s'') = readNext' s'
in (Cons car cdr,s'')
readNext' (')':s) = (Nil,s)
readNext' (_:s) = readNext' s
readNext' [] = error "unmatched ("
readNext (')':_) = error "unmatched )"
readNext (_:s) = readNext s
readNext [] = error "unmatched ("
strToValue :: String -> Value
strToValue [] = Cons Nil Nil
strToValue (c:cs) = bitsToValue [7,6..0] c
where
bitsToValue [] _ = strToValue cs
bitsToValue (b:bs) byte =
(if testBit (ord c) b then Cons else flip Cons)
(bitsToValue bs byte) Nil
valueToStr :: Value -> String
valueToStr value = valueToBits [7,6..0] 0 value
where
valueToBits [] byte rest = chr byte : valueToStr rest
valueToBits _ _ Nil = []
valueToBits (_:bs) byte (Cons Nil rest) = valueToBits bs byte rest
valueToBits (b:bs) byte (Cons rest _) = valueToBits bs (byte + bit b) rest
data ValueTrie a = ValueTrie (ValueTrie a) (ValueTrie a) (Maybe a) | Empty
head Empty = Empty
head (ValueTrie hd _ _) = hd
tail Empty = Empty
tail (ValueTrie _ tl _) = tl
value Empty = Nothing
value (ValueTrie _ _ val) = val
empty :: ValueTrie a
empty = Empty
insert :: ValueTrie a -> Value -> a -> ValueTrie a
insert trie key val =
let insertValue trie = ValueTrie (head trie) (tail trie) (Just val)
in insert' trie key insertValue
insert' :: ValueTrie a -> Value -> (ValueTrie a -> ValueTrie a) -> ValueTrie a
insert' trie Nil insertValue = insertValue trie
insert' trie (Cons hd tl) insertValue =
let insertTail trie' =
ValueTrie (head trie')
(insert' (tail trie') tl insertValue)
(value trie')
in ValueTrie (insert' (head trie) hd insertTail) (tail trie) (value trie)
lookup :: ValueTrie a -> Value -> Maybe a
lookup = lookup' value
lookup' :: (ValueTrie a -> b) -> ValueTrie a -> Value -> b
lookup' value Empty _ = value Empty
lookup' value trie Nil = value trie
lookup' value trie (Cons hd tl) =
case lookup' id (head trie) hd of
Empty -> value Empty
trie' -> lookup' value (tail trie') tl
data Scope a b = Root | Nested (Scope a b) (a -> Maybe b)
root :: (a -> Maybe b) -> Scope a b
root = Nested Root
nested :: Scope a b -> (a -> Maybe b) -> Scope a b
nested = Nested
get :: Show a => Scope a b -> a -> b
get scope@(Nested outer getValue) name =
case getValue name of
Just value -> value
Nothing -> get outer name
get Root name = error (show name)
data Op = Op (Value -> Scope Value Op -> Value -> Value)
op (Op op) = op
rootScope :: Scope Value Op
rootScope = root getBinding where
getBinding Nil = Just (Op quoteOp)
getBinding (Cons Nil Nil) = Just (Op letOp)
getBinding (Cons Nil (Cons Nil Nil)) = Just (Op cdrOp)
getBinding (Cons Nil (Cons Nil (Cons Nil Nil))) = Just (Op ifOp)
getBinding (Cons Nil (Cons (Cons Nil Nil) Nil)) = Just (Op concatOp)
getBinding (Cons (Cons Nil Nil) Nil) = Just (Op carOp)
getBinding (Cons (Cons Nil Nil) (Cons Nil Nil)) = Just (Op consOp)
getBinding (Cons (Cons (Cons Nil Nil) Nil) Nil) = Just (Op evalOp)
getBinding _ = Nothing
quoteOp input scope arg = arg
letOp input scope Nil = Nil
letOp input scope (Cons bindings letBody) =
let bindingList Nil = empty
bindingList (Cons Nil rest) = bindingList rest
bindingList (Cons (Cons name body) rest) =
let definedOp input scope arg =
eval (eval input scope arg) letScope body
in insert (bindingList rest) name (Op definedOp)
letScope = nested scope (lookup (bindingList bindings))
in eval input letScope letBody
cdrOp input scope arg = cdr (eval input scope arg)
ifOp input scope Nil = Nil
ifOp input scope (Cons _ Nil) = Nil
ifOp input scope (Cons cond body)
| isNil (eval input scope cond) = eval input scope (cdr body)
| otherwise = eval input scope (car body)
carOp input scope arg = car (eval input scope arg)
consOp input scope Nil = Nil
consOp input scope (Cons head tail) =
Cons (eval input scope head) (eval input scope tail)
evalOp input scope arg = eval input scope (eval input scope arg)
concatOp input scope Nil = Nil
concatOp input scope (Cons head tail) =
let concat Nil rest = rest
concat (Cons Nil Nil) rest = rest
concat (Cons Nil tl) rest = Cons Nil (concat tl rest)
concat (Cons hd tl) rest = Cons (concat hd rest) tl
in concat (eval input scope head) (eval input scope tail)
eval input scope Nil = input
eval input scope expr = (op (get scope (car expr))) input scope (cdr expr)
main :: IO ()
main = do
args <- getArgs
(toStr,code,arg) <- processArgs valueToStr args
putStr $ toStr $ eval arg rootScope code
processArgs :: (Value -> String) -> [String] -> IO (Value -> String,Value,Value)
processArgs toStr [] = do
src <- getContents
return (toStr, read src, Nil)
processArgs _ ("-v":args) = processArgs show args
processArgs toStr (file:_) = do
src <- readFile file
input <- getContents
return (toStr, read src, strToValue input)
No comments:
Post a Comment