From 1b23b6b3e4f90471e162200bfcbc526d39f51b4b Mon Sep 17 00:00:00 2001
From: Hans-Peter Deifel <hpd@hpdeifel.de>
Date: Sun, 5 Aug 2018 10:54:28 +0200
Subject: [PATCH] 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.
---
src/MA/Functors/Distribution.hs | 7 ++++---
src/MA/Functors/MonoidValued.hs | 28 +++++++++++++++++++---------
2 files changed, 23 insertions(+), 12 deletions(-)
diff --git a/src/MA/Functors/Distribution.hs b/src/MA/Functors/Distribution.hs
index 46b3157..daf1724 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 bd15ca2..3d11e19 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
+ )
--
GitLab