Commit 558310f7 authored by Hans-Peter Deifel's avatar Hans-Peter Deifel
Browse files

Implement product functor

This is only temporal and demonstrates the fact that multi-argument
functors are implementable. In the future this will be replaced by a
more general polynomial functor, but the parsing infrastructure for
functor expressions can't handle that yet.
parent ac9635fc
......@@ -36,6 +36,7 @@ library
, MA.Functors.FixedProduct
, MA.Functors.MonoidValued
, MA.Functors.Distribution
, MA.Functors.Product
, MA.Functors.SomeFunctor
, MA.Parser
, MA.Parser.Lexer
......
......@@ -20,10 +20,16 @@ import MA.Parser.Types
data FunctorParser f where
Prefix :: (forall a m. ParserT m (a -> f a)) -> FunctorParser f
Postfix :: (forall a m. ParserT m (a -> f a)) -> FunctorParser f
InfixN :: (forall a m. ParserT m (a -> a -> f a )) -> FunctorParser f
InfixL :: (forall a m. ParserT m (a -> a -> f a )) -> FunctorParser f
InfixR :: (forall a m. ParserT m (a -> a -> f a )) -> FunctorParser f
transParser :: (forall a. f a -> g a) -> FunctorParser f -> FunctorParser g
transParser natTrans (Prefix p) = Prefix (fmap natTrans <$> p)
transParser natTrans (Postfix p) = Postfix (fmap natTrans <$> p)
transParser natTrans (InfixN p) = InfixN ((\f a b -> natTrans (f a b)) <$> p)
transParser natTrans (InfixL p) = InfixL ((\f a b -> natTrans (f a b)) <$> p)
transParser natTrans (InfixR p) = InfixR ((\f a b -> natTrans (f a b)) <$> p)
newtype Precedence = Precedence Int
deriving (Num, Bounded, Enum, Integral, Real, Ord, Eq, Show)
......@@ -57,6 +63,11 @@ makeOpTable table =
case funcParser of
Prefix p -> Expr.Prefix ((Functor precedence .) <$> p)
Postfix p -> Expr.Postfix ((Functor precedence .) <$> p)
InfixN p -> Expr.InfixN (mkInfix precedence <$> p)
InfixL p -> Expr.InfixL (mkInfix precedence <$> p)
InfixR p -> Expr.InfixR (mkInfix precedence <$> p)
mkInfix precedence f a b = Functor precedence (f a b)
parseFunctorExpression ::
[[FunctorParser f]]
......
......@@ -4,11 +4,14 @@ module MA.Functors
( registeredFunctors
) where
import Prelude hiding (product)
import MA.Functors.FixedProduct (fixedproduct)
import MA.Functors.MonoidValued (intValued, realValued)
import MA.Functors.Powerset (powerset)
import MA.Functors.Bag (bag)
import MA.Functors.Distribution (distribution)
import MA.Functors.Product (product)
import MA.Functors.SomeFunctor
import MA.FunctorExpression.Parser
......@@ -16,5 +19,6 @@ registeredFunctors :: [[FunctorParser SomeFunctor]]
registeredFunctors =
[ [someFunctor intValued, someFunctor realValued]
, [someFunctor powerset, someFunctor bag, someFunctor distribution]
, [someFunctor product]
, [someFunctor fixedproduct]
]
module MA.Functors.Product
( product
, Product(..)
) where
import Control.Monad (void)
import Prelude hiding (product)
import Data.Tuple.Extra (both)
import MA.RefinementInterface
import qualified MA.Parser.Lexer as L
import MA.FunctorExpression.Parser
import MA.Coalgebra.RefinementTypes
import MA.Coalgebra.Parser
data Product a = Product a a
deriving (Show, Functor, Foldable, Traversable)
product :: FunctorParser Product
product = InfixR $ do
void $ L.symbol "×"
return Product
data Side = L | R
deriving (Eq)
data Three = ToRest | ToCompound | ToSub
deriving (Show, Eq, Ord, Enum)
type instance H1 Product = ()
type instance H3 Product = (Three, Three)
type instance Label Product = Side
type instance Weight Product = (Bool, Bool)
instance ParseMorphism Product where
parseMorphismPoint (Product parseLeft parseRight) = L.parens $ do
left <- parseLeft
void L.comma
right <- parseRight
return ((), [(left, L), (right, R)])
instance RefinementInterface Product where
init :: H1 Product -> [Label Product] -> Weight Product
init _ _ = (True, True)
update :: [Label Product] -> Weight Product -> (Weight Product, H3 Product, Weight Product)
update labels (left, right) = val up
where
val h3 = (both (==ToSub) h3, h3, both (==ToCompound) h3)
up = (left +? (L `elem` labels), right +? (R `elem` labels))
(+?) :: Bool -> Bool -> Three
a +? b = toEnum (fromEnum a + fromEnum b)
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment