module Condorcet(Candidate, Ballot, run) where
import GHC.ST
import Data.Array.ST
import Data.Array.Unboxed
type Candidate = Int
type Ballot = [[Candidate]]
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
loadVotes vs rest
where
loadVoteSet ds rst =
mapM_ loadVote [(a,b) | a <- ds, b <- concat rst]
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
initPaths vs paths
floyd vs paths
unsafeFreeze 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
run :: [Ballot]
-> [Candidate]
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