Mercurial > repo
view interps/rhotor/Evaluator.hs @ 3911:8c112ffd5765
<kmc> addquote zzo38 [~zzo38@24-207-49-17.eastlink.ca] has quit [Quit: I need the stats for the small leech, not the big one. So, if you write it on here while I am gone then when I return I will check.]
author | HackBot |
---|---|
date | Tue, 15 Oct 2013 22:19:50 +0000 |
parents | 859f9b4339e6 |
children |
line wrap: on
line source
module Evaluator (evaluate) where import Node import Uniqs evaluate :: Node -> Node evaluate x = eval x--stripBreaks (eval x) eval :: Node -> Node eval (Cons a b) = Cons (eval a) (eval b) eval (Function a b c) = Function (eval a) (eval b) (eval c) eval (Application (Function a b c) d) = if patternMatch a d then eval (application a b d) else eval (Application c d) eval (Application Nil _) = Nil eval (Application (Cons a b) d) = eval (Cons (Application a d) (Application b d)) eval (Application y@(Application _ _) d) = eval (Application (eval y) d) eval (Application y@(Break _) d) = eval (Application (eval y) d) eval (Break x) = eval x eval x = x stripBreaks :: Node -> Node stripBreaks (Break a) = stripBreaks a stripBreaks (Function a b c) = Function (stripBreaks a) (stripBreaks b) (stripBreaks c) stripBreaks (Application a b) = Application (stripBreaks a) (stripBreaks b) stripBreaks (Cons a b) = Cons (stripBreaks a) (stripBreaks b) stripBreaks x = x patternMatch :: Node -> Node -> Bool patternMatch (Symbol _) _ = True patternMatch Nil Nil = True patternMatch (Cons a1 d1) (Cons a2 d2) = (patternMatch a1 a2) && (patternMatch d1 d2) -- patternMatch (Function a1 d1 c1) (Function a2 d2 c2) = (patternMatch a1 a2) && (patternMatch d1 d2) && (patternMatch e1 e2) patternMatch a@(Application _ _ ) b = patternMatch (eval a) b patternMatch a b@(Application _ _ ) = patternMatch a (eval a) patternMatch (Break a) b = patternMatch a b patternMatch a (Break b) = patternMatch a b patternMatch _ _ = False application :: Node -> Node -> Node -> Node application patrn func arg = applyList func (applicationList patrn arg) applyList :: Node -> [(Uniqs, Node)] -> Node applyList (Symbol y) list = getNodeForSymbol y list applyList (Cons a d) list = Cons (applyList a list) (applyList d list) applyList (Function a b c) list = Function (applyList a list) (applyList b list) (applyList c list) applyList (Application a b) list = Application (applyList a list) (applyList b list) applyList (Break a) _ = Break a applyList Nil _ = Nil getNodeForSymbol :: Uniqs -> [(Uniqs, Node)] -> Node getNodeForSymbol s tab = case (lookup s tab) of Just (Break a) -> Break a Just a -> Break a Nothing -> Symbol s applicationList :: Node -> Node -> [(Uniqs, Node)] applicationList (Symbol y) x = [(y,x)] applicationList Nil Nil = [] applicationList (Cons a1 d1) (Cons a2 d2) = (applicationList a1 a2) ++ (applicationList d1 d2) applicationList a@(Application _ _ ) b = applicationList (eval a) b applicationList a b@(Application _ _ ) = applicationList a (eval a) applicationList (Break a) b = applicationList a b applicationList a (Break b) = applicationList a b