diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Henri Verroken (c) 2017 + +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 Henri Verroken nor the names of other + 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,12 @@ +# bordacount + +[![Travis](https://travis-ci.org/hverr/bordacount.svg?branch=master)](https://travis-ci.org/hverr/bordacount) +[![Coverage](https://coveralls.io/repos/github/hverr/bordacount/badge.svg?branch=master)](https://coveralls.io/github/hverr/bordacount?branch=master) +[![Hackage](https://img.shields.io/hackage/v/bordacount.svg?maxAge=2592000)](https://hackage.haskell.org/package/bordacount) +[![Stackage Nightly](http://stackage.org/package/bordacount/badge/nightly)](http://stackage.org/nightly/package/bordacount) +[![Stackage LTS](http://stackage.org/package/bordacount/badge/lts)](http://stackage.org/lts/package/bordacount) + +Haskell implementation of the Borda count election method, optionally with +different weights for different participants. + +See https://en.wikipedia.org/wiki/Borda_count diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bordacount.cabal b/bordacount.cabal new file mode 100644 --- /dev/null +++ b/bordacount.cabal @@ -0,0 +1,40 @@ +name: bordacount +version: 0.1.0.0 +synopsis: Implementation of the Borda count election method. +description: + Implementation of the Borda count election method, optionally with + different weights for different participants. + . + See +homepage: https://github.com/hverr/bordacount#readme +license: BSD3 +license-file: LICENSE +author: Henri Verroken +maintainer: henriverroken@gmail.com +copyright: 2017 Henri Verroken +category: Algorithms +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Data.Voting.BordaCount + build-depends: base >= 4.7 && < 5 + , containers + default-language: Haskell2010 + +test-suite bordacount-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , bordacount + , hspec + , QuickCheck + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/hverr/bordacount diff --git a/src/Data/Voting/BordaCount.hs b/src/Data/Voting/BordaCount.hs new file mode 100644 --- /dev/null +++ b/src/Data/Voting/BordaCount.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | Implementation of the modified Borda count election method. +-- +-- The implementation implements the modified Borda count election +-- method, optionally with different weights for different participants. +-- +-- See . +-- +-- The election runs in two phases. First individual 'Vote's on options +-- from a certain participant are gathered and ranked into the +-- participant's 'Ballot' using the function 'ballot'. +-- +-- Then all ballots are gathered and an 'election' is held, resulting in +-- a list of election 'Result's, one for each option. +-- +-- Except for the 'Vote' data constructor, you should not use other data +-- constructors, as they do not reflect invariants correctly. However, the +-- 'ballot' and 'election' will enforce variants. +module Data.Voting.BordaCount ( + -- * Voting + Vote(..) + , Ballot(..) + , BallotError(..) + , ballot + + -- * Election + , Result(..) + , Score(..) + , Zeros(..) + , ElectionError(..) + , election + , election' + + -- * Internal + , findFirstDuplicateBy +) where + +import Data.Function (on) +import Data.List (find, foldl', nubBy) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M + +-- | A vote is an attribution of a number of points to an option +data Vote o = Vote { + voteRanking :: Int + , voteOption :: o + } deriving (Eq, Show) + + +-- | A ballot with options of type @o@ filled in by a participant of type @p@. +data Ballot p o = Ballot { + ballotParticipant :: p + , ballotVotes :: [Vote o] + } deriving (Eq, Show) + +-- | Construct a new ballot for a participant from a collection of votes. +-- +-- This function constructs a valid ballot or returns an error if the +-- collection of votes is invalid. +ballot :: Eq o => p -> [Vote o] -> Either (BallotError o) (Ballot p o) +ballot p votes = do + () <- checkDoubleVotes + () <- checkNonZeros + return $ Ballot p votes + where + zeros = filter ((== 0) . voteRanking) votes + nonZeros = filter ((/= 0) . voteRanking) votes + + checkNonZeros = + case findFirstDuplicateBy ((==) `on` voteRanking) nonZeros of + Just (v, v') -> Left $ DuplicateRanking (voteOption v) (voteOption v') + Nothing -> Right () + + checkDoubleVotes = + case findFirstDuplicateBy ((==) `on` voteOption) votes of + Just (v, _) -> Left $ DuplicateOption (voteOption v) + Nothing -> Right () + +-- | Result of a certain option of type @o@ of an election. +data Result o = Result o Score Zeros deriving (Eq, Show) + +-- | The weighted score of a 'Result'. +newtype Score = Score Double deriving (Eq, Num, Ord, Real, Show) + +-- | The number of weighted zeros a 'Result' got. +newtype Zeros = Zeros Double deriving (Eq, Num, Ord, Real, Show) + +-- | Hold an election, collect all the ballots and produce the 'Result'. +-- +-- This functions assumes that the 'Ballot's are well formed, as +-- returned by the function 'ballot'. +-- +-- Thee function holds the election, and might return an 'ElectionError' +-- on any irregularity. +election :: (Eq p, Ord o) + => (p -> Double) -- ^ Weighing function for participants. + -> [Ballot p o] -- ^ All ballots. + -> Either (ElectionError p) [Result o] -- ^ Election result +election weigh ballots = do + () <- checkUniqueParticipants + return . M.elems $ foldl' process M.empty ballots + where + checkUniqueParticipants = + case findFirstDuplicateBy ((==) `on` ballotParticipant) ballots of + Just (b, _) -> Left $ DuplicateParticipant (ballotParticipant b) + Nothing -> Right () + + process m b = + let w = weigh (ballotParticipant b) in + foldl' (register w) m (ballotVotes b) + + register w m v + | 0 <- voteRanking v + = M.insertWith plus (voteOption v) (Result (voteOption v) 0 (Zeros w)) m + + | n <- voteRanking v + , s <- fromIntegral n * w + = M.insertWith plus (voteOption v) (Result (voteOption v) (Score s) 0) m + + plus (Result o s z) (Result _ s' z') = Result o (s + s') (z + z') + +-- | Hold an 'election', but with a weight of @1@ for all participants. +-- +-- See 'election' for more information. +election' :: (Eq p, Ord o) + => [Ballot p o] -- ^ All ballots + -> Either (ElectionError p) [Result o] -- ^ Election result +election' = election (const 1.0) + +-- | Find the first duplicates, filtered by a function. +findFirstDuplicateBy :: (a -> a -> Bool) -> [a] -> Maybe (a, a) +findFirstDuplicateBy _ [] = Nothing +findFirstDuplicateBy f (x:xs) = case find (f x) xs of + Just x' -> Just (x, x') + Nothing -> findFirstDuplicateBy f xs + +-- | Errors that can occur when creating a 'Ballot' using 'ballot'. +data BallotError o = DuplicateRanking o o -- ^ The given options have the same ranking + | DuplicateOption o -- ^ The given option was voted on twice. + deriving (Eq, Show) + +-- | Error that can occur when holding an 'election'. +newtype ElectionError p = DuplicateParticipant p -- ^ The given participant voted twice. + deriving (Eq, Show) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE ScopedTypeVariables #-} +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck + +import Data.List (nub) + +import Data.Voting.BordaCount + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "duplicate checks" $ + prop "properly detects duplicates" $ \(xs :: [Int]) -> + let dup = length xs /= length (nub xs) in + case findFirstDuplicateBy (==) xs of + Just (x, _) -> length (filter (== x) xs) > 1 + Nothing -> not dup + + describe "ballot" $ do + it "rejects duplicate options" $ do + ballot "" [Vote 0 "a", Vote 2 "b", Vote 1 "a"] `shouldBe` Left (DuplicateOption "a") + ballot "" [Vote 0 "a", Vote 2 "a", Vote 1 "a"] `shouldBe` Left (DuplicateOption "a") + ballot "" [Vote 0 "b", Vote 2 "a", Vote 1 "a"] `shouldBe` Left (DuplicateOption "a") + + it "rejects duplicate rankings" $ do + ballot "" [Vote 0 "a", Vote 2 "b", Vote 2 "c"] `shouldBe` Left (DuplicateRanking "b" "c") + ballot "" [Vote 0 "a", Vote 3 "b", Vote 3 "c"] `shouldBe` Left (DuplicateRanking "b" "c") + + it "accepts valid ballots" $ do + ballot "" [Vote 0 "a", Vote 0 "b", Vote 1 "c", Vote 4 "d"] `shouldSatisfy` anyRight + ballot "" ([] :: [Vote String]) `shouldSatisfy` anyRight + ballot "" [Vote 1 "c", Vote 2 "d", Vote 0 "x"] `shouldSatisfy` anyRight + + describe "election" $ do + it "rejects duplicate participants" $ + election' [Ballot "henri" [Vote 0 "x"], + Ballot "viktor" [Vote 1 "x"], + Ballot "henri" [Vote 0 "x"]] `shouldBe` Left (DuplicateParticipant "henri") + + let ballots = [Ballot "henri" [Vote 0 "x", Vote 1 "y", Vote 2 "z"], + Ballot "viktor" [Vote 1 "x", Vote 2 "y", Vote 3 "z"], + Ballot "arno" [Vote 0 "x", Vote 0 "y", Vote 1 "z"]] + + it "accepts valid ballot (uniform weight)" $ + election' ballots `shouldBe` Right [ + Result "x" 1 2 + , Result "y" 3 1 + , Result "z" 6 0] + + it "accepts valid ballot (weighted)" $ + let w "henri" = 5.0 + w "viktor" = 2.0 + w "arno" = 1.0 + w p = error $ "unknown participant: " ++ p + in + election w ballots `shouldBe` Right [ + Result "x" 2 6 + , Result "y" 9 1 + , Result "z" 17 0] + where + anyRight (Left _) = False + anyRight (Right _) = True