### 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