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
return (h1, succs)
instance RefinementInterface Distribution where
init _ _ = (0, 1)
update weightsToS (toRest, toC) =
init _ _ = MonoidWeight 0 1
update weightsToS (MonoidWeight toRest toC) =
let
toS = sum weightsToS
toCwithoutS = toC - toS
......@@ -58,4 +58,5 @@ instance RefinementInterface Distribution where
then mkRes (toRest, toCwithoutS, toS)
else mkRes (0, 0, 1)
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
( intValued
, realValued
, MonoidValued(..)
, MonoidWeight(..)
, MonoidH3(..)
) where
import Control.Monad (when)
......@@ -46,10 +48,14 @@ realValued :: FunctorParser (MonoidValued Double)
realValued = prefix
((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 Weight (MonoidValued m) = (m, m)
type instance Weight (MonoidValued m) = MonoidWeight m
type instance H1 (MonoidValued m) = m
type instance H3 (MonoidValued m) = (m, m, m)
type instance H3 (MonoidValued m) = MonoidH3 m
parseMorphismPointHelper ::
(Num w, Ord x, MonadParser m)
......@@ -77,16 +83,20 @@ instance ParseMorphism (MonoidValued Int) where
instance ParseMorphism (MonoidValued Double) where
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 _ weights = (0, sum weights)
init _ weights = MonoidWeight 0 (sum weights)
update :: [Label (MonoidValued m)] -> Weight (MonoidValued m)
-> (Weight (MonoidValued m), H3 (MonoidValued m), Weight (MonoidValued m))
update weightsToS (toRest, toC) =
update weightsToS (MonoidWeight toRest toC) =
let
toS = sum weightsToS
toCwithoutS = toC - toS
toNotS = toRest + toCwithoutS
!toS = sum weightsToS
!toCwithoutS = toC - toS
!toNotS = toRest + toCwithoutS
!toNotC = toRest + toS
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