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

Speed up polynomial functor for large products

This speeds up the polynomial functor by a factor of 4-5 for some of
my tests and also reduces memory usage considerably by using much more
efficient data structures for `H1 Polynomial`, `Weight Polynomial` and
`H3 Polynomial` (e.g bit-arrays instead of a recursive data structure
filled with `Bool`s).

This is most noticeable for DFAs which are essentially `X^A`, where A
is the input alphabet and can be large.
parent cbe5bfdc
......@@ -32,16 +32,20 @@ import Data.Maybe (fromMaybe)
import GHC.Generics (Generic)
import Data.List (intersperse)
import Data.Semigroup ((<>))
import Data.Traversable
import Data.Word (Word8)
import qualified Data.Vector.Utils as V
import Data.Text (Text)
import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as VU
import Text.Megaparsec
import Data.Eq.Deriving (deriveEq1)
import Text.Show.Deriving (deriveShow1)
import Lens.Micro
import Control.DeepSeq (NFData)
import qualified Data.IntSet as S
import MA.PrettyShow
import MA.Coalgebra.Parser
......@@ -174,10 +178,10 @@ instance PrettyShow a => PrettyShow (FactorValue a) where
prettyShow (ExponentialValue v) =
"[" <> mconcat (intersperse ", " (map prettyShow (V.toList v))) <> "]"
data Three = ToRest | ToCompound | ToSub
deriving (Show, Eq, Ord, Enum)
type Three = Word8 -- ToRest | ToCompound | ToSub
--deriving (Show, Eq, Ord, Enum)
type instance H1 Polynomial = SumValue ()
type instance H1 Polynomial = (Int, Int, Vector Int)
-- | Tuple @(a, b)@ of
--
......@@ -186,12 +190,12 @@ type instance H1 Polynomial = SumValue ()
--
-- For "Identity"s, @b@ is 0. Also note that the top-level co-product doesn't
-- appear in the label at all. It already appears in "H1".
type instance Label Polynomial = (Int, Int)
type instance Label Polynomial = Int
-- | Defined as H2
type instance Weight Polynomial = SumValue Bool
type instance Weight Polynomial = VU.Vector Bool
type instance H3 Polynomial = SumValue Three
type instance H3 Polynomial = VU.Vector Three
instance ParseMorphism Polynomial where
parseMorphismPoint (Polynomial expr) = parseSum1 expr
......@@ -201,7 +205,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 (), Vector (a, Label Polynomial))
MonadParser m => Sum (m a) -> m (H1 Polynomial, Vector (a, Label Polynomial))
parseSum1 sum@(Sum (product :| [])) = do
-- only a single summand => parse product directly
......@@ -210,7 +214,7 @@ parseSum1 sum@(Sum (product :| [])) = do
-- This avoids strange situations where a constant calle 'inj' exists and the
-- input starts with inj.
(try parseSumPrefix >>= parseSum sum) <|>
(first (SumValue 0) <$> parseProduct1 product)
(first (uncurry (0,,)) <$> parseProduct1 product)
parseSum1 other = parseSumPrefix >>= parseSum other -- otherwise, require 'inj'
<?> "coproduct injection"
......@@ -220,63 +224,69 @@ 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 (), Vector (a, Label Polynomial))
MonadParser m => Sum (m a) -> Int -> m (H1 Polynomial, Vector (a, Label Polynomial))
parseSum (Sum summands) i = do
when (i < 0 || i >= length summands) $
fail ("polynomial: injection " ++ show i ++ " is out of bounds")
(h1, successors) <- parseProduct1 (summands NonEmpty.!! i)
return (SumValue i h1, successors)
return (uncurry (i,,) h1, successors)
----------- Products parser
-- | Parse either a single factor without parens or a tuple.
parseProduct1 ::
MonadParser m => Product (m a) -> m (ProductValue (), Vector ((a, (Int, Int))))
MonadParser m => Product (m a) -> m ((Int, Vector Int), Vector (a, Label Polynomial))
parseProduct1 product@(Product (factor :| [])) =
let mkProduct f = f & _1 %~ (ProductValue . V.singleton)
& _2 %~ (_Just . each . _2 %~ (0,) <&> fromMaybe V.empty)
let mkProduct = either (\i -> ((0, V.singleton i), V.empty))
(\v -> ((length v, V.empty), v))
in (mkProduct <$> parseFactor factor) <|> parseProduct product
parseProduct1 other = parseProduct other
parseProduct ::
MonadParser m => Product (m a) -> m (ProductValue (), Vector (a, (Int, Int)))
parseProduct
:: MonadParser m
=> Product (m a)
-> m ((Int, Vector Int), Vector (a, Label Polynomial))
parseProduct (Product l@(f :| fs)) =
label ("a product of " ++ show (length l) ++ " element(s)") $ L.parens $ do
factors <- V.cons
factors <-
V.cons
<$> parseFactor f
<*> (V.fromList <$> traverse (\x -> L.comma *> parseFactor x) fs)
let (h1, successors) = V.unzip factors
labeledSuccessors =
V.imap
(\i x -> x & _Just . traversed . _2 %~ (i,) & fromMaybe V.empty)
successors
let
constants = V.fromList (factors ^.. each . _Left)
labels = factors ^.. each . _Right
(numFactors, successors) = mapAccumL
(\cur f -> (cur + length f, f & each . _2 %~ (+ cur)))
0
labels
return ( ProductValue h1 , fold labeledSuccessors)
return ((numFactors, constants), V.concat successors)
----------- Factor parser
parseFactor :: MonadParser m => Factor (m a) -> m (FactorValue (), Maybe (Vector (a, Int)))
parseFactor :: MonadParser m => Factor (m a) -> m (Either Int (Vector (a, Int)))
parseFactor (Const (ExplicitSet names)) = do
!h1 <- ConstValue <$> someName names
return (h1, Nothing) -- const has no successors
!h1 <- Left <$> someName names
return h1 -- const has no successors
parseFactor (Const IntSet) = do
x <- L.signed L.decimal <?> "integer"
return (ConstValue x, Nothing)
return (Left x)
parseFactor (Const NatSet) = do
x <- L.decimal <?> "natural number"
return (ConstValue x, Nothing)
return (Left x)
parseFactor (Const (FiniteNatSet n)) = do
x <- L.decimal <?> ("natural number small than " ++ show n)
unless (x < n) $
fail ("out of range constant: " ++ show x ++
"(must be between 0 and " ++ show n ++ ")")
return (ConstValue x, Nothing)
return (Left x)
parseFactor (Identity inner) = do
successor <- inner
return (IdValue (), Just (V.singleton (successor, 0)))
return (Right (V.singleton (successor, 0)))
parseFactor (Exponential inner exp) = L.braces $ do
successors <- V.sortOn snd . V.fromList <$>
(flip (,) <$> parseExpValue exp
......@@ -286,9 +296,7 @@ parseFactor (Exponential inner exp) = L.braces $ do
unless (allExpValues exp == (V.map snd successors)) $
fail ("exponential: map must be well-defined on " ++ showExp exp)
return ( ExponentialValue (V.replicate (length successors) ())
, Just successors
)
return (Right successors)
parseExpValue :: MonadParser m => Exponent -> m Int
parseExpValue (ExplicitExp names) = someName names
......@@ -315,7 +323,7 @@ someName v = do
instance RefinementInterface Polynomial where
init :: H1 Polynomial -> [Label Polynomial] -> Weight Polynomial
init h1 _ = fmap (const True) h1
init (_,n,_) _ = VU.replicate n True
update ::
[Label Polynomial]
......@@ -325,23 +333,12 @@ instance RefinementInterface Polynomial where
where
val :: H3 Polynomial -> (Weight Polynomial, H3 Polynomial, Weight Polynomial)
val h3 =
let toS = fmap (== ToSub) h3
toC = fmap (== ToCompound) h3
let toS = VU.map (== 0) h3
toC = VU.map (== 1) h3
in
(toS, h3, toC)
up :: ([Label Polynomial], Weight Polynomial) -> H3 Polynomial
up (labels, weight) = fmapIndex (\i j bi -> bi +? ((i,j) `elem` labels)) weight
(+?) :: Bool -> Bool -> Three
(+?) a b = toEnum (fromEnum a + fromEnum b)
fmapIndex :: forall a b. (Int -> Int -> a -> b) -> SumValue a -> SumValue b
fmapIndex f (SumValue !s (ProductValue !factors)) =
let !res = V.imap fmapFactor factors
in SumValue s (ProductValue res)
where
fmapFactor :: Int -> FactorValue a -> FactorValue b
fmapFactor i (ExponentialValue as) = ExponentialValue (V.imap (f i) as)
fmapFactor i other = (fmap (f i 0)) other
up (labels, weight) =
let labels'' = map (\i -> (i, toEnum (fromEnum (VU.unsafeIndex weight i)) + 1)) labels
in VU.unsafeUpd (VU.map (toEnum.fromEnum) weight :: VU.Vector Word8) labels''
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