Commit 0f631281 authored by Hans-Peter Deifel's avatar Hans-Peter Deifel
Browse files

Use vectors instead of lists as result for parseMorphismPoint

parent e2fc7b4e
module Data.Vector.Utils
( iforM_
, sort
, sortBy
, sortOn
, hasDuplicates
) where
import Data.Ord (comparing)
import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.Vector.Algorithms.Intro as V
iforM_ :: Monad m => Vector a -> (Int -> a -> m b) -> m ()
iforM_ = flip V.imapM_
sort :: Ord a => Vector a -> Vector a
sort = V.modify V.sort
-- FIXME: There should be inline pragmas for sortBy and sortOn, but GHC panics
-- when I do this.
sortBy :: (a -> a -> Ordering) -> Vector a -> Vector a
sortBy predicate = V.modify (V.sortBy predicate)
sortOn :: Ord b => (a -> b) -> Vector a -> Vector a
sortOn f = V.modify (V.sortBy (comparing f))
hasDuplicates :: Eq a => Vector a -> Bool
hasDuplicates v = V.length (V.uniq v) /= V.length v
......@@ -21,6 +21,7 @@ import qualified Data.Text as T
import Lens.Micro.Platform
import Text.Megaparsec hiding (State)
import qualified Data.Vector as V
import Data.Vector (Vector)
import Control.DeepSeq (NFData)
import MA.FunctorExpression.Type
......@@ -35,7 +36,7 @@ data Symbol = Defined | Undefined
deriving (Eq)
data ParserState l h1 = ParserState
{ _graph :: M.HashMap State (Sort, (h1, [(State, l)]))
{ _graph :: M.HashMap State (Sort, (h1, Vector (State, l)))
, _symbolTable :: M.HashMap Text (State, Symbol)
, _nextState :: Int
}
......@@ -51,7 +52,7 @@ initState = ParserState
type MorphParser l h1 = StateT (ParserState l h1) Parser
class ParseMorphism f where
parseMorphismPoint :: (Eq x, Ord x, MonadParser m) => f (m x) -> m (H1 f, [(x, Label f)])
parseMorphismPoint :: (Eq x, Ord x, MonadParser m) => f (m x) -> m (H1 f, Vector (x, Label f))
newState :: MorphParser l h1 State
newState = nextState <<%= succ
......@@ -96,16 +97,15 @@ finalizeState state =
case M.lookup i g of
Nothing -> error "should not happen" -- FIXME: Handle this case better
Just (sort, (h1, _)) -> (sort, h1)
edges = concatMap toEdges (M.toList g)
edgeVec = V.fromList edges
edges = V.concat (map toEdges (M.toList g))
symTab = M.fromList (map swap (M.toList (fmap fst (state ^. symbolTable))))
in
(SymbolTable symTab, Encoding.new h1Vec edgeVec)
(SymbolTable symTab, Encoding.new h1Vec edges)
where
toEdges :: (State, (Sort, (h1, [(State, l)]))) -> [Encoding.Edge (Sort, l)]
toEdges (from, (sort, (_, succs))) = map (\(to, lab) -> Encoding.Edge from (sort, lab) to) succs
toEdges :: (State, (Sort, (h1, Vector (State, l)))) -> (Vector (Encoding.Edge (Sort, l)))
toEdges (from, (sort, (_, succs))) = V.map (\(to, lab) -> Encoding.Edge from (sort, lab) to) succs
morphismsParser ::
(Functor f, ParseMorphism f)
......
......@@ -17,6 +17,7 @@ module MA.Functors.Bag
import Prelude hiding (init)
import qualified Data.Vector as V
import Text.Megaparsec
import Data.Eq.Deriving (deriveEq1)
import Text.Show.Deriving (deriveShow1)
......@@ -46,11 +47,11 @@ deriving instance Show (Bag ())
instance ParseMorphism Bag where
parseMorphismPoint (Bag inner) = L.brackets $ do
successors <- inner `sepBy` L.comma
successors <- V.fromList <$> inner `sepBy` L.comma
let h1 = length successors
return (h1, zip successors (repeat 1))
return (h1, V.map (,1) successors)
instance RefinementInterface Bag where
init = init @(MonoidValued Int)
......
......@@ -14,9 +14,12 @@ module MA.Functors.MonoidValued
import Control.Monad (when)
import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.Set as S
import Text.Megaparsec
import qualified Data.Vector.Utils as V
import MA.RefinementInterface
import MA.Coalgebra.Parser
import MA.Coalgebra.RefinementTypes
......@@ -51,19 +54,18 @@ parseMorphismPointHelper ::
(Num w, Ord x, MonadParser m)
=> m x
-> m w
-> m (w, [(x, w)])
parseMorphismPointHelper inner weightParser = L.braces $ do
successors <- edge `sepBy` L.comma
-> m (w, Vector (x, w))
parseMorphismPointHelper inner weightParser = do
successors <- V.sortOn fst . V.fromList <$> L.braces (edge `sepBy` L.comma)
when (not (allUnique (map fst successors))) $
when (V.hasDuplicates (fmap fst successors)) $
fail "monoid valued: Duplicate edges"
let h1 = sum (map snd successors)
let h1 = V.sum (V.map snd successors)
return (h1, successors)
where
edge = (,) <$> inner <* L.colon <*> (L.signed weightParser)
allUnique l = length (S.fromList l) == length l
instance ParseMorphism (MonoidValued Int) where
parseMorphismPoint (IntValued inner) = parseMorphismPointHelper inner L.decimal
......
......@@ -31,7 +31,7 @@ import Data.Maybe (fromMaybe)
import Data.Tuple (swap)
import GHC.Generics (Generic)
import qualified Data.Vector.Algorithms.Intro as V (sort)
import qualified Data.Vector.Utils as V
import Data.Text (Text)
import qualified Data.Text as T
import Data.Vector (Vector)
......@@ -124,13 +124,9 @@ parseIdOrExp inner = do
parseExplicitExp :: MonadParser m => m Exponent
parseExplicitExp = L.braces $ do
names <- (V.modify V.sort . V.fromList) <$> L.name `sepBy` L.comma
let iter (unique :: Bool, last :: Maybe Text) (current :: Text) =
let sameAsLast = last == Just current
in (unique && (not sameAsLast), Just current)
allUnique = fst (foldl' iter (True, Nothing) names)
names <- (V.sort . V.fromList) <$> L.name `sepBy` L.comma
unless allUnique $
when (V.hasDuplicates names) $
fail "exponential: domain must be uniquely defined"
return (ExplicitExp names)
......@@ -183,7 +179,7 @@ instance ParseMorphism Polynomial where
-- | Parse either a single product or an injection into the coproduct, depending
-- on the number of co-factors.
parseSum1 ::
MonadParser m => Sum (m a) -> m (SumValue (), [(a, Label Polynomial)])
MonadParser m => Sum (m a) -> m (SumValue (), Vector (a, Label Polynomial))
parseSum1 sum@(Sum (product :| [])) = do
-- only a single summand => parse product directly
......@@ -202,7 +198,7 @@ parseSumPrefix = L.symbol "inj" *> L.decimal
-- | Parse an injection into the coproduct with the syntax 'inj i _'
parseSum ::
MonadParser m => Sum (m a) -> Int -> m (SumValue (), [(a, Label Polynomial)])
MonadParser m => Sum (m a) -> Int -> m (SumValue (), Vector (a, Label Polynomial))
parseSum (Sum summands) i = do
when (i < 0 || i >= length summands) $
fail ("polynomial: injection " ++ show i ++ " is out of bounds")
......@@ -215,33 +211,32 @@ parseSum (Sum summands) i = do
-- | Parse either a single factor without parens or a tuple.
parseProduct1 ::
MonadParser m => Product (m a) -> m (ProductValue (), [(a, (Int, Int))])
MonadParser m => Product (m a) -> m (ProductValue (), Vector ((a, (Int, Int))))
parseProduct1 product@(Product (factor :| [])) =
let mkProduct f = f & _1 %~ (ProductValue . V.singleton)
& _2 %~ (_Just . each . _2 %~ (0,) <&> fromMaybe [])
& _2 %~ (_Just . each . _2 %~ (0,) <&> fromMaybe V.empty)
in (mkProduct <$> parseFactor factor) <|> parseProduct product
parseProduct1 other = parseProduct other
parseProduct ::
MonadParser m => Product (m a) -> m (ProductValue (), [(a, (Int, Int))])
MonadParser m => Product (m a) -> m (ProductValue (), Vector (a, (Int, Int)))
parseProduct (Product l@(f :| fs)) =
label ("a product of " ++ show (length l) ++ " element(s)") $ L.parens $ do
factors <- (:)
factors <- V.cons
<$> parseFactor f
<*> traverse (\x -> L.comma *> parseFactor x) fs
<*> (V.fromList <$> traverse (\x -> L.comma *> parseFactor x) fs)
let (h1, successors) = unzip factors
let (h1, successors) = V.unzip factors
labeledSuccessors =
zipWith
(\x i -> x & _Just . traversed . _2 %~ (i,) & fromMaybe [])
V.imap
(\i x -> x & _Just . traversed . _2 %~ (i,) & fromMaybe V.empty)
successors
[0..]
return ( ProductValue (V.fromList h1) , concat labeledSuccessors)
return ( ProductValue h1 , fold labeledSuccessors)
----------- Factor parser
parseFactor :: MonadParser m => Factor (m a) -> m (FactorValue (), Maybe [(a, Int)])
parseFactor :: MonadParser m => Factor (m a) -> m (FactorValue (), Maybe (Vector (a, Int)))
parseFactor (Const (ExplicitSet names)) = do
h1 <- ConstValue <$> someName names
return (h1, Nothing) -- const has no successors
......@@ -259,19 +254,18 @@ parseFactor (Const (FiniteNatSet n)) = do
return (ConstValue x, Nothing)
parseFactor (Identity inner) = do
successor <- inner
return (IdValue (), Just [(successor, 0)])
return (IdValue (), Just (V.singleton (successor, 0)))
parseFactor (Exponential inner exp) = L.braces $ do
successors <- ((,) <$> parseExpValue exp
<*> (L.colon *> inner))
`sepBy` L.comma
successors <- V.sortOn snd . V.fromList <$>
(flip (,) <$> parseExpValue exp
<*> (L.colon *> inner))
`sepBy` L.comma
let allIdxUsedOnce = (allExpValues exp) == sort (map fst successors)
unless allIdxUsedOnce $
unless (allExpValues exp == (V.map snd successors)) $
fail ("exponential: map must be well-defined on " ++ showExp exp)
return ( ExponentialValue (V.replicate (length successors) ())
, Just (map swap successors)
, Just successors
)
parseExpValue :: MonadParser m => Exponent -> m Int
......@@ -283,9 +277,9 @@ parseExpValue (FiniteNatExp n) = do
"is out of bounds. (must be between 0 and " ++ show n ++ ")")
return x
allExpValues :: Exponent -> [Int]
allExpValues (ExplicitExp names) = [0..length names-1]
allExpValues (FiniteNatExp n) = [0..n-1]
allExpValues :: Exponent -> Vector Int
allExpValues (ExplicitExp names) = V.enumFromN 0 (length names)
allExpValues (FiniteNatExp n) = V.enumFromN 0 n
showExp :: Exponent -> String
showExp (ExplicitExp names) = show names
......@@ -294,10 +288,10 @@ showExp (FiniteNatExp n) = "{0.." ++ show n ++ "}"
someName :: MonadParser m => Vector Text -> m Int
someName v = do
name <- try L.name
label ("name from {" ++
T.unpack (T.intercalate "," (V.toList v)) ++
"}") $ do
maybe empty return (V.elemIndex name v)
-- label ("name from {" ++
-- T.unpack (T.intercalate "," (V.toList v)) ++
-- "}") $ do
maybe empty return (V.elemIndex name v)
instance RefinementInterface Polynomial where
init :: H1 Polynomial -> [Label Polynomial] -> Weight Polynomial
......
......@@ -7,6 +7,8 @@ import Control.Monad (when)
import qualified Data.Set as S
import Text.Megaparsec
import qualified Data.Vector as V
import qualified Data.Vector.Utils as V
import MA.RefinementInterface
import qualified MA.Parser.Lexer as L
......@@ -33,18 +35,15 @@ type instance H1 Powerset = Bool
type instance H3 Powerset = (Bool, Bool, Bool)
instance ParseMorphism Powerset where
parseMorphismPoint (Powerset inner) = L.braces $ do
successors <- inner `sepBy` L.comma
parseMorphismPoint (Powerset inner) = do
successors <- V.sort . V.fromList <$> L.braces (inner `sepBy` L.comma)
when (not (allUnique successors)) $
when (V.hasDuplicates successors) $
fail "powerset: Duplicate edges"
let h1 = not (null successors)
return (h1, zip successors (repeat ()))
where
allUnique l = length (S.fromList l) == length l
return (h1, fmap (,()) successors)
instance RefinementInterface Powerset where
......
......@@ -108,4 +108,4 @@ instance ParseMorphism SomeFunctor where
where
fRep = typeRep @tf
convert = (\(h1, succs) -> (SomeH1 fRep h1, map (\(x,y) -> (x, SomeLabel fRep y)) succs))
convert = (\(h1, succs) -> (SomeH1 fRep h1, fmap (\(x,y) -> (x, SomeLabel fRep y)) succs))
......@@ -105,7 +105,7 @@ type instance Label Id = ()
instance ParseMorphism Id where
parseMorphismPoint (Id inner) = do
suc <- inner
return ((), ([(suc, ())]))
return ((), (V.singleton (suc, ())))
data Powerset a = P a
deriving (Functor)
......@@ -115,8 +115,8 @@ type instance Label Powerset = ()
instance ParseMorphism Powerset where
parseMorphismPoint (P inner) = do
succs <- brackets (inner `sepBy` comma)
return (null succs, zip succs (repeat ()))
succs <- V.fromList <$> brackets (inner `sepBy` comma)
return (null succs, V.map (,()) succs)
data FixedProduct a = FP [Text] a
deriving (Functor)
......@@ -128,7 +128,7 @@ instance ParseMorphism FixedProduct where
parseMorphismPoint (FP labels inner) = do
(h1, suc) <-
parens ((,) <$> choice (map (try . symbol) labels) <*> (comma *> inner))
return (h1, [(suc, ())])
return (h1, V.singleton (suc, ()))
data SomeFunctor a where
SomeFunctor
......@@ -179,7 +179,7 @@ instance ParseMorphism SomeFunctor where
convertOuter (parseMorphismPoint f)
where
convertOuter = fmap (\(h1, succs) -> (SomeH1 h1, map (_2 %~ SomeLabel) succs))
convertOuter = fmap (\(h1, succs) -> (SomeH1 h1, fmap (_2 %~ SomeLabel) succs))
parsing :: (Functor f, ParseMorphism f) => FunctorExpression f Sort
-> Text
......
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