fixed instant runoff bug

Candidates that were no ones first choice should have been eliminated
first. Instead, they were skipped.

src/InstantRunoff.hs

@@ -2,30 +2,34 @@ 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 qualified Data.Foldable as F
-import Data.Ord
-import Data.Maybe hiding (catMaybes)
-import Data.Ratio
 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
     where
 
     -- 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
 
-    -- firstChoiceLosers :: S.Set a
+    firstChoiceLosers :: S.Set a
     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
 
-    -- voteCounts :: M.Map a Word
-    voteCounts = M.unionsWith (+) . map (`M.singleton` (1 :: Word)) . LN.toList $ firstChoices
+    voteCounts :: M.Map a Word
+    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 . L.catMaybes . LN.toList

src/Main.hs

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