functor DAGOPT(structure B: BlockSig):
sig
    structure B : BlockSig
    val blockOpt : B.Block -> B.Block
end 
= struct
structure B = B
open B

fun reshape (x +++ (y +++ z)) = reshape ((x +++ y) +++ z)
  | reshape (x +++ (y --- z)) = reshape ((x +++ y) --- z)
  | reshape (x --- (y +++ z)) = reshape ((x --- y) --- z)
  | reshape (x --- (y --- z)) = reshape ((x +++ z) --- y)
  | reshape (x *** (y *** z)) = reshape ((x *** y) *** z)
  | reshape (x *** (y /// z)) = reshape ((x *** y) /// z)
  | reshape (x /// (y *** z)) = reshape ((x /// y) /// z)
  | reshape (x /// (y /// z)) = reshape ((x *** z) /// y)
  | reshape (x +++ y)        = reshape x +++ reshape y
  | reshape (x --- y)        = reshape x --- reshape y
  | 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 +++ Lit m) --- Lit n) = amalgam(x +++ Lit(m - n))
  | amalgam ((x --- Lit m) +++ Lit n) = amalgam(x +++ Lit(n - m))
  | 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) *** Lit n)     = amalgam((x *** Lit n) /// y)
  | amalgam ((x /// y) /// Lit n)     = amalgam((x /// Lit n) /// y)
  | amalgam ((x +++ y) +++ Lit n)     = amalgam((x +++ Lit n) +++ y)
  | amalgam ((x +++ y) --- Lit n)     = amalgam((x --- Lit n) +++ y)
  | 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 /// 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 m *** Lit n) = Lit (m * n)
  | delim (Lit 0 *** x)     = Lit 0
  | delim (Lit 0 /// x)     = Lit 0
  | delim (x *** Lit 0)     = Lit 0
  | delim (Lit 1 *** x)     = x
  | delim (x *** Lit 1)     = x
  | delim (Lit 1 /// x)     = x
  | delim (x /// Lit 1)     = x
  | delim (Lit 0 +++ x)     = x
  | delim (x +++ Lit 0)     = 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 /// 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 /// 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 --- y) = reorder x --- reorder y
  | reorder (x /// y) = reorder x /// reorder y
  | reorder x        = x

val optimise = reorder o elim o amalgam o reshape;

fun blockOpt (Block b) = Block(map (fn (s,e) => (s, optimise e)) b)
end;