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

different ordering method for non-first-place

Browse source
This commit is contained in:
Jack Wines 2023-06-21 02:58:06 -07:00
parent 620b45bfea
commit 353f24315f
2 changed files with 42 additions and 29 deletions
Download patch file Download diff file Expand all files Collapse all files

63
src/InstantRunoff.hs
View file

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

6
src/Main.hs
View file

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