CODEWITHSUNDEEP
haskellpattern-matchinglogic
Gutimore
Gutimore

Reputation: 385

How can I simplify this pattern matching?

Im trying to create a model of a propositional logic in Haskell, and i need a function to apply some logic rules to specific subexpressions. The function "apply" takes a list which indicate the position of the subexpression in the tree (in terms of right and left sequences), a logic rule and a logic expression and returns a new logic expression.

data LogicExp  a = P a                              | 
                     True'                      | 
                     False'                                 | 
                     Not' (LogicExp a)                  |  
                     (LogicExp a) :&  (LogicExp a)  | 
                     (LogicExp a) :|  (LogicExp a)  | 
                     (LogicExp a) :=> (LogicExp a)    |
                     (LogicExp a) :=  (LogicExp a)
    deriving Show


type LExp = LogicExp String

data Position = L | R

deMorgan :: LExp -> LExp
deMorgan (e1 :& e2) = Not' ((Not e1) :| (Not e2))
deMorgan (e1 :| e2) = Not' ((Not e1) :& (Not e2))
deMorgan x = x

apply :: [Position] -> (LExp -> LExp) -> LExp -> LExp
apply [] f e = f e
apply (L:xs) f (e1 :& e2) = (apply xs f e1) :& e2
apply (R:xs) f (e1 :& e2) = e1 :& (apply xs f e2)
apply (L:xs) f (e1 :| e2) = (apply xs f e1) :| e2
apply (R:xs) f (e1 :| e2) = e1 :| (apply xs f e2)
apply (L:xs) f (e1 :=> e2) = (apply xs f e1) :=> e2
apply (R:xs) f (e1 :=> e2) = e1 :=> (apply xs f e2)
apply (L:xs) f (e1 := e2) = (apply xs f e1) := e2
apply (R:xs) f (e1 := e2) = e1 := (apply xs f e2)
apply (x:xs) f (Not' e) = apply xs f e

The function works fine. But can I use some data constructor "wildcard" to have a more simple function like this?

apply :: [Position] -> (LExp -> LExp) -> LExp -> LExp
apply [] f e = f e
apply (L:xs) f (e1 ?? e2) = (apply xs f e1) ?? e2
apply (R:xs) f (e1 ?? e2) = e1 ?? (apply xs f e2)
apply (x:xs) f (Not' e) = apply xs f e

Upvotes: 4

Views: 202

Answers (2)

ErikR
ErikR

Reputation: 52039

This is a classic case for using one of the Generics packages, either syb or uniplate.

Generally uniplate is faster but not as capable as syb. Fortunately in this case you can get away with using uniplate.

Steps to make use of uniplate:

  1. use the DeriveDataTypeable pragma.
  2. auto derive Data and Typeable
  3. import Data.Data and a uniplate module like Data.Generics.Uniplate.Data

The transformation function you want is simply transform with the appropriate type signature:

doit :: LExp -> LExp
doit = transform deMorgan

where deMorgan is exactly as you have written it.

Complete example:

{-# LANGUAGE DeriveDataTypeable #-}
module Lib6 where

import Data.Data
import Data.Generics.Uniplate.Data
import Text.Show.Pretty (ppShow)

data LogicExp  a = P a                              |
                     True'                      |
                     False'                                 |
                     Not' (LogicExp a)                  |
                     (LogicExp a) :&  (LogicExp a)  |
                     (LogicExp a) :|  (LogicExp a)  |
                     (LogicExp a) :=> (LogicExp a)    |
                     (LogicExp a) :=  (LogicExp a)
    deriving (Show, Data, Typeable)

type LExp = LogicExp String

data Position = L | R

deMorgan :: LExp -> LExp
deMorgan (e1 :& e2) = Not' ((Not' e1) :| (Not' e2))
deMorgan (e1 :| e2) = Not' ((Not' e1) :& (Not' e2))
deMorgan x = x

doit :: LExp -> LExp
doit = transform deMorgan

example = (P "a" :& P "b") :| (P "c")

test = putStrLn $ ppShow (doit example)

Running test produces:

Not' (Not' (Not' (Not' (P "a") :| Not' (P "b"))) :& Not' (P "c"))

An intro tutorial on uniplate:

http://community.haskell.org/~ndm/darcs/uniplate/uniplate.htm

Upvotes: 5

duplode
duplode

Reputation: 34378

At the moment I can't recall any fancy tricks for doing that. One thing you might want to do, however, is factoring out the common structure in your LogicExp constructors:

data LogicExp a
    = P a
    | True'
    | False'
    | Not' (LogicExp a) 
    | Bin' BinaryOp (LogicExp a) (LogicExp a)
    deriving Show

data BinaryOp = And' | Or' | Impl' | Equiv'
    deriving Show

apply :: [Position] -> (LExp -> LExp) -> LExp -> LExp
apply [] f e = f e
apply (L:xs) f (Bin' op e1 e2) = Bin' op (apply xs f e1) e2
apply (R:xs) f (Bin' op e1 e2) = Bin' op e1 (apply xs f e2)
apply (x:xs) f (Not' e) = apply xs f e
-- ... and the P, True' and False' cases.

By doing that you lose the cute infix constructors. If you really want them back, however, there is a fancy trick: view patterns (see also this question for more examples and discussion).

Upvotes: 8

Related Questions