--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/interps/rhotor/Evaluator.hs	Sun Dec 09 19:30:08 2012 +0000
@@ -0,0 +1,72 @@
+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