module Penny.Lincoln.Bits.Qty
( Qty
, NumberStr(..)
, toQty
, mantissa
, places
, prettyShowQty
, compareQty
, newQty
, Mantissa
, Places
, add
, mult
, Difference(LeftBiggerBy, RightBiggerBy, Equal)
, difference
, allocate
, TotSeats
, PartyVotes
, SeatsWon
, largestRemainderMethod
, qtyOne
) where
import qualified Control.Monad.Exception.Synchronous as Ex
import qualified Data.Binary as B
import GHC.Generics (Generic)
import Data.List (genericLength, genericReplicate, genericSplitAt, sortBy)
import Data.Ord (comparing)
import qualified Penny.Lincoln.Equivalent as Ev
data NumberStr =
Whole String
| WholeRad String
| WholeRadFrac String String
| RadFrac String
deriving Show
toQty :: NumberStr -> Maybe Qty
toQty ns = case ns of
Whole s -> fmap (\m -> Qty m 0) (readInteger s)
WholeRad s -> fmap (\m -> Qty m 0) (readInteger s)
WholeRadFrac w f -> fromWholeRadFrac w f
RadFrac f -> fromWholeRadFrac "0" f
where
fromWholeRadFrac w f =
fmap (\m -> Qty m (genericLength f)) (readInteger (w ++ f))
readInteger :: String -> Maybe Integer
readInteger s = case reads s of
(i, ""):[] -> if i < 0 then Nothing else Just i
_ -> Nothing
data Qty = Qty { mantissa :: !Integer
, places :: !Integer
} deriving (Eq, Generic, Show, Ord)
prettyShowQty :: Qty -> String
prettyShowQty q =
let man = show . mantissa $ q
e = places q
len = genericLength man
small = "0." ++ ((genericReplicate (e len) '0') ++ man)
in case compare e len of
GT -> small
EQ -> small
LT ->
let (b, end) = genericSplitAt (len e) man
in if e == 0
then man
else b ++ ['.'] ++ end
instance Ev.Equivalent Qty where
equivalent x y = x' == y'
where
(x', y') = equalizeExponents x y
compareEv x y = compare x' y'
where
(x', y') = equalizeExponents x y
instance B.Binary Qty
type Mantissa = Integer
type Places = Integer
qtyOne :: Qty
qtyOne = Qty 1 0
newQty :: Mantissa -> Places -> Maybe Qty
newQty m p
| m > 0 && p >= 0 = Just $ Qty m p
| otherwise = Nothing
compareQty :: Qty -> Qty -> Ordering
compareQty q1 q2 = compare (mantissa q1') (mantissa q2')
where
(q1', q2') = equalizeExponents q1 q2
equalizeExponents :: Qty -> Qty -> (Qty, Qty)
equalizeExponents x y = (x', y')
where
(ex, ey) = (places x, places y)
(x', y') = case compare ex ey of
GT -> (x, increaseExponent (ex ey) y)
LT -> (increaseExponent (ey ex) x, y)
EQ -> (x, y)
increaseExponent :: Integer -> Qty -> Qty
increaseExponent i (Qty m e) = Qty m' e'
where
amt = abs i
m' = m * 10 ^ amt
e' = e + amt
increaseExponentTo :: Integer -> Qty -> Qty
increaseExponentTo i q@(Qty _ e) =
let diff = i e
in if diff >= 0 then increaseExponent diff q else q
data Difference =
LeftBiggerBy Qty
| RightBiggerBy Qty
| Equal
deriving (Eq, Show)
difference :: Qty -> Qty -> Difference
difference x y =
let (x', y') = equalizeExponents x y
(mx, my) = (mantissa x', mantissa y')
in case compare mx my of
GT -> LeftBiggerBy (Qty (mx my) (places x'))
LT -> RightBiggerBy (Qty (my mx) (places x'))
EQ -> Equal
add :: Qty -> Qty -> Qty
add x y =
let ((Qty xm e), (Qty ym _)) = equalizeExponents x y
in Qty (xm + ym) e
mult :: Qty -> Qty -> Qty
mult (Qty xm xe) (Qty ym ye) = Qty (xm * ym) (xe + ye)
allocate :: Qty -> (Qty, [Qty]) -> (Qty, [Qty])
allocate tot (q1, qs) = case allocate' tot (q1:qs) of
[] -> error "allocate error"
x:xs -> (x, xs)
allocate'
:: Qty
-> [Qty]
-> [Qty]
allocate' tot ls =
let ((tot':ls'), e) = sameExponent (tot:ls)
(moreE, (_, ss)) =
multRemainderAllResultsAtLeast1 (mantissa tot')
(map mantissa ls')
totE = e + moreE
in map (\m -> Qty m totE) ss
sameExponent
:: [Qty]
-> ([Qty], Integer)
sameExponent ls =
let newExp = maximum . fmap places $ ls
in (map (increaseExponentTo newExp) ls, newExp)
type Multiplier = Integer
multLargestRemainder
:: TotSeats
-> [PartyVotes]
-> Multiplier
-> (TotSeats, [SeatsWon])
multLargestRemainder ts pv m =
let ts' = ts * 10 ^ m
pv' = map (\x -> x * 10 ^ m) pv
in (ts', largestRemainderMethod ts' pv')
increasingMultRemainder
:: TotSeats
-> [PartyVotes]
-> [(Multiplier, (TotSeats, [SeatsWon]))]
increasingMultRemainder ts pv =
zip [0..] (map (multLargestRemainder ts pv) [0..])
multRemainderAllResultsAtLeast1
:: TotSeats
-> [PartyVotes]
-> (Multiplier, (TotSeats, [SeatsWon]))
multRemainderAllResultsAtLeast1 ts pv
= head
. dropWhile (any (< 1) . snd . snd)
$ increasingMultRemainder ts pv
type AutoSeats = Integer
type PartyVotes = Integer
type TotVotes = Integer
type TotSeats = Integer
type Remainder = Rational
type SeatsWon = Integer
largestRemainderMethod
:: TotSeats
-> [PartyVotes]
-> [SeatsWon]
largestRemainderMethod ts pvs =
let err s = error $ "largestRemainderMethod: error: " ++ s
in Ex.resolve err $ do
Ex.assert "TotalSeats not positive" (ts > 0)
Ex.assert "sum of [PartyVotes] not positive" (sum pvs > 0)
Ex.assert "negative member of [PartyVotes]" (minimum pvs >= 0)
return (allocRemainder ts . allocAuto ts $ pvs)
autoAndRemainder
:: TotSeats -> TotVotes -> PartyVotes -> (AutoSeats, Remainder)
autoAndRemainder ts tv pv =
let fI = fromIntegral :: Integer -> Rational
quota = if ts == 0
then error "autoAndRemainder: zero total seats"
else if tv == 0
then error "autoAndRemainder: zero total votes"
else fI tv / fI ts
in properFraction (fI pv / quota)
allocAuto :: TotSeats -> [PartyVotes] -> [(AutoSeats, Remainder)]
allocAuto ts pvs = map (autoAndRemainder ts (sum pvs)) pvs
allocRemainder
:: TotSeats
-> [(AutoSeats, Remainder)]
-> [SeatsWon]
allocRemainder ts ls =
let totLeft = ts (sum . map fst $ ls)
(leftForEach, stillLeft) = totLeft `divMod` genericLength ls
wIndex = zip ([0..] :: [Integer]) ls
sorted = sortBy (comparing (snd . snd)) wIndex
wOrder = zip [0..] sorted
awarder (ord, (ix, (as, _))) =
if ord < stillLeft
then (ix, as + leftForEach + 1)
else (ix, as + leftForEach)
awarded = map awarder wOrder
in map snd . sortBy (comparing fst) $ awarded