How to optimize a transitive closure? - haskell

Question

I have the following code, which I would like to optimize.
I'm particularly unhappy with nub :
deep (Op o x) = [f (Op o x)] ++ map (\y->(Op o y)) (sf x)
deep x = [x]
sf [x] = [[f x]]
sf (x:xs) = map (\y->(y:xs)) (deep x) ++ map (x:) (sf xs)
eqlst l
| l == ll = l
| otherwise = eqlst ll
where ll = nub $ l ++ (concat $ map deep l)
For a full understanding of this, I provide all my code, which is not so long:
module Nat ( Nat, Operator(Add, Mul), Exp(Const, Name, Op), toNat, fromNat) where
import Data.List(nub)
newtype Nat = Nat Integer deriving (Eq, Show, Ord)
toNat :: Integer -> Nat
toNat x | x <= 0 = error "Natural numbers should be positive."
| otherwise = Nat x
fromNat :: Nat -> Integer
fromNat (Nat n) = n
instance Num Nat where
fromInteger = toNat
x + y = toNat (fromNat x + fromNat y)
x - y = toNat (fromNat x - fromNat y)
x * y = toNat (fromNat x * fromNat y)
abs x = x
signum x = 1
data Operator = Add | Sub | Mul
deriving (Eq, Show, Ord)
data Exp = Const Nat | Name { name::String } | Op{ op::Operator, kids::[Exp] }
deriving (Eq, Ord)
precedence :: Exp -> Integer
precedence (Const x) = 10
precedence (Name x) = 10
precedence (Op Add x) = 6
precedence (Op Sub x) = 6
precedence (Op Mul x) = 7
instance Show Exp where
show Op { op = Add, kids = [x, y] } =
let left = if precedence x <= 6 then "(" ++ show x ++ ")" else show x in
let right = if precedence y <= 6 then "(" ++ show y ++ ")" else show y in
left ++ "+" ++ right
show Op { op = Sub, kids = [x, y] } =
let left = if precedence x <= 6 then "(" ++ show x ++ ")" else show x in
let right = if precedence y <= 6 then "(" ++ show y ++ ")" else show y in
left ++ "-" ++ right
show Op { op = Mul, kids = [x, y] } =
let left = if precedence x <= 7 then "(" ++ show x ++ ")" else show x in
let right = if precedence y <= 7 then "(" ++ show y ++ ")" else show y in
left ++ "∙" ++ right
show (Const (Nat x)) = show x
show (Name x) = x
show x = "wat"
instance Num Exp where
fromInteger = Const . toNat
(Const x) + (Const y) = Const (x+y)
x + y = simplify $ Op { op = Add, kids = [x, y] }
(Const x) - (Const y) = Const (x-y)
x - y = simplify $ Op { op = Sub, kids = [x, y] }
(Const x) * (Const y) = Const (x*y)
x * y = simplify $ Op { op = Mul, kids = [x, y] }
abs x = x
signum x = 1
simplify :: Exp -> Exp
simplify (Op Mul [x,1]) = x
simplify (Op Mul [1,x]) = x
simplify (Op Sub [x,y])
| x == y = 0
| otherwise = (Op Sub [x,y])
simplify x = x
f (Op Add [x,y]) = y+x
f (Op Sub [x,y]) = y-x
f (Op Mul [x,y]) = y*x
f x = x
deep (Op o x) = [f (Op o x)] ++ map (\y->(Op o y)) (sf x)
deep x = [x]
sf [x] = [[f x]]
sf (x:xs) = map (\y->(y:xs)) (deep x) ++ map (x:) (sf xs)
eqlst l
| l == ll = l
| otherwise = eqlst ll
where ll = nub $ l ++ (concat $ map deep l)
eq x = eqlst [x]
main = do
let x = Name "x";y = Name "x";z = Name "z";w = Name "w";q = Name "q"
let g = (x+y+(z+w)+q)+(x+y+(z+w)+q)+(x+y+(z+w)+q)+(x+y+(z+w)+q)
putStr $ unlines $ map show $ eq g
I also have a side question, about the function deep and sf that are using f::Exp->Exp. In the end, f should probably be f::[Exp]->[Exp].
Right now, f only performs one kind of transformation. In the end, I would like it to perform many kinds of transformations, for example :
a+b->b+a, (a+b)+c->a+(b+c), etc.

Answer 1

The function nub is inefficient since it only uses an Eq constraint and therefore has to compare every nondiscarded pair of elements. Using the more efficient Data.Set, which is based internally on sorted trees, should improve on this:
import qualified Data.Set as S
eqset s
| s == ss = s
| otherwise = eqset ss
where ss = S.unions $ s : map (S.fromList . deep) (S.toList s)
eqlst = S.toList . eqset . S.fromList