Talk:Anemone

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:

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:

""" Defcalc interpreter v0.1 by Andrew Farnen Usage: defcalc.py [input-file-0] [input-file-1] [input-file-2] ... """ import sys 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 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 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 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) 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 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
 * 1) ! /usr/bin/python
 * 1) for reading input files
 * 1) for breadth-first search
 * 1) syntax
 * 1) tokenize string, returning list of tokens
 * 1) parse term from list of tokens, returning either atom, var or app
 * 1) parse rules from list of tokens, returning list of rules
 * 1) for rule in rules:
 * 2)  print rule

--Afarnen 18:48, 7 February 2010 (UTC)