[Haskell-cafe] Is there already an abstraction for this?
Nicolas Pouillard
nicolas.pouillard at gmail.com
Tue Sep 23 00:47:44 EDT 2008
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
More information about the Haskell-Cafe
mailing list