How to optimize a transitive closure?

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