different ordering method for non-first-place

src/InstantRunoff.hs

@@ -3,52 +3,69 @@ import qualified Data.List as L
 import qualified Data.List.NonEmpty as LN
 import qualified Data.Map.Strict as M
 import qualified Data.Set as S
-import qualified Data.Maybe as L
+import qualified Data.Maybe as M
 import qualified Data.Ord as O
 
-solve :: forall a. Ord a => Show a => LN.NonEmpty (LN.NonEmpty a) -> [S.Set a]
-solve votes = maybe (L.singleton . M.keysSet $ voteCounts) ((loser : ) . solve) $ remove loser
-    where
+solve :: forall a. Ord a => [a] ->  LN.NonEmpty (LN.NonEmpty a) -> [S.Set a]
+solve candidates votes' = if S.null notVotedForCandidates
+  then solved
+  else solved ++ [notVotedForCandidates]
+  where
 
-    -- if Nothing, then all options in votes are valued equally
-    remove :: S.Set a -> Maybe (LN.NonEmpty (LN.NonEmpty a))
-    remove toRemove = filterVotes (`S.notMember` toRemove)
+    -- candidates not on any submitted ballot
+    notVotedForCandidates :: S.Set a
+    notVotedForCandidates = S.difference (S.fromList candidates) . S.unions $ solved
 
-    filterVotes :: (a -> Bool) -> Maybe (LN.NonEmpty (LN.NonEmpty a))
-    filterVotes removeFn = catMaybes . LN.map (LN.nonEmpty . LN.filter removeFn) $ votes
+    solved = solve' votes'
+
+    solve' :: LN.NonEmpty (LN.NonEmpty a) -> [S.Set a]
+    solve' votes = maybe [] ((:) winner' . solve') remainingVotes
+      where
+        winner' = winner votes
+
+        remainingVotes :: Maybe (LN.NonEmpty (LN.NonEmpty a))
+        remainingVotes = filterVotes (`S.notMember` winner') votes
+
+winner :: forall a. Ord a => LN.NonEmpty (LN.NonEmpty a) -> S.Set a
+winner votes = maybe (M.keysSet $ voteCounts) winner . filterVotes (`S.notMember` losers) $ votes
+  where
 
     firstChoiceLosers :: S.Set a
     firstChoiceLosers = M.keysSet . M.filter ((==) . L.minimum . M.elems $ voteCounts) $ voteCounts
 
-    loser :: S.Set a
-    loser = S.fromList . smallestSubset preferred . S.toList $ firstChoiceLosers
+    losers :: S.Set a
+    losers = S.fromList . smallestSubset preferred . S.toList $ firstChoiceLosers
 
     preferred :: a -> a -> Ordering
-    preferred x0 x1 = compare (L.length . L.filter (== Just x0) $ preferences) (L.length . L.filter (== Just x1) $ preferences)
+    preferred x0 x1 = compare (numMatch x0) (numMatch x1)
       where
+        numMatch x = L.length . L.filter (== Just x) $ preferences
+
         preferences :: [Maybe a]
         preferences = map (ballotFavors . LN.toList) . LN.toList $ votes
 
         ballotFavors :: [a] -> Maybe a
         ballotFavors = L.find (`S.member` [x0, x1])
 
-
-    firstChoices :: LN.NonEmpty a
-    firstChoices = LN.map LN.head votes
-
     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)
+    voteCounts =
+        M.unionsWith (+)
+      . (candidatesMinimumVoteCounts :)
+      . map (`M.singleton` 1)
+      . LN.toList .
+      LN.map LN.head $ votes
 
     candidatesMinimumVoteCounts :: M.Map a Word
-    candidatesMinimumVoteCounts = (M.fromSet (const 0) candidates)
+    candidatesMinimumVoteCounts = (M.fromSet (const 0) (allVotedFor votes))
 
+filterVotes :: (a -> Bool) -> LN.NonEmpty (LN.NonEmpty a) -> Maybe (LN.NonEmpty (LN.NonEmpty a))
+filterVotes f = catMaybes . LN.map (LN.nonEmpty . LN.filter f)
+
+allVotedFor :: Ord a => LN.NonEmpty (LN.NonEmpty a) -> S.Set a
+allVotedFor = S.unions . map (S.fromList . LN.toList) . LN.toList
 
 catMaybes :: LN.NonEmpty (Maybe a) -> Maybe (LN.NonEmpty a)
-catMaybes = LN.nonEmpty . L.catMaybes . LN.toList
+catMaybes = LN.nonEmpty . M.catMaybes . LN.toList
 
+smallestSubset :: (t -> t -> Ordering) -> [t] -> [t]
 smallestSubset f = last . takeWhile (\xs -> (f (head xs) (last xs)) == O.EQ) . tail . L.inits . L.sortBy f

src/Main.hs

@@ -61,8 +61,7 @@ results pollId = do
   case toNonEmptyList . P.votes $ poll of
     Nothing -> fullPage "poll doesn't have any votes"
     Just votesList -> do
-      let voteless = notVotedFor poll
-      let results' = (reverse . IR.solve $ votesList) ++ noVotesAsBallot voteless
+      let results' = (IR.solve (LN.toList . P.options . P.createInfo $ poll) votesList)
       fullPage $ do
         h2_ "results"
         toHtml $ T.append (T.pack . show . length . P.votes $ poll) " ballots submitted"
@@ -70,9 +69,6 @@ results pollId = do
         h3_ . toHtml . P.question . P.createInfo $ poll
         with div_ [id_ "results"] . mconcat $ zipWith nthPlaceFor results' nthPlaces
   where
-    noVotesAsBallot :: S.Set T.Text -> [S.Set T.Text]
-    noVotesAsBallot notVotedFor' = if S.null notVotedFor' then [] else [notVotedFor']
-
     toNonEmptyList :: [B.Ballot] -> Maybe (LN.NonEmpty (LN.NonEmpty T.Text))
     toNonEmptyList = LN.nonEmpty . My.mapMaybe (LN.nonEmpty . filter (not . T.null) . B.options)