-- Condorcet voting. -- Copyright (C) 2005 Evan Martin <martine@danga.com> module Condorcet(Candidate, Ballot, run) where import GHC.ST import Data.Array.ST import Data.Array.Unboxed -- | Candidates are represented as integers. type Candidate = Int {-| Ballots are a ranking of candidates. Ballots are lists, where each element is a list of candidates the rank the same. Earlier entries in the ballot list are ranked higher. E.g., this ballot: > [ [1,3], [4], [2] ] Means that 1 and 3 are tied for first, outranking 4, and everyone beats 2. -} type Ballot = [[Candidate]] -- Entry (i,j) having value k means that i beats j in k votes. type VoteArray = UArray (Int,Int) Int type STVoteArray s = STUArray s (Int,Int) Int loadVotes :: STVoteArray s -> [[Candidate]] -> ST s () loadVotes _ [] = return () loadVotes vs (cs:rest) = do loadVoteSet cs rest -- each candidate at this ranks beat the ones below loadVotes vs rest -- and recurse on lower ranks where -- loadVoteSet cs rest: store that each candidate in cs beat each in rest. loadVoteSet ds rst = mapM_ loadVote [(a,b) | a <- ds, b <- concat rst] -- loadVote (a,b): store that a beat b in the vote matrix. loadVote pair = do v <- readArray vs pair writeArray vs pair (v+1) dim :: VoteArray -> [Int] dim vs = [minim..maxim] where ((minim, _), (maxim, _)) = bounds vs initPaths :: VoteArray -> STVoteArray s -> ST s () initPaths vs paths = mapM_ writeDelta (indices vs) where writeDelta (i,j) = writeArray paths (i,j) (max 0 (vs!(i,j) - vs!(j,i))) floyd :: VoteArray -> STVoteArray s -> ST s () floyd vs paths = mapM_ update [(i,j,k) | i<-ranges, j<-ranges, i/=j, k<-ranges, i/=k, j/=k] where ranges = dim vs update (i,j,k) = do a <- readArray paths (j,i) b <- readArray paths (i,k) let s = min a b cur <- readArray paths (j,k) if cur < s then writeArray paths (j,k) s else return () strongPath :: VoteArray -> ST s VoteArray strongPath vs = do paths <- thaw vs -- make a copy of vs initPaths vs paths -- load delta votes into paths floyd vs paths -- run floyd over paths unsafeFreeze paths -- and return paths winners :: VoteArray -> [Candidate] winners paths = filter isWinner candidates where isWinner c = (c `beats`) `all` candidates i `beats` j = paths!(i,j) >= paths!(j,i) candidates = dim paths -- join :: String -> [String] -> String -- join sep [] = "" -- join sep [a] = a -- join sep (a:b:as) = a ++ sep ++ (join sep (b:as)) -- showVA :: VoteArray -> String -- showVA vs = join "\n" (map showRow positions) where -- showRow y = join ", " (map (\x -> show $ vs ! (x,y)) positions) -- positions = dim vs -- loadBallots :: [Ballot] -> ST s (STVoteArray s) -- loadBallots ballots = do -- let size = maximum $ concat $ concat ballots -- votes <- newArray ((1,1),(size,size)) 0 -- mapM_ (loadVotes votes) ballots -- return votes -- | 'run' runs the process, taking a list of 'Ballot's and returning a -- list of winning candidates. run :: [Ballot] -- ^ A list of ballots -> [Candidate] -- ^ The winning candidates run ballots = runST realrun where realrun = do let size = maximum $ concat $ concat ballots votes <- newArray ((1,1),(size,size)) 0 mapM_ (loadVotes votes) ballots fvotes <- unsafeFreeze votes paths <- strongPath fvotes return $ winners paths -- vim: set ts=2 sw=2 et :