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

instant runoff loser changes

Browse source
This commit is contained in:
Jack Wines 2023-06-21 01:40:55 -07:00
parent f04a059f32
commit 620b45bfea
1 changed files with 21 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

23
src/InstantRunoff.hs
View file

@ -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