diff --git a/Condorcet.hs b/Condorcet.hs new file mode 100644 --- /dev/null +++ b/Condorcet.hs @@ -0,0 +1,106 @@ +-- Condorcet voting. +-- Copyright (C) 2005 Evan Martin +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 : diff --git a/Demo.hs b/Demo.hs new file mode 100644 --- /dev/null +++ b/Demo.hs @@ -0,0 +1,44 @@ +-- Condorcet voting. +-- Copyright (C) 2005 Evan Martin + +module Main where + +import qualified Condorcet + +import Text.ParserCombinators.Parsec +import Control.Monad.Error + +{- | Parses a simple form of ballots as strings. + Ballot strings are comma-separated list in order of preference; + equally-ranked candidates are separated with an equals sign. + E.g., "3=4=5,1,2" -} +parseBallot :: String -> Either ParseError Condorcet.Ballot +parseBallot input = parse ballot "" input where + ballot :: Parser [[Int]] + ballot = do { b <- sepBy1 rank (char ','); eof; return b } + rank :: Parser [Int] + rank = sepBy1 number (char '=') + number :: Parser Int + number = do { ds <- many1 digit; return (read ds) } + +-- parse a set of ballots, halting on failure (using the Error monad). +parseBallots :: [String] -> Either String [Condorcet.Ballot] +parseBallots bs = mapM pb bs >>= return where + pb ballot = case parseBallot ballot of + Left err -> throwError (show err) + Right x -> return x + +main :: IO () +main = do + case parseBallots ["1,2,3", "2=1,3", "2,1,3"] of + Left e -> putStrLn e + Right ballots -> do + putStrLn $ "Parsed " ++ (show (length ballots)) ++ " ballots:" + mapM_ print ballots + putStrLn "Computing winners..." + let winners = Condorcet.run ballots + putStrLn "Winners:" + putStrLn $ show winners + +-- vim: set ts=2 sw=2 et : + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2006 Evan Martin + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +#!/usr/bin/runhaskell + +import Distribution.Simple + +main = defaultMainWithHooks simpleUserHooks diff --git a/condorcet.cabal b/condorcet.cabal new file mode 100644 --- /dev/null +++ b/condorcet.cabal @@ -0,0 +1,22 @@ +name: condorcet +version: 0.0.1 +stability: Experimental +category: Data +synopsis: Library for Condorcet voting +description: This is a small library for determining the winner of a Condorcet election; + for what a Condorcet election is, see +license: BSD3 +license-file: LICENSE +author: Evan Martin +maintainer: Evan Martin +homepage: http://neugierig.org/software/darcs/condorcet + +build-depends: base, array +build-type: Simple +tested-with: GHC==6.8.2 + +exposed-modules: Condorcet +extra-source-files: Demo.hs + +ghc-options: -O2 -Wall -optl-Wl,-s +ghc-prof-options: -prof -auto-all