```-- | Penny quantities. A quantity is simply a count (possibly
-- fractional) of something. It does not have a commodity or a
-- Debit/Credit.
module Penny.Lincoln.Bits.Qty (
Qty, NumberStr(..), toQty, mantissa, places, newQty,
Mantissa, Places,
equivalent, difference, allocate,

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
-- ^ A whole number only. No radix point.
-- ^ A whole number and a radix point, but nothing after the radix
-- point.
-- ^ A whole number and something after the radix point.
-- ^ A radix point and a fractional value after it, but nothing
deriving Show

-- | Converts strings to Qty. Fails if any of the strings have
-- non-digits, or if any are negative, or if the result is not greater
-- than zero, or if the strings are empty.
toQty :: NumberStr -> Maybe Qty
toQty ns = case ns of
Whole s -> fmap (\m -> Qty m 0) (readInteger s)
where
fmap (\m -> Qty m (genericLength f)) (readInteger (w ++ f))

-- | Reads non-negative integers only.
readInteger :: String -> Maybe Integer
(i, ""):[] -> if i < 0 then Nothing else Just i
_ -> Nothing

-- | A quantity is always greater than zero. Various odd questions
-- happen if quantities can be zero. For instance, what if you have a
-- debit whose quantity is zero? Does it require a balancing credit
-- that is also zero? And how can you have a debit of zero anyway?
--
-- I can imagine situations where a quantity of zero might be useful;
-- for instance maybe you want to specifically indicate that a
-- particular posting in a transaction did not happen (for instance,
-- that a paycheck deduction did not take place). I think the better
-- way to handle that though would be through an addition to
-- Debit/Credit - maybe Debit/Credit/Zero. Barring the addition of
-- that, though, the best way to indicate a situation such as this
-- would be through transaction memos.
--
-- The Eq instance is derived. Therefore q1 == q2 only if q1 and q2
-- have both the same mantissa and the same exponent. You may instead
-- want 'equivalent'.
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

-- | Shows a quantity, nicely formatted after accounting for both the
-- mantissa and decimal places, e.g. @0.232@ or @232.12@ or whatever.
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

-- | Compares Qty after equalizing their exponents.
--
-- > compare (newQty 15 1) (newQty 1500 3) == EQ
instance Ord Qty where
compare q1 q2 = compare (mantissa q1') (mantissa q2')
where
(q1', q2') = equalizeExponents q1 q2

-- | Adjust the exponents on two Qty so they are equivalent
-- before, but now have the same exponent.
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)

-- | Increase the exponent by the amount given, so that the new Qty is
-- equivalent to the old one. Takes the absolute value of the
increaseExponent :: Integer -> Qty -> Qty
increaseExponent i (Qty m e) = Qty m' e'
where
amt = abs i
m' = m * 10 ^ amt
e' = e + amt

-- | Increases the exponent to the given amount. Does nothing if the
-- exponent is already at or higher than this amount.
increaseExponentTo :: Integer -> Qty -> Qty
increaseExponentTo i q@(Qty _ e) =
let diff = i - e
in if diff >= 0 then increaseExponent diff q else q

-- | Compares Qty after equalizing their exponents.
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)

-- | Subtract the second Qty from the first, after equalizing their
-- exponents.
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
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 a Qty proportionally so that the sum of the results adds
-- up to a given Qty. Fails if the allocation cannot be made (e.g. if
-- it is impossible to allocate without overflowing Decimal.) The
-- result will always add up to the given sum.
allocate
:: Qty
-- ^ The result will add up to this Qty.

-> NonEmpty Qty
-- ^ Allocate using this list of Qty.

-> NonEmpty Qty
-- ^ The length of this list will be equal to the length of the list
-- of allocations. Each item will correspond to the original
-- allocation.

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

-- | Given a list of Decimals, and a single Decimal, return Decimals
-- that are equivalent to the original Decimals, but where all
-- Decimals have the same exponent. Also returns new exponent.
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)

-- | Given an Integer and a list of Integers, multiply all integers by
-- ten raised to an exponent, so that the first Integer is larger than
-- the count of the number of Integers in the list. Returns
-- the new Integer, new list of Integers, and the exponent used.
--
-- Previously this only grew the first Integer so that it was at least
-- as large as the count of Integers in the list, but this causes
-- problems, as there must be at least one seat for the allocation process.
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)

-- Largest remainder method: votes for one party is divided by
-- (total votes / number of seats). Result is an integer and a
-- remainder. Each party gets the number of seats indicated by its
-- integer. Parties are then ranked on the basis of the remainders, and
-- those with the largest remainders get an additional seat until all
-- seats have been distributed.
type AutoSeats = Integer
type TotSeats = Integer
type Remainder = Rational
type SeatsWon = Integer

-- | Allocates integers using the largest remainder method. This is
-- the method used to allocate parliamentary seats in many countries,
-- so the types are named accordingly.
largestRemainderMethod
:: TotSeats
-- ^ Total number of seats in the legislature. This is the integer
-- that will be allocated. This number must be positive or this
-- function will fail at runtime.

-- ^ The total seats will be allocated proportionally depending on
-- how many votes each party received. The sum of this list must be
-- positive, and each member of the list must be at least zero;
-- otherwise a runtime error will occur.

-> [SeatsWon]
-- ^ The sum of this list will always be equal to the total number
-- of seats, and its length will always be equal to length of the

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
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
```