diff --git a/src/MA/Functors/Distribution.hs b/src/MA/Functors/Distribution.hs index 46b315762213eb0dc30e5931dc0ff9497a532767..daf1724a0f6f9c1c7bd998af2fb74ff2459720cd 100644 --- a/src/MA/Functors/Distribution.hs +++ b/src/MA/Functors/Distribution.hs @@ -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 ) diff --git a/src/MA/Functors/MonoidValued.hs b/src/MA/Functors/MonoidValued.hs index bd15ca2d035efed9a120a84dd4be41debd12f7fd..3d11e1954214ac9fb929163aad8fc9ba0ff30597 100644 --- a/src/MA/Functors/MonoidValued.hs +++ b/src/MA/Functors/MonoidValued.hs @@ -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 + )