[initial import
Evan Martin <martine@danga.com>**20050430001852] {
addfile ./Condorcet.hs
hunk ./Condorcet.hs 1
+-- 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]]
+
+type STVoteArray s = STUArray s (Int,Int) Int
+type VoteArray = UArray (Int,Int) Int
+
+loadVotes :: STVoteArray s -> [[Candidate]] -> ST s ()
+loadVotes vs []        = 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 cs rest =
+      mapM_ loadVote [(a,b) | a <- cs, b <- concat rest]
+
+    -- 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 = [min..max] where ((min, _), (max, _)) = 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<-range, j<-range, i/=j, k<-range, i/=k, j/=k] where
+    range = 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  = all (c `beats`) 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
+
+-- |'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 :
addfile ./Demo.hs
hunk ./Demo.hs 1
+-- Condorcet voting.
+-- Copyright (C) 2005 Evan Martin <martine@danga.com>
+
+module Main where
+
+import qualified Condorcet
+
+import Parsec
+
+test :: IO ()
+test = do
+  let votes = [[ [1],[2],[3] ],
+               [ [2],[1],[3] ],
+               [ [2],[1],[3] ]]
+  let winners = Condorcet.run votes
+  putStrLn "winners:"
+  putStrLn $ show winners
+
+-- vim: set ts=2 sw=2 et :
+
addfile ./LICENSE
hunk ./LICENSE 1
+Copyright (c) 2005, Evan Martin <martine@danga.com>
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+* Redistributions of source code must retain the above copyright notice,
+  this list of conditions and the following disclaimer.
+    
+* Redistributions in binary form must reproduce the above copyright
+  notice, this list of conditions and the following disclaimer in the
+  documentation and/or other materials provided with the distribution.
+     
+* Neither the name of the <ORGANIZATION> nor the names of its
+  contributors may be used to endorse or promote products derived from
+  this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
}