Introduce `normalizeDown`

1 files changed, 43 insertions, 12 deletions

diff --git a/lib/Malodivo/Budget.hs b/lib/Malodivo/Budget.hs
index 438d868..a707cec 100644
--- a/lib/Malodivo/Budget.hs
+++ b/lib/Malodivo/Budget.hs
@@ -5,6 +5,7 @@ Budget planning in the Kingdom of Malodivo.
 -}
 module Malodivo.Budget
   ( DistrictFunds
+  , normalizeDown
   , manyToOne
   , manyToMany
   ) where
@@ -18,6 +19,39 @@ import qualified Malodivo.Types.District as D
 type DistrictFunds = HM.HashMap D.District Integer
 
 {-|
+Normalize list of integers, i. e. proportionally decrease each list element
+so that the sum of all elements does not exceed given limit.
+
+>>> normalizeDown 10 [10, 20, 30, 40]
+[1,2,3,4]
+
+>>> normalizeDown 9 [11]
+[9]
+
+
+If requested maximum sum is larger or equal to the sum of input list, the
+list is not changed:
+
+>>> normalizeDown 101 [10, 20, 30, 40]
+[10,20,30,40]
+
+__TODO__ It /should/ be generalized to
+<https://en.wikipedia.org/wiki/Partition_(number_theory) integer partition>
+so that the sums of input and output lists are equal to each other. Currently
+it is not guaranteed and the numbers are rounded down if necessary.
+-}
+normalizeDown ::
+     Integer -- ^ Maximum sum of all list items.
+  -> [Integer] -- ^ Initial list.
+  -> [Integer] -- ^ Normalized list.
+normalizeDown maxSum inList
+  | inSum <= maxSum = inList
+  | otherwise = norm <$> inList
+  where
+    inSum = sum inList
+    norm i = maxSum * i `div` inSum
+
+{-|
 
 Trivial case: many districts, one bill, no constraints (wishes,
 limits).  We assume that, with no explicit wishes, each district
@@ -94,7 +128,7 @@ manyToOne ::
      DistrictFunds -- ^ Amounts of available funds per district.
   -> B.Bill -- ^ A bill requiring funding.
   -> DistrictFunds -- ^ Contribution of each district.
-manyToOne funds bill = fundRaising funds (B.amount bill)
+manyToOne funds bill = fundRaising (B.amount bill) funds
 
 {-|
 Districts funding multiple bills. No constraints.
@@ -125,21 +159,18 @@ manyToMany ::
      DistrictFunds -- ^ Amounts of available funds per district.
   -> [B.Bill] -- ^ Bills requiring funding.
   -> [DistrictFunds] -- ^ Contribution of each district to each bill.
-manyToMany funds bills = fundRaising funds <$> amountsAllocated
+manyToMany funds bills =
+  flip fundRaising funds <$> normalizeDown fundsTotal billAmounts
   where
+    billAmounts = B.amount <$> bills
     fundsTotal = sum $ HM.elems funds
-    billsTotal = sum $ B.amount <$> bills
-    requestTotal = min billsTotal fundsTotal
-    allocale bill = requestTotal * B.amount bill `div` billsTotal
-    amountsAllocated = allocale <$> bills
 
 -- | Helper function to maintain DRY and backward compatibility.
 fundRaising ::
-     DistrictFunds -- ^ Amounts of available funds per district.
-  -> Integer -- ^ Amount to be raised.
+     Integer -- ^ Amount to be raised.
+  -> DistrictFunds -- ^ Amounts of available funds per district.
   -> DistrictFunds -- ^ Contribution of each district.
-fundRaising funds needed = HM.map takeMoney funds
+fundRaising needed df = HM.fromList $ zip districts funds'
   where
-    available = sum $ HM.elems funds
-    request = min needed available
-    takeMoney m = request * m `div` available
+    (districts, funds) = unzip $ HM.toList df
+    funds' = normalizeDown needed funds