diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/apportionment.cabal b/apportionment.cabal new file mode 100644 --- /dev/null +++ b/apportionment.cabal @@ -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%. + +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 diff --git a/src/Math/Apportionment.hs b/src/Math/Apportionment.hs new file mode 100644 --- /dev/null +++ b/src/Math/Apportionment.hs @@ -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. + + +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) + + +{- | + + +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