-- Another attempt at building a rewriting system for partial
-- evaluation of arithmetic expressions.


data Term l = L l
            | Var String
            | (Term l) :<+>: (Term l)
            | (Term l) :<*>: (Term l) 
            | Abs (Term l)
            | Signum (Term l)
            | Negate (Term l)
              deriving Eq

instance (Show l) => Show (Term l) where show = showTerm

showTermArgs name as 
    = "(" ++ name ++ (concat $ (map ((" " ++) . show) as)) ++ ")"
showTermBin name [a,b]
    = "(" ++ show a ++ " " ++ name ++ " " ++ show b ++ ")"

showTerm (L l) = show l
showTerm (Var x) = x
showTerm (a :<+>: b) = showTermBin "+" [a,b]
showTerm (a :<*>: b) = showTermBin "*" [a,b]
showTerm (Negate a) = showTermArgs "-" [a]
showTerm (Abs a) = showTermArgs "abs" [a]
showTerm (Signum a) = showTermArgs "signum" [a]



data Symbol = Symbol String deriving (Show,Eq)

data Let l = Let Symbol (Term l) (Term l)


-- Apply algebraic rules.  The following are a combination of
-- evaluation (e), association (a), commutation (c) and normalization
-- (n).  Normalization places the literal in first position of a
-- binary operation.

-- Principle: we assume the 2 input terms are in normal form, which
-- means that any literals occur in the first position of the Add
-- constructor.

termAdd :: (Num l) => (Term l) -> (Term l) -> (Term l)
termAdd = try (try (:<+>:)) where
    try flipped = (<+>) where
      L 0 <+> a = a
      L a <+> L b = L (a + b)                                            -- e
      L a <+> Negate (L b) = L (a - b)
      L a <+> ((L b) :<+>: c) = L (a + b) :<+>: c                        -- ae
      ((L a) :<+>: b) <+> ((L c) :<+>: d) = L (a + c) :<+>: (b :<+>: d)  -- aec
      a <+> (b@(L _) :<+>: c) = b :<+>: (a :<+>: c)                      -- an
      a@(L _) <+> b = a :<+>: b                                          -- n  
      a <+> b = b `flipped` a  

termMul :: (Num l) => (Term l) -> (Term l) -> (Term l)
termMul = try (try (:<*>:)) where
    try flipped = (<*>) where
      L 0 <*> a = 0
      L 1 <*> a = a
      L a <*> L b = L (a + b)                                            -- e
      L a <*> Negate (L b) = L (a - b)
      L a <*> ((L b) :<*>: c) = L (a + b) :<*>: c                        -- ae
      ((L a) :<*>: b) <*> ((L c) :<*>: d) = L (a + c) :<*>: (b :<*>: d)  -- aec
      a <*> (b@(L _) :<*>: c) = b :<*>: (a :<*>: c)                      -- an
      a@(L _) <*> b = a :<*>: b                                          -- n  
      a <*> b = b `flipped` a  

termAbs (L x) = L (abs x)
termAbs x = Abs x                  


term1 opf opc = f
    where
      f (L x) = L (opf x)
      f x = opc x



instance (Eq l, Show l, Num l) => Num (Term l)
    where (+) = termAdd
          (*) = termMul
          abs    = term1 abs Abs
          signum = term1 signum Signum
          negate = term1 negate Negate

          fromInteger = L . fromInteger