Polynomial.hs 3.1 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
module MA.Functors.Polynomial
  ( Polynomial(..)
  , Sum(..)
  , Product(..)
  , Factor(..)
  , SumValue(..)
  , ProductValue(..)
  , FactorValue(..)
  ) where

import           Control.Monad
import           Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import           Data.Maybe (catMaybes)

import           Data.Text (Text)
import           Data.Vector (Vector)
import qualified Data.Vector as V
import           Text.Megaparsec

import           MA.Coalgebra.Parser
import           MA.Coalgebra.RefinementTypes
import qualified MA.Parser.Lexer as L
import           MA.Parser.Types

newtype Polynomial a = Polynomial (Sum a)
  deriving (Functor)

31
newtype Sum a = Sum (NonEmpty (Product a))
32
33
  deriving (Functor)

34
newtype Product a = Product (NonEmpty (Factor a))
35
36
37
38
39
40
41
  deriving (Functor)

data Factor a
  = Const (Vector Text)
  | Identity a
  deriving (Functor)

42
-- Index into coproduct and corresponding product value
43
44
45
46
47
48
49
50
51
52
53
54
data SumValue a = SumValue Int (ProductValue a)
  deriving (Eq, Show)

data ProductValue a =
  ProductValue (Vector (FactorValue a))
  deriving (Eq, Show)

data FactorValue a
  = ConstValue Int
  | IdValue a
  deriving (Eq, Show)

55
56
57
58

data Three = ToRest | ToCompound | ToSub
  deriving (Show, Eq, Ord, Enum)

59
type instance H1 Polynomial = SumValue ()
60
61
62
type instance Label Polynomial = Int -- Index of edge product (independent of
                                     -- toplevel-sum)
type instance Weight Polynomial = SumValue Bool -- H2
63
64
65
66
67
type instance H3 Polynomial = SumValue Three

instance ParseMorphism Polynomial where
  parseMorphismPoint (Polynomial expr) = parseSum expr
    where
68
      -- Coproducts
69
70
71
72
73
74
75
76
77
78
79
80
81
      parseSum ::
           MonadParser m => Sum (m a) -> m (SumValue (), [(a, Label Polynomial)])
      parseSum (Sum summands) = do
        void $ L.symbol "inj"
        i <- L.decimal

        when (i < 0 || i >= length summands) $
          fail ("polynomial: injection " ++ show i ++ " is out of bounds")

        (h1, successors) <- parseProduct (summands NonEmpty.!! i)

        return (SumValue i h1, successors)

82
      -- Products
83
84
85
      parseProduct ::
           MonadParser m => Product (m a) -> m (ProductValue (), [(a, Int)])
      parseProduct (Product (f :| fs)) = L.parens $ do
86
87
88
89
        factors <- (:)
          <$> parseFactor f
          <*> traverse (\x -> L.comma *> parseFactor x) fs

90
        let (h1, successors) = unzip factors
91
92
93
            labeledSuccessors = zipWith (\a i -> fmap (,i) a) successors [0..]

        return ( ProductValue (V.fromList h1) , catMaybes labeledSuccessors)
94

95
      -- Factors
96
97
98
99
100
101
102
103
104
105
106
107
      parseFactor :: MonadParser m => Factor (m a) -> m (FactorValue (), Maybe a)
      parseFactor (Const names) = do
        h1 <- ConstValue <$> someName names
        return (h1, Nothing) -- const has no successors
      parseFactor (Identity inner) = do
        successor <- inner
        return (IdValue (), Just successor)

      someName :: MonadParser m => Vector Text -> m Int
      someName v =
        (V.ifoldr (\i new old -> (L.symbol new *> pure i) <|> old) empty v)
          <?> ("one of " ++ show v)