bordacount (empty) → 0.1.0.0
raw patch · 6 files changed
+293/−0 lines, 6 filesdep +QuickCheckdep +basedep +bordacountsetup-changed
Dependencies added: QuickCheck, base, bordacount, containers, hspec
Files
- LICENSE +30/−0
- README.md +12/−0
- Setup.hs +2/−0
- bordacount.cabal +40/−0
- src/Data/Voting/BordaCount.hs +144/−0
- test/Spec.hs +65/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,12 @@+# bordacount++[](https://travis-ci.org/hverr/bordacount)+[](https://coveralls.io/github/hverr/bordacount?branch=master)+[](https://hackage.haskell.org/package/bordacount)+[](http://stackage.org/nightly/package/bordacount)+[](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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bordacount.cabal view
@@ -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 <https://en.wikipedia.org/wiki/Borda_count>+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
+ src/Data/Voting/BordaCount.hs view
@@ -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 <https://en.wikipedia.org/wiki/Borda_count>.+--+-- 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)
+ test/Spec.hs view
@@ -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