structure GoodOptimise: OptimiseSig = struct open Expn fun reshape (x ++ (y ++ z)) = reshape ((x ++ y) ++ z) | reshape (x ** (y ** z)) = reshape ((x ** y) ** z) | reshape (x ++ y) = reshape x ++ reshape y | reshape (x ** y) = reshape x ** reshape y | reshape x = x fun amalgam ((x ** Lit m) ** Lit n) = amalgam(x ** Lit(m * n)) | amalgam ((x ++ Lit m) ++ Lit n) = amalgam(x ++ Lit(m + n)) | amalgam ((x ** y) ** Lit n) = amalgam((x ** Lit n) ** y) | amalgam ((x ++ y) ++ Lit n) = amalgam((x ++ Lit n) ++ y) | amalgam (x ++ y) = amalgam x ++ amalgam y | amalgam (x ** y) = amalgam x ** amalgam y | amalgam x = x fun delim (Lit m ++ Lit n) = Lit (m + n) | delim (Lit m ** Lit n) = Lit (m * n) | delim (Lit 0 ** x) = Lit 0 | delim (x ** Lit 0) = Lit 0 | delim (Lit 1 ** x) = x | delim (x ** Lit 1) = x | delim (Lit 0 ++ x) = x | delim (x ++ Lit 0) = x | delim y = y fun elim (x ++ y) = delim(elim x ++ elim y) | elim (x ** y) = delim(elim x ** elim y) | elim x = x fun rightHeight (x ++ y) = Prelude.max (rightHeight x) (1 + rightHeight y) | rightHeight (x ** y) = Prelude.max (rightHeight x) (1 + rightHeight y) | rightHeight x = 0 fun order (x ** y) = if rightHeight y > rightHeight x then y ** x else x ** y | order (x ++ y) = if rightHeight y > rightHeight x then y ++ x else x ++ y | order x = x fun reorder (x ++ y) = order(reorder x ++ reorder y) | reorder (x ** y) = order(reorder x ** reorder y) | reorder x = x val optimise = reorder o elim o amalgam o reshape; end;