optimusprime-0.0.1.20091114: Optimus/Homeo.hs

module Optimus.Homeo where
	import Flite.Syntax
	import Optimus.Uniplate
	
	import Data.Generics.Uniplate
	
	(<||) :: Exp -> Exp -> Bool
	x <|| y = dive x y || couple x y
	
	dive :: Exp -> Exp -> Bool
	dive x y = any (x <||) (children y)
	
	couple :: Exp -> Exp -> Bool
	couple x y 	= x =~ y && length x_ == length y_
				&& and (zipWith (<||) x_ y_)
		where
			x_ = children x
			y_ = children y
			
	-- Must alpha first
	(=~) :: Exp -> Exp -> Bool
	(Bottom) =~ (Bottom) = True
	(Int i) =~ (Int j) = i == j
	(Fun f) =~ (Fun h) = f == h
	(Con c) =~ (Con d) = c == d
	(Var _) =~ (Var _) = True
	(App _ xs) =~ (App _ ys) = length xs == length ys
	(Let bs_x _) =~ (Let bs_y _) = length bs_x == length bs_y
								-- && and (zipFst (==) bs_x bs_y)
	(Case _ alts_x) =~ (Case _ alts_y) = length alts_x == length alts_y
								--	&& and (zipFst (==~) alts_x alts_y)
	_ =~ _ = False
										
	(==~) :: Exp -> Exp -> Bool
	(App _ xs) ==~ (App _ ys) = length xs == length ys
							&& and (zipWith (==~) xs ys)
	(Con c) ==~ (Con d) = c == d
	(Var v) ==~ (Var w) = v == w
	_ ==~ _ = False
	
	zipFst :: (a -> b -> c) -> [(a, d)] -> [(b, e)] -> [c]
	zipFst f = zipWith (\(x, _) (y, _) -> f x y)