From 620b45bfea1bfb1654b4a25377b47a87fdcc0acd Mon Sep 17 00:00:00 2001
From: Jack Wines <jack@winesj.com>
Date: Wed, 21 Jun 2023 01:40:55 -0700
Subject: [PATCH] instant runoff loser changes

---
 src/InstantRunoff.hs | 23 +++++++++++++++++++++--
 1 file changed, 21 insertions(+), 2 deletions(-)

diff --git a/src/InstantRunoff.hs b/src/InstantRunoff.hs
index a7ad0fc..f5498a8 100644
--- a/src/InstantRunoff.hs
+++ b/src/InstantRunoff.hs
@@ -4,18 +4,35 @@ 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.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) ((firstChoiceLosers : ) . solve) . remove $ firstChoiceLosers
+solve votes = maybe (L.singleton . M.keysSet $ voteCounts) ((loser : ) . solve) $ remove loser
     where
 
     -- if Nothing, then all options in votes are valued equally
     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 = filterVotes (`S.notMember` toRemove)
+
+    filterVotes :: (a -> Bool) -> Maybe (LN.NonEmpty (LN.NonEmpty a))
+    filterVotes removeFn = catMaybes . LN.map (LN.nonEmpty . LN.filter removeFn) $ votes
 
     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
+
+    preferred :: a -> a -> Ordering
+    preferred x0 x1 = compare (L.length . L.filter (== Just x0) $ preferences) (L.length . L.filter (== Just x1) $ preferences)
+      where
+        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
 
@@ -33,3 +50,5 @@ solve votes = maybe (L.singleton . M.keysSet $ voteCounts) ((firstChoiceLosers :
 
 catMaybes :: LN.NonEmpty (Maybe a) -> Maybe (LN.NonEmpty a)
 catMaybes = LN.nonEmpty . L.catMaybes . LN.toList
+
+smallestSubset f = last . takeWhile (\xs -> (f (head xs) (last xs)) == O.EQ) . tail . L.inits . L.sortBy f