39 lines
1.4 KiB
Haskell
39 lines
1.4 KiB
Haskell
module InstantRunoff where
|
|
import qualified Data.List as L
|
|
import qualified Data.List.NonEmpty as LN
|
|
import qualified Data.Map.Strict as M
|
|
import qualified Data.Maybe as My
|
|
import qualified Data.Set as S
|
|
import Data.Ord
|
|
import Data.Maybe
|
|
import Data.Ratio
|
|
|
|
|
|
solve :: Ord a => LN.NonEmpty (LN.NonEmpty a) -> LN.NonEmpty a
|
|
solve votes =
|
|
case (L.find (\(_, share) -> share > (1 % 2)) . assocs) of
|
|
Just (winner, share) -> return winner -- singleton not introduced until base 4.15
|
|
Nothing -> solve . remove $ S.insert noFirstChoice firstChoiceLoser
|
|
where
|
|
|
|
-- fromList is partial, but inputs that would cause a faliure are caught by the case statement
|
|
remove :: S.Set a -> LN.NonEmpty (LN.NonEmpty a)
|
|
remove toRemove = LN.fromList . LN.filter null . LN.map (`elem` toRemove) $ votes
|
|
|
|
firstChoiceLoser :: a
|
|
firstChoiceLoser = L.minimumBy (\(_, a0) (_, a1) -> compare a0 a1) . LN.map LN.head $ voteShares'
|
|
|
|
firstChoices :: LN.NonEmpty a
|
|
firstChoices = LN.map LN.head $ votes
|
|
|
|
voteShares' :: LN.NonEmpty a -> M.Map a (Ratio Int)
|
|
voteShares' = voteShares firstChoices
|
|
|
|
noFirstChoice :: S.Set a
|
|
noFirstChoice = (S.fromList LN.toList . mconcat $ votes) S.\\ (S.fromList . LN.toList $ firstChoices)
|
|
|
|
allSame :: Eq a => [a] -> Bool
|
|
allSame = (== 1) . LN.length . LN.nub
|
|
|
|
voteShares :: Ord a => LN.NonEmpty a -> M.Map a (Ratio Int)
|
|
voteShares l = M.map (% (LN.length l)) . M.fromListWith (+) . map (, 1) . LN.toList $ l
|