condorcet-0.0.1: Condorcet.hs

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