Instant-runoff voting

IRV.hs

module IRV where

import Data.List (nub, sortBy)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Ord (Down(..), comparing)

winner :: Eq a => [[a]] -> Maybe a
winner votes = do
  let freqs = frequencies votes
  top <- topCandidate freqs
  if hasAbsoluteMajority top freqs
     then return top
     else do
       last <- lastCandidate freqs
       winner (removeFirstPref last votes)

frequencies :: Eq a => [[a]] -> [(a, Int)]
frequencies = group . catMaybes . map maybeHead

group :: Eq a => [a] -> [(a, Int)]
group xs = map count (nub xs)
  where count x = (x, length (filter (x ==) xs))

maybeHead :: [a] -> Maybe a
maybeHead (x:_) = Just x
maybeHead [] = Nothing

topCandidate :: Eq a => [(a, Int)] -> Maybe a
topCandidate = (fst <$>) . maybeHead . sortBy (comparing (Down . snd))

lastCandidate :: Eq a => [(a, Int)] -> Maybe a
lastCandidate freqs
  | allCandidatesTied freqs = Nothing -- It's a tie!
  | otherwise = fst <$> maybeHead (sortBy (comparing snd) freqs)

allCandidatesTied :: Eq a => [(a, Int)] -> Bool
allCandidatesTied (x:xs) = all (snd x ==) (map snd xs)
allCandidatesTied [] = True

hasAbsoluteMajority :: Eq a => a -> [(a, Int)] -> Bool
hasAbsoluteMajority candidate freqs = candidateVotes > totalVotes `div` 2
  where candidateVotes = fromMaybe 0 (lookup candidate freqs)
        totalVotes = sum (map snd freqs)

removeFirstPref :: Eq a => a -> [[a]] -> [[a]]
removeFirstPref candidate = map removeFirstPref'
  where removeFirstPref' [] = []
        removeFirstPref' prefs@(x:xs)
          | x == candidate = xs
          | otherwise = prefs