module Penny.Lincoln.Bits.Qty
(
Digit(..)
, DigitList(..)
, Digits(..)
, Grouper(..)
, PeriodGrp(..)
, CommaGrp(..)
, GroupedDigits(..)
, WholeFrac
, whole
, frac
, wholeFrac
, wholeOrFrac
, WholeOrFracResult
, wholeOrFracToQtyRep
, WholeOnly
, unWholeOnly
, wholeOnly
, WholeOrFrac(..)
, Radix(..)
, showRadix
, QtyRep(..)
, qtyToRep
, qtyToRepNoGrouping
, qtyToRepGrouped
, showQtyRep
, bestRadGroup
, Qty
, HasQty(..)
, signif
, places
, compareQty
, newQty
, Signif
, Places
, add
, mult
, divide
, Difference(LeftBiggerBy, RightBiggerBy, Equal)
, difference
, allocate
, TotSeats
, PartyVotes
, SeatsWon
, largestRemainderMethod
, qtyOne
) where
import Control.Applicative ((<|>))
import Data.Text (Text)
import qualified Data.Text as X
import Data.Ord(comparing)
import Data.List ( genericLength, genericReplicate, sortBy, group, sort,
genericSplitAt )
import Data.List.Split (chunksOf)
import Data.List.NonEmpty (NonEmpty((:|)), toList, nonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import qualified Data.Semigroup(Semigroup(..))
import Data.Semigroup(sconcat)
import Data.Monoid ((<>))
import qualified Penny.Lincoln.Equivalent as Ev
import Penny.Lincoln.Equivalent (Equivalent(..))
import qualified Data.Sums as S
data Digit = D0 | D1 | D2 | D3 | D4 | D5 | D6 | D7 | D8 | D9
deriving (Eq, Ord, Show, Enum, Bounded)
data PeriodGrp
= PGSpace
| PGThinSpace
| PGComma
deriving (Eq, Show, Ord, Enum, Bounded)
data CommaGrp
= CGSpace
| CGThinSpace
| CGPeriod
deriving (Eq, Show, Ord, Enum, Bounded)
class Grouper a where
groupChar :: a -> Char
instance Grouper PeriodGrp where
groupChar c = case c of
PGSpace -> ' '
PGThinSpace -> '\x2009'
PGComma -> ','
instance Grouper CommaGrp where
groupChar c = case c of
CGSpace -> ' '
CGThinSpace -> '\x2009'
CGPeriod -> '.'
newtype DigitList = DigitList { unDigitList :: NonEmpty Digit }
deriving (Eq, Show, Ord)
instance Data.Semigroup.Semigroup DigitList where
(<>) (DigitList l1) (DigitList l2) =
DigitList $ l1 Data.Semigroup.<> l2
class Digits a where
digits :: a -> DigitList
instance Digits DigitList where
digits = id
instance Digits (GroupedDigits a) where
digits (GroupedDigits d1 dr) = sconcat (d1 :| map snd dr)
data GroupedDigits a = GroupedDigits
{ dsFirstPart :: DigitList
, dsNextParts :: [(a, DigitList)]
} deriving (Eq, Show, Ord)
data WholeFrac a = WholeFrac
{ whole :: a
, frac :: a
} deriving (Eq, Show, Ord)
wholeFrac
:: Digits a
=> a
-> a
-> Maybe (WholeFrac a)
wholeFrac w f = if digitsHasNonZero w || digitsHasNonZero f
then (Just (WholeFrac w f)) else Nothing
digitsHasNonZero :: Digits a => a -> Bool
digitsHasNonZero = any (/= D0) . toList . unDigitList . digits
newtype WholeOnly a = WholeOnly { unWholeOnly :: a }
deriving (Eq, Show, Ord)
wholeOnly :: Digits a => a -> Maybe (WholeOnly a)
wholeOnly d = if digitsHasNonZero d then Just (WholeOnly d) else Nothing
newtype WholeOrFrac a = WholeOrFrac
{ unWholeOrFrac :: Either (WholeOnly a) (WholeFrac a) }
deriving (Eq, Show, Ord)
type WholeOrFracResult a = Either (WholeOrFrac DigitList)
(WholeOrFrac (GroupedDigits a))
wholeOrFrac
:: GroupedDigits a
-> Maybe (GroupedDigits a)
-> Maybe (WholeOrFracResult a)
wholeOrFrac g@(GroupedDigits l1 lr) mayAft = case mayAft of
Nothing -> case lr of
[] -> fmap (Left . WholeOrFrac . Left) $ wholeOnly l1
_ -> fmap (Right . WholeOrFrac . Left) $ wholeOnly g
Just aft@(GroupedDigits r1 rr) -> case (lr, rr) of
([], []) -> fmap (Left . WholeOrFrac . Right) $ wholeFrac l1 r1
_ -> fmap (Right . WholeOrFrac . Right) $ wholeFrac g aft
data Radix = Period | Comma
deriving (Eq, Show, Ord, Enum, Bounded)
wholeOrFracToQtyRep
:: Either (WholeOrFracResult PeriodGrp) (WholeOrFracResult CommaGrp)
-> QtyRep
wholeOrFracToQtyRep e = case e of
Left p -> case p of
Left dl -> QNoGrouping dl Period
Right gd -> QGrouped (Left gd)
Right c -> case c of
Left dl -> QNoGrouping dl Comma
Right gd -> QGrouped (Right gd)
data QtyRep
= QNoGrouping (WholeOrFrac DigitList) Radix
| QGrouped (Either (WholeOrFrac (GroupedDigits PeriodGrp))
(WholeOrFrac (GroupedDigits CommaGrp)))
deriving (Eq, Show, Ord)
instance Equivalent QtyRep where
equivalent x y = showQtyRep x == showQtyRep y
compareEv x y = Ev.compareEv (toQty x) (toQty y)
intToDigits :: Integer -> NonEmpty Digit
intToDigits
= fmap intToDigit
. fromMaybe (error "intToDigits: show made empty list")
. nonEmpty
. show
where
intToDigit c = case c of
{ '0' -> D0; '1' -> D1; '2' -> D2; '3' -> D3; '4' -> D4;
'5' -> D5; '6' -> D6; '7' -> D7; '8' -> D8; '9' -> D9;
_ -> error "intToDigits: show made non-digit character" }
prependNonEmpty :: [a] -> NonEmpty a -> NonEmpty a
prependNonEmpty [] x = x
prependNonEmpty (x:xs) (y1 :| ys) = x :| (xs ++ (y1 : ys))
qtyToRepNoGrouping :: Qty -> WholeOrFrac DigitList
qtyToRepNoGrouping q =
let sig = intToDigits . signif $ q
e = places q
len = genericLength . toList $ sig
in WholeOrFrac $ if e == 0
then Left (WholeOnly (DigitList sig))
else if e < len
then let prefixLen = len e
(pfx, sfx) = genericSplitAt prefixLen . toList $ sig
ne = fromMaybe
(error "qtyToRepNoGrouping: nonEmpty failed")
. NE.nonEmpty
(pfxNE, sfxNE) = (ne pfx, ne sfx)
(w, f) = (DigitList pfxNE, DigitList sfxNE)
in Right (WholeFrac w f)
else let leadZeroes = genericReplicate (e len) D0
w = DigitList $ D0 :| []
f = DigitList $ prependNonEmpty leadZeroes sig
in Right (WholeFrac w f)
bestRadGroup
:: [QtyRep]
-> Maybe (S.S3 Radix PeriodGrp CommaGrp)
bestRadGroup ls = fromGrouping <|> fromRadix
where
grpToRadix q = case q of
QNoGrouping _ _ -> Nothing
QGrouped e -> Just $ either (const Period) (const Comma) e
mostCommonGrpRad = mode . mapMaybe grpToRadix $ ls
fromGrouping = do
rad <- mostCommonGrpRad
case rad of
Period -> fmap S.S3b . mostCommonPeriodGrp $ ls
Comma -> fmap S.S3c . mostCommonCommaGrp $ ls
fromRadix = fmap S.S3a . mode . mapMaybe noGrpToRadix $ ls
noGrpToRadix q = case q of
QNoGrouping _ r -> Just r
_ -> Nothing
mostCommonPeriodGrp :: [QtyRep] -> Maybe PeriodGrp
mostCommonPeriodGrp
= mode
. concatMap f
where
f q = case q of
QNoGrouping _ _ -> []
QGrouped e -> case e of
Left (WholeOrFrac ei) -> case ei of
Left _ -> []
Right (WholeFrac g1 g2) -> getSeps g1 ++ getSeps g2
Right _ -> []
mostCommonCommaGrp :: [QtyRep] -> Maybe CommaGrp
mostCommonCommaGrp
= mode
. concatMap f
where
f q = case q of
QNoGrouping _ _ -> []
QGrouped e -> case e of
Left _ -> []
Right (WholeOrFrac ei) -> case ei of
Left _ -> []
Right (WholeFrac g1 g2) -> getSeps g1 ++ getSeps g2
getSeps :: GroupedDigits a -> [a]
getSeps (GroupedDigits _ ls) = map fst ls
mode :: Ord a => [a] -> Maybe a
mode = listToMaybe . modes
newtype Down a = Down a
instance Eq a => Eq (Down a) where
(==) (Down x) (Down y) = x == y
instance Ord a => Ord (Down a) where
compare (Down x) (Down y) = case compare x y of
LT -> GT
GT -> LT
_ -> EQ
modes :: Ord a => [a] -> [a]
modes
= map (head . snd)
. sortBy (comparing (Down . fst))
. map (\ls -> (length ls, ls))
. group
. sort
groupDigits
:: NonEmpty a
-> (NonEmpty a, [NonEmpty a])
groupDigits
= toPair
. reverse
. map reverse
. chunksOf 3
. reverse
. toList
where
toPair [] = error "groupDigits: chunksOf produced empty list"
toPair (x:xs) = (ne x, map ne xs)
ne = fromMaybe (error $ "groupDigits: chunksOf produced"
++ " empty inner list") . nonEmpty
qtyToRepGrouped :: g -> Qty -> WholeOrFrac (GroupedDigits g)
qtyToRepGrouped g q = WholeOrFrac
$ case unWholeOrFrac $ qtyToRepNoGrouping q of
Left (WholeOnly (DigitList ds)) ->
Left $ WholeOnly (mkWholeGroups ds)
Right (WholeFrac w f) ->
Right $ mkWholeFracGroups (unDigitList w) (unDigitList f)
where
mkGroups ds =
let (g1, gs) = groupDigits ds
mkGrp dl = (g, DigitList dl)
in GroupedDigits (DigitList g1) (map mkGrp gs)
mkWholeGroups ds = if (length . toList $ ds) > maxUngrouped
then mkGroups ds
else GroupedDigits (DigitList ds) []
mkWholeFracGroups w f = WholeFrac w' f'
where
f' = GroupedDigits (DigitList f) []
w' = if (length . toList $ w) + (length . toList $ f)
> maxUngrouped
then mkGroups w
else GroupedDigits (DigitList w) []
maxUngrouped = 4
qtyToRep
:: S.S3 Radix PeriodGrp CommaGrp
-> Qty
-> QtyRep
qtyToRep x q = case x of
S.S3a r -> QNoGrouping (qtyToRepNoGrouping q) r
S.S3b g -> QGrouped . Left $ qtyToRepGrouped g q
S.S3c g -> QGrouped . Right $ qtyToRepGrouped g q
class HasQty a where
toQty :: a -> Qty
digitToInt :: Digit -> Integer
digitToInt d = case d of
{ D0 -> 0; D1 -> 1; D2 -> 2; D3 -> 3; D4 -> 4; D5 -> 5;
D6 -> 6; D7 -> 7; D8 -> 8; D9 -> 9 }
digitsToInt :: DigitList -> Integer
digitsToInt
= sum
. map (\(e, s) -> s * 10 ^ e)
. zip ([0..] :: [Integer])
. map digitToInt
. reverse
. toList
. unDigitList
instance HasQty QtyRep where
toQty q = case q of
QNoGrouping (WholeOrFrac ei) _ -> case ei of
Left (WholeOnly ds) -> Qty (digitsToInt ds) 0
Right (WholeFrac w f) -> Qty sig ex
where
sig = digitsToInt ((Data.Semigroup.<>) w f)
ex = genericLength . toList . unDigitList $ f
QGrouped ei -> either groupedToQty groupedToQty ei
groupedToQty :: WholeOrFrac (GroupedDigits a) -> Qty
groupedToQty (WholeOrFrac ei) = case ei of
Left (WholeOnly g) -> Qty (digitsToInt . digits $ g) 0
Right (WholeFrac w f) -> Qty sig ex
where
sig = digitsToInt ((Data.Semigroup.<>) (digits w) (digits f))
ex = genericLength . toList . unDigitList . digits $ f
instance HasQty Qty where
toQty = id
showDigit :: Digit -> Text
showDigit d = case d of
{ D0 -> "0"; D1 -> "1"; D2 -> "2"; D3 -> "3"; D4 -> "4";
D5 -> "5"; D6 -> "6"; D7 -> "7"; D8 -> "8"; D9 -> "9" }
showRadix :: Radix -> Text
showRadix r = case r of { Comma -> ","; Period -> "." }
showDigitList :: DigitList -> X.Text
showDigitList = X.concat . toList . fmap showDigit . unDigitList
showGroupedDigits
:: Grouper a
=> GroupedDigits a
-> Text
showGroupedDigits (GroupedDigits d ds)
= showDigitList d <> (X.concat . map f $ ds)
where
f (c, cs) = (X.singleton $ groupChar c) <> showDigitList cs
showWholeOnlyDigitList :: WholeOnly DigitList -> Text
showWholeOnlyDigitList = showDigitList . unWholeOnly
showWholeOnlyGroupedDigits
:: Grouper a
=> WholeOnly (GroupedDigits a)
-> Text
showWholeOnlyGroupedDigits = showGroupedDigits . unWholeOnly
showWholeFracDigitList
:: Radix
-> WholeFrac DigitList
-> Text
showWholeFracDigitList r wf
= showDigitList (whole wf) <> showRadix r <> showDigitList (frac wf)
showWholeFracGroupedDigits
:: Grouper a
=> Radix
-> WholeFrac (GroupedDigits a)
-> Text
showWholeFracGroupedDigits r wf
= showGroupedDigits (whole wf) <> showRadix r
<> showGroupedDigits (frac wf)
wholeOrFracGrouped
:: Grouper a
=> Radix
-> WholeOrFrac (GroupedDigits a)
-> Text
wholeOrFracGrouped r
= either showWholeOnlyGroupedDigits (showWholeFracGroupedDigits r)
. unWholeOrFrac
wholeOrFracDigitList
:: Radix
-> WholeOrFrac DigitList
-> Text
wholeOrFracDigitList r
= either showWholeOnlyDigitList (showWholeFracDigitList r)
. unWholeOrFrac
showQtyRep :: QtyRep -> Text
showQtyRep q = case q of
QNoGrouping wf r -> wholeOrFracDigitList r wf
QGrouped ei ->
either (wholeOrFracGrouped Period)
(wholeOrFracGrouped Comma) ei
data Qty = Qty
{ signif :: !Integer
, places :: !Integer
} deriving (Eq, Show, Ord)
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
type Signif = Integer
type Places = Integer
qtyOne :: Qty
qtyOne = Qty 1 0
newQty :: Signif -> Places -> Maybe Qty
newQty m p
| m > 0 && p >= 0 = Just $ Qty m p
| otherwise = Nothing
compareQty :: Qty -> Qty -> Ordering
compareQty q1 q2 = compare (signif q1') (signif 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) = (signif x', signif 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)
divide :: Fractional a => Qty -> Qty -> a
divide q1 q2 = toFloat q1 / toFloat q2
where
toFloat (Qty s p) = fromIntegral s / (10 ^ p)
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 (signif tot')
(map signif 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 either err id $ do
assert "TotalSeats not positive" (ts > 0)
assert "sum of [PartyVotes] not positive" (sum pvs > 0)
assert "negative member of [PartyVotes]" (minimum pvs >= 0)
return (allocRemainder ts . allocAuto ts $ pvs)
assert :: e -> Bool -> Either e ()
assert e b = if b then Right () else Left e
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