module Penny.Lincoln.Bits.Qty (
Qty, NumberStr(..), toQty, mantissa, places, newQty,
Mantissa, Places,
add, mult, Difference(LeftBiggerBy, RightBiggerBy, Equal),
equivalent, difference, allocate,
TotSeats, PartyVotes, SeatsWon, largestRemainderMethod) where
import qualified Control.Monad.Exception.Synchronous as Ex
import qualified Data.Foldable as F
import Data.List (genericLength, genericReplicate, genericSplitAt, sortBy)
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Ord (comparing)
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
type Mantissa = Integer
type Places = Integer
newQty :: Mantissa -> Places -> Maybe Qty
newQty m p
| m > 0 && p >= 0 = Just $ Qty m p
| otherwise = Nothing
instance Show Qty where
show (Qty m e) =
let man = show m
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 Ord Qty where
compare 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
equivalent :: Qty -> Qty -> Bool
equivalent x y = x' == y'
where
(x', y') = equalizeExponents x y
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
-> NonEmpty Qty
-> NonEmpty Qty
allocate tot ls =
let (tot', ls', e') = sameExponent tot ls
(tI, lsI) = (mantissa tot', fmap mantissa ls')
(seats, (p1 :| ps), moreE) = growTarget tI lsI
adjSeats = seats (genericLength ps + 1)
del = largestRemainderMethod adjSeats (p1 : ps)
totE = e' + moreE
r1:rs = fmap (\m -> Qty (m + 1) totE) del
in r1 :| rs
sameExponent
:: Qty
-> NonEmpty Qty
-> (Qty, NonEmpty Qty, Integer)
sameExponent dec ls =
let newExp = max (F.maximum . fmap places $ ls)
(places dec)
dec' = increaseExponentTo newExp dec
ls' = fmap (increaseExponentTo newExp) ls
in (dec', ls', newExp)
growTarget
:: Integer
-> NonEmpty Integer
-> (Integer, NonEmpty Integer, Integer)
growTarget target is = go target is 0
where
len = genericLength . F.toList $ is
go t xs c =
let t' = t * 10 ^ c
xs' = fmap (\x -> x * 10 ^ c) xs
in if t' > len
then (t', xs', c)
else go t' xs' (c + 1)
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
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