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

Make MonoidValued functor implementation more strict

This improves running times slightly and may avoid space leaks that
arise from holding on to the labels-list for too long.
parent e3a5e55c
...@@ -47,8 +47,8 @@ instance ParseMorphism Distribution where ...@@ -47,8 +47,8 @@ instance ParseMorphism Distribution where
return (h1, succs) return (h1, succs)
instance RefinementInterface Distribution where instance RefinementInterface Distribution where
init _ _ = (0, 1) init _ _ = MonoidWeight 0 1
update weightsToS (toRest, toC) = update weightsToS (MonoidWeight toRest toC) =
let let
toS = sum weightsToS toS = sum weightsToS
toCwithoutS = toC - toS toCwithoutS = toC - toS
...@@ -58,4 +58,5 @@ instance RefinementInterface Distribution where ...@@ -58,4 +58,5 @@ instance RefinementInterface Distribution where
then mkRes (toRest, toCwithoutS, toS) then mkRes (toRest, toCwithoutS, toS)
else mkRes (0, 0, 1) else mkRes (0, 0, 1)
where where
mkRes h3@(a, b, c) = ((a + b, c), h3, (a + c, b)) mkRes h3@(a, b, c) =
( MonoidWeight (a + b) c, MonoidH3 a b c, MonoidWeight (a + c) b )
...@@ -11,6 +11,8 @@ module MA.Functors.MonoidValued ...@@ -11,6 +11,8 @@ module MA.Functors.MonoidValued
( intValued ( intValued
, realValued , realValued
, MonoidValued(..) , MonoidValued(..)
, MonoidWeight(..)
, MonoidH3(..)
) where ) where
import Control.Monad (when) import Control.Monad (when)
...@@ -46,10 +48,14 @@ realValued :: FunctorParser (MonoidValued Double) ...@@ -46,10 +48,14 @@ realValued :: FunctorParser (MonoidValued Double)
realValued = prefix realValued = prefix
((L.symbol "R" <|> L.symbol "ℝ") >> L.symbol "^" >> pure RealValued) ((L.symbol "R" <|> L.symbol "ℝ") >> L.symbol "^" >> pure RealValued)
data MonoidWeight m = MonoidWeight !m !m
data MonoidH3 m = MonoidH3 !m !m !m
deriving (Eq, Ord, Show)
type instance Label (MonoidValued m) = m type instance Label (MonoidValued m) = m
type instance Weight (MonoidValued m) = (m, m) type instance Weight (MonoidValued m) = MonoidWeight m
type instance H1 (MonoidValued m) = m type instance H1 (MonoidValued m) = m
type instance H3 (MonoidValued m) = (m, m, m) type instance H3 (MonoidValued m) = MonoidH3 m
parseMorphismPointHelper :: parseMorphismPointHelper ::
(Num w, Ord x, MonadParser m) (Num w, Ord x, MonadParser m)
...@@ -77,16 +83,20 @@ instance ParseMorphism (MonoidValued Int) where ...@@ -77,16 +83,20 @@ instance ParseMorphism (MonoidValued Int) where
instance ParseMorphism (MonoidValued Double) where instance ParseMorphism (MonoidValued Double) where
parseMorphismPoint (RealValued inner) = parseMorphismPointHelper inner L.float parseMorphismPoint (RealValued inner) = parseMorphismPointHelper inner L.float
instance (Num m, Ord m, Show m) => RefinementInterface (MonoidValued m) where instance (Num m, Ord m) => RefinementInterface (MonoidValued m) where
init :: H1 (MonoidValued m) -> [Label (MonoidValued m)] -> Weight (MonoidValued m) init :: H1 (MonoidValued m) -> [Label (MonoidValued m)] -> Weight (MonoidValued m)
init _ weights = (0, sum weights) init _ weights = MonoidWeight 0 (sum weights)
update :: [Label (MonoidValued m)] -> Weight (MonoidValued m) update :: [Label (MonoidValued m)] -> Weight (MonoidValued m)
-> (Weight (MonoidValued m), H3 (MonoidValued m), Weight (MonoidValued m)) -> (Weight (MonoidValued m), H3 (MonoidValued m), Weight (MonoidValued m))
update weightsToS (toRest, toC) = update weightsToS (MonoidWeight toRest toC) =
let let
toS = sum weightsToS !toS = sum weightsToS
toCwithoutS = toC - toS !toCwithoutS = toC - toS
toNotS = toRest + toCwithoutS !toNotS = toRest + toCwithoutS
!toNotC = toRest + toS
in in
((toNotS, toS), (toRest, toCwithoutS, toS), (toRest + toS, toCwithoutS)) ( MonoidWeight toNotS toS
, MonoidH3 toRest toCwithoutS toS
, MonoidWeight toNotC toCwithoutS
)
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