Jack/rcv-site
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

fixed instant runoff bug

Browse source 
Candidates that were no ones first choice should have been eliminated
first. Instead, they were skipped.
This commit is contained in:
Jack Wines 2023-06-17 01:58:55 -07:00
parent 7429c445a2
commit 651c86b136
2 changed files with 16 additions and 12 deletions
Download patch file Download diff file Expand all files Collapse all files

26
src/InstantRunoff.hs
View file

@ -2,30 +2,34 @@ module InstantRunoff where
import qualified Data.List as L import qualified Data.List as L
import qualified Data.List.NonEmpty as LN import qualified Data.List.NonEmpty as LN
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import qualified Data.Maybe as My
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Foldable as F
import Data.Ord
import Data.Maybe hiding (catMaybes)
import Data.Ratio
import qualified Data.Maybe as L import qualified Data.Maybe as L
solve :: Ord a => Show a => LN.NonEmpty (LN.NonEmpty a) -> [S.Set a] solve :: forall a. Ord a => Show a => LN.NonEmpty (LN.NonEmpty a) -> [S.Set a]
solve votes = maybe (L.singleton . M.keysSet $ voteCounts) ((firstChoiceLosers : ) . solve) . remove $ firstChoiceLosers solve votes = maybe (L.singleton . M.keysSet $ voteCounts) ((firstChoiceLosers : ) . solve) . remove $ firstChoiceLosers
where where
-- if Nothing, then all options in votes are valued equally -- if Nothing, then all options in votes are valued equally
-- remove :: S.Set a -> LN.NonEmpty (LN.NonEmpty a) -> Maybe (LN.NonEmpty (LN.NonEmpty a)) remove :: S.Set a -> Maybe (LN.NonEmpty (LN.NonEmpty a))
remove toRemove = catMaybes . LN.map (LN.nonEmpty . LN.filter (`S.notMember` toRemove)) $ votes remove toRemove = catMaybes . LN.map (LN.nonEmpty . LN.filter (`S.notMember` toRemove)) $ votes
-- firstChoiceLosers :: S.Set a firstChoiceLosers :: S.Set a
firstChoiceLosers = M.keysSet . M.filter ((==) . L.minimum . M.elems $ voteCounts) $ voteCounts firstChoiceLosers = M.keysSet . M.filter ((==) . L.minimum . M.elems $ voteCounts) $ voteCounts
-- firstChoices :: LN.NonEmpty a firstChoices :: LN.NonEmpty a
firstChoices = LN.map LN.head votes firstChoices = LN.map LN.head votes
-- voteCounts :: M.Map a Word voteCounts :: M.Map a Word
voteCounts = M.unionsWith (+) . map (`M.singleton` (1 :: Word)) . LN.toList $ firstChoices voteCounts = M.unionWith (+) candidatesMinimumVoteCounts . M.unionsWith (+) . map (`M.singleton` 1) . LN.toList $ firstChoices
-- candidates that are no ones first choice should be eliminated first
-- so we make sure to grab all of them here
candidates :: S.Set a
candidates = S.unions (map (S.fromList . LN.toList) . LN.toList $ votes)
candidatesMinimumVoteCounts :: M.Map a Word
candidatesMinimumVoteCounts = (M.fromSet (const 0) candidates)
catMaybes :: LN.NonEmpty (Maybe a) -> Maybe (LN.NonEmpty a) catMaybes :: LN.NonEmpty (Maybe a) -> Maybe (LN.NonEmpty a)
catMaybes = LN.nonEmpty . L.catMaybes . LN.toList catMaybes = LN.nonEmpty . L.catMaybes . LN.toList

2
src/Main.hs
View file

@ -62,7 +62,7 @@ results pollId = do
Nothing -> fullPage "poll doesn't have any votes" Nothing -> fullPage "poll doesn't have any votes"
Just votesList -> do Just votesList -> do
let voteless = notVotedFor poll let voteless = notVotedFor poll
let results' = (IR.solve $ votesList) ++ noVotesAsBallot voteless let results' = (reverse . IR.solve $ votesList) ++ noVotesAsBallot voteless
fullPage $ do fullPage $ do
h2_ "results" h2_ "results"
toHtml $ T.append (T.pack . show . length . P.votes $ poll) " ballots submitted" toHtml $ T.append (T.pack . show . length . P.votes $ poll) " ballots submitted"