Talk:Anemone
(Redirected from Talk:Defcalc)
An implementation of Defcalc
Notes
Given:
and t t = t. and X Y = f.
results in
and (and t t) t => f
My initial interpretation of "the outer-most reducible term" results in different semantics than what the fibonacci example implies. Changing search in my implementation from breadth-first to depth-first allows it to match the fibonacci example.
- (I think the "outer-most reducible term" thing just means you have to evaluate the operands before the function. --Koen (talk) 02:32, 20 September 2012 (UTC)
Breadth-first:
and (cons (and t t) (and t t)) (and t t) and (cons (and t t) (and t t)) t and (cons t (and t t)) t and (cons t t) t
Depth-first:
and (cons (and t t) (and t t)) (and t t) and (cons t (and t t)) (and t t) and (cons t t) (and t t) and (cons t t) t
Code
module Main(main) where
import System.Environment(getArgs)
import Text.ParserCombinators.Parsec(Parser,char,many,many1,noneOf,oneOf,parse,spaces,(<|>))
main :: IO ()
main = do
(src:_) <- getArgs
fmap (rules src) (readFile src) >>= either putStrLn (interact . repl)
repl :: [Rule] -> String -> String
repl rules input = unlines (map (unlines . eval rules) (lines input))
eval :: [Rule] -> String -> [String]
eval rules input =
either (:[]) (map show . apply rules) (terms "(input)" input)
-- Expr
data Expr = Expr [Expr] | Atom String | Variable String deriving Eq
data Rule = Rule Expr Expr
canonical :: Expr -> Expr
canonical (Expr [expr]) = canonical expr
canonical (Expr ((Expr expr):exprs)) = canonical (Expr (expr ++ exprs))
canonical (Expr exprs) = Expr (map canonical exprs)
canonical expr = expr
instance Show Expr where
showsPrec prec (Expr expr) =
showParen (prec > 0) (unwords (map (flip (showsPrec 1) "") expr) ++)
showsPrec _ (Atom atom) = showString atom
showsPrec _ (Variable variable) = showString variable
instance Show Rule where
showsPrec _ (Rule lhs rhs) =
shows lhs . showString " = " . shows rhs . showChar '.'
-- Rules
data ResultTree a = NoResult | Result a | DeeperResult [ResultTree a]
instance Functor ResultTree where
fmap _ NoResult = NoResult
fmap f (Result a) = Result (f a)
fmap f (DeeperResult as) = DeeperResult (map (fmap f) as)
search :: ResultTree a -> Maybe a
search NoResult = Nothing
search (Result a) = Just a
search (DeeperResult as) =
let search' [] = Nothing
search' (NoResult:as') = search' as'
search' ((Result a):_) = Just a
search' ((DeeperResult deeper):as') = search' (as' ++ deeper)
-- for depth-first search, replace the preceding 3 lines with:
-- search' (a:as) = maybe (search' as) Just (search a)
in search' as
apply :: [Rule] -> Expr -> [Expr]
apply rules expr =
maybe [] (\ exp' -> exp' : apply rules exp') (search (apply1 rules expr))
apply1 :: [Rule] -> Expr -> ResultTree Expr
apply1 rules expr =
maybe (applySubexprs rules expr) (Result . canonical) (applyTop rules expr)
applySubexprs :: [Rule] -> Expr -> ResultTree Expr
applySubexprs rules (Expr exprs) =
let applyEach _ [] = []
applyEach pre (expr:exprs) =
fmap (Expr . (reverse pre ++) . (:exprs)) (apply1 rules expr)
: applyEach (expr:pre) exprs
in DeeperResult (applyEach [] exprs)
applySubexprs rules _ = NoResult
applyTop :: [Rule] -> Expr -> Maybe Expr
applyTop [] _ = Nothing
applyTop ((Rule pattern replacement):rules) expr =
maybe (applyTop rules expr)
(Just . replace replacement)
(match True pattern expr [])
match :: Bool -> Expr -> Expr -> [(String,Expr)] -> Maybe [(String,Expr)]
match top (Expr pattern) (Expr terms) bindings =
match' top pattern terms bindings
match top (Variable variable) term bindings =
maybe (Just ((variable,term):bindings))
(\ value -> if value == term then Just bindings else Nothing)
(lookup variable bindings)
match _ pattern term bindings =
if pattern == term then Just bindings else Nothing
match' :: Bool -> [Expr] -> [Expr] -> [(String,Expr)] -> Maybe [(String,Expr)]
match' top (pattern:patterns) (term:terms) bindings =
maybe Nothing (match' top patterns terms)
(match False pattern term bindings)
match' _ [] [] bindings = Just bindings
match' True [] terms bindings = Just (("",Expr terms):bindings)
match' _ _ _ _ = Nothing
replace :: Expr -> [(String,Expr)] -> Expr
replace expr bindings =
maybe (substitute bindings expr)
(appendExpr (substitute bindings expr))
(lookup "" bindings)
substitute :: [(String,Expr)] -> Expr -> Expr
substitute _ expr@(Atom _) = expr
substitute bindings (Variable variable) =
maybe (error ("unbound variable: " ++ variable)) id
(lookup variable bindings)
substitute bindings (Expr exprs) =
Expr (map (substitute bindings) exprs)
appendExpr :: Expr -> Expr -> Expr
appendExpr (Expr exprs1) (Expr exprs2) = Expr (exprs1 ++ exprs2)
appendExpr (Expr exprs1) expr2 = Expr (exprs1 ++ [expr2])
appendExpr expr1 (Expr exprs2) = Expr (expr1 : exprs2)
appendExpr expr1 expr2 = Expr [expr1, expr2]
-- Parser
f <$> a = fmap f a
f <*> a = f >>= (<$> a)
a *> b = a >> b
a <* b = const <$> a <*> b
infixl 4 <$>
infixl 4 <*>
infixl 4 *>
infixl 4 <*
ch :: Char -> Parser Char
ch c = char c <* spaces
atom :: Parser Expr
atom = Atom <$> ((:) <$> noneOf (" \t\r\n.=()" ++ ['A'..'Z'])
<*> many (noneOf " \t\r\n.=()")
<* spaces)
variable :: Parser Expr
variable = Variable <$> ((:) <$> oneOf ['A'..'Z']
<*> many (noneOf " \t\r\n.=()")
<* spaces)
rule :: Parser Rule
rule = Rule <$> ((canonical . Expr) <$> many1 expr) <* ch '='
<*> ((canonical . Expr) <$> many1 expr) <* ch '.'
expr :: Parser Expr
expr = Expr <$> (ch '(' *> many1 expr <* ch ')') <|> atom <|> variable
rules :: String -> String -> Either String [Rule]
rules source contents =
either (Left . show) Right (parse (spaces *> many1 rule) source contents)
term :: Parser Expr
term = Expr <$> (ch '(' *> many1 term <* ch ')') <|> atom
terms :: String -> String -> Either String Expr
terms source contents =
either (Left . show) (Right . canonical . Expr)
(parse (spaces *> many1 term) source contents)
--Qpliu 02:08, 4 February 2010 (UTC)
- Thanks for the great feedback. That AND did need to be changed--though I needed a simple way to explain that order of rules is important. I've now used the "equals" predicate for this purpose.
- Breadth-first is correct. However, my Fibonacci example was not correct, simply because of my carelessness in evaluating the examples manually, as I had not yet written an interpreter. Now that there is one, that problem is solved, though I am experiencing some difficulties with the interpreter, namely that SKI combinator logic does not work as it should.
- Once again, thanks! --Afarnen 09:03, 6 February 2010 (UTC)
- Yeah, there's a bug in the code. I think it should be fixed now.
- The eq example also has non-intuitive results, for example
eq (eq eq eq) t => f
- --Qpliu 05:11, 7 February 2010 (UTC)
- You would expect those kind of results when you don't have types. I left algebraic data types out of the wiki, as I'm not sure how exactly I would implement them. I might do, for example, Boolean algebra like this:
- --Qpliu 05:11, 7 February 2010 (UTC)
bool (not (bool t)) = bool f. bool (not (bool f)) = bool t. bool (and (bool t) (bool X)) = bool X. bool (and (bool f) (bool X)) = bool f. bool (or (bool t) (bool X)) = bool t. bool (or (bool f) (bool X)) = bool X.
- wrapping all data with "type" atoms. A test run:
bool (and (bool t) (bool (or (bool (not (bool f))) (bool f)))) bool (or (bool (not (bool f))) (bool f)) bool (or (bool t) (bool f)) bool t
- However, this prevents Currying with "wrapped" terms. A better way might be (note the use of "typed" SKI combinators):
X i (X Y) = X Y. X k (X Y) (X Z) = X Y. bool not (bool t) = bool f. bool not (bool f) = bool t. bool and (bool t) = bool i. bool and (bool f) = bool k (bool f). bool or (bool t) = bool k (bool t). bool or (bool f) = bool i.
- It may be to your surprise, as I haven't made it clear before, but those first two rules are perfectly valid--though your interpreter doesn't like them. The same expression, with this new type encoding:
bool and (bool t) (bool or (bool not (bool f)) (bool f)) bool i (bool or (bool not (bool f)) (bool f)) bool or (bool not (bool f)) (bool f) bool or (bool t) (bool f) bool k (bool t) (bool f) bool t
- I'm going to explore this concept further. The language itself is completely finished, but at the moment I haven't written any formal or complete documentation because I'm not sure how one would use it practically. --Afarnen 09:46, 7 February 2010 (UTC)
- P.S. The code works great! --Afarnen 09:48, 7 February 2010 (UTC)
- Disallowing rules starting with variables actually made the parser slightly more complicated. --Qpliu 01:55, 11 February 2010 (UTC)
A second, complete interpreter
Here's my interpreter that I wrote in Python (it's a little long, since I wrote the parser from scratch, and it catches all syntax errors). It even allows rules that start with variables. It's poorly documented at the moment:
#! /usr/bin/python
"""
Defcalc interpreter v0.1 by Andrew Farnen
Usage:
defcalc.py [input-file-0] [input-file-1] [input-file-2] ...
"""
# for reading input files
import sys
# for breadth-first search
from collections import deque
# tokens
class token:
def __init__(self, name, line, col):
self.name = name
self.line = line
self.col = col
def __str__(self):
return self.name
class l_paren(token):
pass
class r_paren(token):
pass
class equals(token):
pass
class period(token):
pass
class string(token):
pass
class eof(token):
pass
# syntax
class atom:
def __init__(self, name):
self.name = name
def __str__(self, outer):
return self.name
class var:
def __init__(self, name):
self.name = name
def __str__(self, outer):
return self.name
class app:
def __init__(self, left, right):
self.left = left
self.right = right
def __str__(self, outer):
ret =
if outer == 0:
ret = '('
ret += self.left.__str__(isinstance(self.left, app)) + ' ' + self.right.__str__(0)
if outer == 0:
ret += ')'
return ret
class rule:
def __init__(self, left, right):
self.left = left
self.right = right
def __str__(self):
return self.left.__str__(1) + ' = ' + self.right.__str__(1) + '. '
class syntax_error(Exception):
def __init__(self, message):
self.message = message
class empty(Exception):
pass
# tokenize string, returning list of tokens
def tokenize(s):
tokens = []
line = 0
col = 0
pos = 0
strflag = 0
for pos, char in enumerate(s):
if char == '\n':
line += 1
if strflag == 1:
if char.isspace() or char in '()=.':
tokens.append(string(s[start:pos], line, startcol))
strflag = 0
if strflag == 0:
if not char.isspace():
if char == '(':
tokens.append(l_paren('(', line, col))
elif char == ')':
tokens.append(r_paren(')', line, col))
elif char == '=':
tokens.append(equals('=', line, col))
elif char == '.':
tokens.append(period('.', line, col))
else:
strflag = 1
start = pos
startcol = col
if char == '\n':
col = 0
else:
col += 1
if strflag == 1:
tokens.append(string(s[start:], line, start))
tokens.append(eof(, line, col))
return tokens
# parse term from list of tokens, returning either atom, var or app
def parse(tokens, start, end, accept_vars, filename):
if start == end:
raise empty()
if isinstance(tokens[end], l_paren) or isinstance(tokens[end], equals) or isinstance(tokens[end], period):
raise syntax_error("Syntax error (" + filename + ", line " + str(tokens[end].line) + ", col " + str(tokens[end].col) + "): unexpected `" + tokens[end].name + "'")
if isinstance(tokens[end], string):
if tokens[end].name[0].isupper():
if accept_vars == 0:
raise syntax_error("Syntax error (" + filename + ", line " + str(tokens[end].line) + ", col " + str(tokens[end].col) + "): unexpected var `" + tokens[end].name + "'")
right = var(tokens[end].name)
else:
right = atom(tokens[end].name)
right_empty = 0
pos = end - 1
elif isinstance(tokens[end], r_paren):
right_empty = 1
depth = 1
pos = end - 1
token = tokens[pos]
while pos > start and depth > 0:
if isinstance(token, r_paren):
depth += 1
elif isinstance(token, l_paren):
depth -= 1
if depth < 0:
raise syntax_error("Syntax error (" + filename + ", line " + str(token.line) + ", col " + str(token.col) + "): unmatched parentheses")
elif isinstance(token, equals) or isinstance(token, period):
raise syntax_error("Syntax error (" + filename + ", line " + str(token.line) + ", col " + str(token.col) + "): unexpected `" + token.name + "'")
elif isinstance(token, string):
right_empty = 0
pos -= 1
token = tokens[pos]
if depth > 0:
raise syntax_error("Syntax error (" + filename + ", line " + str(token.line) + ", col " + str(token.col) + "): unmatched parentheses")
if not right_empty:
right = parse(tokens, pos + 1, end - 1, accept_vars, filename)
if pos == start:
if right_empty:
raise empty()
return right
left_empty = 1
depth = 0
left_end = pos
token = tokens[pos]
while pos > start:
if isinstance(token, r_paren):
depth += 1
elif isinstance(token, l_paren):
depth -= 1
if depth < 0:
raise syntax_error("Syntax error (" + filename + ", line " + str(token.line) + ", col " + str(token.col) + "): unmatched parentheses")
elif isinstance(token, equals) or isinstance(token, period):
raise syntax_error("Syntax error (" + filename + ", line " + str(token.line) + ", col " + str(token.col) + "): unexpected `" + token.name + "'")
elif isinstance(token, string):
left_empty = 0
pos -= 1
token = tokens[pos]
if depth > 0:
raise syntax_error("Syntax error (" + filename + ", line " + str(token.line) + ", col " + str(token.col) + "): unmatched parentheses")
if not left_empty:
left = parse(tokens, start, left_end, accept_vars, filename)
if left_empty:
if right_empty:
raise empty()
return right
if right_empty:
return left
return app(left, right)
# parse rules from list of tokens, returning list of rules
def parse_rules(tokens, filename):
rules = []
start = 0
mode = 0
for pos, token in enumerate(tokens):
if mode == 0:
if isinstance(token, eof):
if pos != start:
raise syntax_error("Syntax error (" + filename + ", line " + str(token.line) + ", col " + str(token.col) + "): unexpected end of input")
break
if isinstance(token, period):
raise syntax_error("Syntax error (" + filename + ", line " + str(token.line) + ", col " + str(token.col) + "): unexpected `" + token.name + "'")
if isinstance(token, equals):
if pos == start:
raise syntax_error("Syntax error (" + filename + ", line " + str(token.line) + ", col " + str(token.col) + "): left-hand side of rule is empty")
mode = 1
split = pos + 1
elif mode == 1:
if isinstance(token, eof):
raise syntax_error("Syntax error (" + filename + ", line " + str(token.line) + ", col " + str(token.col) + "): unexpected end of input")
if isinstance(token, equals):
raise syntax_error("Syntax error (" + filename + ", line " + str(token.line) + ", col " + str(token.col) + "): unexpected `" + token.name + "'")
if isinstance(token, period):
if pos == split:
raise syntax_error("Syntax error (" + filename + ", line " + str(token.line) + ", col " + str(token.col) + "): right-hand side of rule is empty")
mode = 0
rules.append(rule(parse(tokens, start - 1, split - 2, 1, filename), parse(tokens, split - 1, pos - 1, 1, filename)))
start = pos + 1
return rules
def matches(lhs, term, replace_dict):
if isinstance(lhs, atom):
if not isinstance(term, atom) or lhs.name != term.name:
return 0, {}
return 1, replace_dict
if isinstance(lhs, var):
if lhs.name in replace_dict:
m = matches(replace_dict[lhs.name], term, {})
if m[0] == 0:
return 0, {}
return 1, replace_dict
replace_dict[lhs.name] = term
return 1, replace_dict
if isinstance(lhs, app):
if not isinstance(term, app):
return 0, {}
m, replace_dict = matches(lhs.left, term.left, replace_dict)
if m == 0:
return 0, {}
m, replace_dict = matches(lhs.right, term.right, replace_dict)
if m == 0:
return 0, {}
return m, replace_dict
def replace(term, replace_dict):
if isinstance(term, atom):
return term
if isinstance(term, var):
if term.name not in replace_dict:
return term
return replace_dict[term.name]
if isinstance(term, app):
return app(replace(term.left, replace_dict), replace(term.right, replace_dict))
queue = deque([])
def reduce():
global queue
while 1:
parent, term, side = queue.popleft()
rule_num = 0
while rule_num < len(rules):
rule = rules[rule_num]
match, replace_dict = matches(rule.left, term, {})
if match:
if side == 0:
parent.left = replace(rule.right, replace_dict)
else:
parent.right = replace(rule.right, replace_dict)
return 1
rule_num += 1
if isinstance(term, app):
queue.append((term, term.left, 0))
queue.append((term, term.right, 1))
if len(queue) == 0:
return 0
rules = []
for arg in sys.argv[1:]:
input_file = open(arg, 'r')
filename = input_file.name
program = input_file.read()
input_file.close()
tokens = tokenize(program)
try:
parsed = parse_rules(tokens, filename)
rules += parsed
except syntax_error as e:
print e.message
#for rule in rules:
# print rule
while 1:
term = raw_input(">>> ")
tokens = tokenize(term)
try:
term = parse(tokens, -1, len(tokens) - 2, 0, 'stdin')
print term.__str__(1)
while 1:
fake_app = app(term, None)
queue = deque([(fake_app, term, 0)])
if (reduce() == 0):
break
term = fake_app.left
print term.__str__(1)
except syntax_error as e:
print e.message
except empty:
pass
--Afarnen 18:48, 7 February 2010 (UTC)