[Haskell-cafe] Is there already an abstraction for this?

[Nicolas Pouillard]

Excerpts from Jeremy Shaw's message of Mon Sep 22 18:46:22 -0700 2008:
> Hello,
> 
> I am trying to figure out if there is an existing abstraction I am
> missing here.

You can try to pick some information in the mocac [1] project, that is for
OCaml.

 <<
  Moca is a general construction functions generator for Caml data types with
  invariants.

  Moca supports two kinds of relations:

  * algebraic relations (such as associativity or commutativity of a
    binary constructor),
  * general rewrite rules that map some pattern of constructors and
    variables to some arbitrary user's define expression.
 >>

[1]: http://moca.inria.fr/eng.htm

Best regards,

> I have an expression data-type:
> 
> > data Expr 
> >    = Quotient Expr Expr
> >    | Product Expr Expr
> >    | Sum Expr Expr
> >    | Difference Expr Expr
> >    | Lit Double
> >    | Var Char
> >      deriving (Eq, Ord, Data, Typeable, Read, Show)
> >
> 
> And I want to write a function that will take an expression and
> automatically apply the identity laws to simplify the expression.
> 
> The basic identity laws are:
> 
>  a + 0 = a
>  a * 1 = a
> 
> I can implement these with some 'sugar' as:
> 
> > identity (Sum (Lit 0) a)        = a
> > identity (Sum a (Lit 0))        = a
> > identity (Difference a (Lit 0)) = a
> > identity (Product a (Lit 1))    = a
> > identity (Product (Lit 1) a)    = a
> > identity (Quotient a (Lit 1))   = a
> > identity a                      = a
> 
> This works fine when the identity only needs to be applied to the root
> of the expression tree:
> 
> *Main> ppExpr $ identity (expr "1 + 0")
> 1
> 
> But for more complicated trees it does not fully apply the identity laws:
> 
> *Main> ppExpr $ identity (expr "0 + (0 + 0) + (0 + 0)")
> ((0 + 0) + (0 + 0))
> 
> What we need to do is first apply the identity function to the
> children, and then apply them to the parent of the updated children. A
> first attempt would be to extend the identity function like this:
> 
> > identity (Sum a b)              = identity (Sum (identity a) (identity b))
> 
> However, that will not terminate because that same case will keep
> matching over and over. Another approach is to have two mutually
> recursive functions like:
> 
> > identity' (Sum (Lit 0) a)        = identityRec a
> > identity' (Sum a (Lit 0))        = identityRec a
> > identity' a = a
> 
> > identityRec (Sum a b) = identity' (Sum (identity' a) (identity' b))
> 
> This prevents non-termination, but you have to be careful about
> calling identity' vs identityRec or you will either re-introduce
> non-termination, or you may not fully apply the identity laws.
> 
> Another option to create a helper function like:
> 
> > -- |Deep map of an expression.
> > eMap :: (Expr -> Expr) -> Expr -> Expr
> > eMap f (Sum a b) = f (Sum (eMap f a) (eMap f b))
> > eMap f (Difference a b) = f (Difference (eMap f a) (eMap f b))
> > eMap f (Product a b) = f (Product (eMap f a) (eMap f b))
> > eMap f (Quotient a b) = f (Quotient (eMap f a) (eMap f b))
> > eMap f (Var v) = f (Var v)
> > eMap f (Lit i) = f (Lit i)
> 
> Now we can easily apply the identity law recursively like:
> 
> > deepIdentity :: Expr -> Expr
> > deepIdentity = eMap identity
> 
> *Main> ppExpr (deepIdentity (expr "0 + (0 + 0) + (0 + 0)"))
> 0
> 
> Sweet!
> 
> But, having to write eMap out by hand like that somehow feels wrong --
> as if I am missing some additional abstraction. In some respects eMap
> is like a Functor, but not quite. I expect there is a way to implement
> eMap using Data.Generics, which is perhaps better, but I still feel
> like that is missing something?
> 
> Anyway, I just thought I would ask in case someone recognized this
> pattern and could point me in the right direction. I have attached a
> working example program you can play with.
> 
> I would also be interested in alternative approaches besides the ones
> I outlined.
> 
> thanks!
> j.
> >{-# LANGUAGE DeriveDataTypeable #-}
> >
> > import Control.Applicative (Applicative((<*>), pure), (*>), (<*))
> > import Control.Monad (ap)
> > import Data.Generics (Typeable, Data)
> > import Data.List (isSuffixOf)
> > import           Text.ParserCombinators.Parsec  ((<|>))
> > import qualified Text.ParserCombinators.Parsec as P
> > import qualified Text.ParserCombinators.Parsec.Expr as P
> > import           Text.PrettyPrint.HughesPJ ((<+>))
> > import qualified Text.PrettyPrint.HughesPJ as H
> > import Prelude hiding (sum, product)
> >
> > data Expr 
> >    = Quotient Expr Expr
> >    | Product Expr Expr
> >    | Sum Expr Expr
> >    | Difference Expr Expr
> >    | Lit Double
> >    | Var Char
> >      deriving (Eq, Ord, Data, Typeable, Read, Show)
> >
> > instance Applicative (P.GenParser token state) where
> >     pure = return
> >     (<*>) = ap
> >
> > parseExpr :: P.GenParser Char st Expr
> > parseExpr = P.buildExpressionParser optable (lit <|> var <|> parenExpr)
> >     where
> >       parenExpr = 
> >           (P.char '(' >> P.skipMany P.space) *> parseExpr <* (P.char ')' >> P.skipMany P.space)
> >       optable = 
> >           [ [ P.Infix (P.char '/' >> P.skipMany P.space >> return Quotient)  P.AssocLeft  ]
> >           , [ P.Infix (P.char '*' >> P.skipMany P.space >> return Product)    P.AssocRight ]
> >           , [ P.Infix (P.char '+' >> P.skipMany P.space >> return Sum)        P.AssocRight ]
> >           , [ P.Infix (P.char '-' >> P.skipMany P.space >> return Difference) P.AssocLeft  ]
> >           ]
> >       lit = 
> >           do d <- P.try (P.many1 $ P.oneOf ('-' : '.' : ['0'..'9']))
> >              P.skipMany P.space
> >              return (Lit (read d))
> >       var =
> >           do sign <- (P.char '-' >> return (\x -> (Product (Lit (-1)) x))) <|> (return id)
> >              v <- (P.upper <|> P.lower)
> >              P.skipMany P.space
> >              return (sign (Var v))
> >
> > expr :: String -> Expr
> > expr str = either (error .show) id (P.parse parseExpr str str)
> >
> > ppExpr :: Expr -> H.Doc
> > ppExpr (Lit i)          = H.text (let f s = if isSuffixOf ".0" s then init(init s) else s in f $ show i)
> > ppExpr (Var v)          = H.char v
> > ppExpr (Quotient x y)   = H.parens (ppExpr x <+> H.char '/' <+> ppExpr y)
> > ppExpr (Product x y)    = H.parens (ppExpr x <+> H.char '*' <+> ppExpr y)
> > ppExpr (Sum x y)        = H.parens (ppExpr x <+> H.char '+' <+> ppExpr y)
> > ppExpr (Difference x y) = H.parens (ppExpr x <+> H.char '-' <+> ppExpr y)
> 
> > -- |Deep map of an expression.
> > eMap :: (Expr -> Expr) -> Expr -> Expr
> > eMap f (Sum a b) = f (Sum (eMap f a) (eMap f b))
> > eMap f (Difference a b) = f (Difference (eMap f a) (eMap f b))
> > eMap f (Product a b) = f (Product (eMap f a) (eMap f b))
> > eMap f (Quotient a b) = f (Quotient (eMap f a) (eMap f b))
> > eMap f (Var v) = f (Var v)
> > eMap f (Lit i) = f (Lit i)
> 
> > identity (Sum (Lit 0) a)        = a
> > identity (Sum a (Lit 0))        = a
> > identity (Difference a (Lit 0)) = a
> > identity (Product a (Lit 1))    = a
> > identity (Product (Lit 1) a)    = a
> > identity (Quotient a (Lit 1))   = a
> > identity a                      = a
> 
> > deepIdentity :: Expr -> Expr
> > deepIdentity = eMap identity
> 
> > test :: IO ()
> > test =
> >     do print (ppExpr (deepIdentity (expr "1 + 2")))
> >        print (ppExpr (deepIdentity (expr "0 + (0 + 0) + (0 + 0)")))

-- 
Nicolas Pouillard aka Ertai
-------------- next part --------------
A non-text attachment was scrubbed...
Name: signature.asc
Type: application/pgp-signature
Size: 194 bytes
Desc: not available
Url : http://www.haskell.org/pipermail/haskell-cafe/attachments/20080922/c21b294a/signature.bin