apportionment (empty) → 0.0
raw patch · 4 files changed
+164/−0 lines, 4 filesdep +basedep +containersdep +utility-htsetup-changed
Dependencies added: base, containers, utility-ht
Files
- LICENSE +30/−0
- Setup.lhs +3/−0
- apportionment.cabal +26/−0
- src/Math/Apportionment.hs +105/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Henning Thielemann++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Henning Thielemann nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ apportionment.cabal view
@@ -0,0 +1,26 @@+Name: apportionment+Version: 0.0+Synopsis: Round a set of numbers while maintaining its sum+Description:+ Round a set of numbers while maintaining its sum.+ According procedures are used to assign seats to parties in a parliament.+ You may also use it to round percentages that sum up to 100%.+ <https://en.wikipedia.org/wiki/Apportionment_(politics)>+Homepage: http://hub.darcs.net/thielema/apportionment+License: BSD3+License-File: LICENSE+Author: Henning Thielemann+Maintainer: haskell@henning-thielemann.de+Category: Math+Build-Type: Simple+Cabal-Version: >=1.10++Library+ Exposed-Modules: Math.Apportionment+ Build-Depends:+ containers >=0.4.2 && <0.5,+ utility-ht >=0.0 && <0.1,+ base >=4.5 && <4.6+ Hs-Source-Dirs: src+ Default-Language: Haskell2010+ GHC-Options: -Wall
+ src/Math/Apportionment.hs view
@@ -0,0 +1,105 @@+module Math.Apportionment (+ largestRemainder,+ largestRemainderScaled,++ highestAveragesScaled,+ dHondtDivisors,+ sainteLagueDivisors,+ ) where++import Control.Functor.HT (outerProduct, )++import qualified Data.Foldable as Fold+import qualified Data.List.HT as ListHT+import qualified Data.List as List+import qualified Data.Map as Map+import Data.Function.HT (compose2, )+import Data.Tuple.HT (mapSnd, )+import Data.Ord.HT (comparing, )+++{- |+Like 'largestRemainder' but result values+are sorted with respect to descending fractional parts of the inputs.+This is an artifact of the used algorithm.+The result still depends on the input order,+especially on the order of numbers with equal fractional part.+-}+_largestRemainderSort :: (RealFrac a) => [a] -> [Int]+_largestRemainderSort xs =+ let (d, intFracs) = fractions xs+ (intUps, intDowns) =+ splitAt d $ map fst $+ List.sortBy (comparing (negate.snd)) intFracs+ in map (1+) intUps ++ intDowns++{- |+This function rounds values+such that the sum of the rounded values+matches the rounded sum of the original values.++Also known as Hare-Niemeyer method.+<https://en.wikipedia.org/wiki/Largest_remainder_method>++Input values must be non-negative, otherwise 'properFraction' bites us.+-}+largestRemainder :: (RealFrac a) => [a] -> [Int]+largestRemainder = largestRemainderCore . fractions++{- |+@largestRemainderScaled s xs@+scales and rounds the values in @xs@ such that their sum becomes @s@.++E.g. @largestRemainderScaled 100 [1,2,3]@+returns integral percentages proportional to 1:2:3.+-}+largestRemainderScaled :: (RealFrac a) => Int -> [a] -> [Int]+largestRemainderScaled s = largestRemainderCore . fractionsScaled s+++type Fractions a = (Int, [(Int, a)])++largestRemainderCore :: (RealFrac a) => Fractions a -> [Int]+largestRemainderCore (d, intFracs) =+ let (intUps, intDowns) =+ splitAt d $ map (mapSnd fst) $+ List.sortBy (comparing (negate . snd . snd)) $+ zip [(0::Int) .. ] intFracs+ in map snd $ List.sortBy (comparing fst) $+ map (mapSnd (1+)) intUps ++ intDowns++fractions :: (RealFrac a) => [a] -> Fractions a+fractions xs =+ let xsum = round $ sum xs+ intFracs = map properFraction xs+ isum = sum $ map fst intFracs+ in (xsum-isum, intFracs)++fractionsScaled :: (RealFrac a) => Int -> [a] -> Fractions a+fractionsScaled xsum xs =+ let c = fromIntegral xsum / sum xs+ intFracs = map (properFraction . (* c)) xs+ isum = sum $ map fst intFracs+ in (xsum-isum, intFracs)+++{- |+<https://en.wikipedia.org/wiki/Highest_averages_method>++In @highestAveragesScaled divs s xs@,+@divs@ must be an infinite list of strictly increasing positive numbers.+E.g. @highestAveragesScaled dHondtDivisors s xs@ runs the d'Hondt method.+-}+highestAveragesScaled :: (RealFrac a) => [a] -> Int -> [a] -> [Int]+highestAveragesScaled divs s xs =+ let m = Map.fromList $ zip [(0::Int) ..] xs+ in Map.elems $ flip Map.union (fmap (const 0) m) $+ Map.fromListWith (+) $ map (mapSnd (const 1)) $+ take s $ Fold.foldl (ListHT.mergeBy (compose2 (>=) snd)) [] $+ Map.mapWithKey (map . (,)) $ outerProduct (/) m divs++dHondtDivisors :: Num a => [a]+dHondtDivisors = iterate (1+) 1++sainteLagueDivisors :: Num a => [a]+sainteLagueDivisors = iterate (2+) 1