hjugement 2.0.1.20190208 → 2.0.2.20190414

raw patch · 16 files changed

+293/−114 lines, 16 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Majority/Merit.hs +6/−2
• Majority/Rank.hs +156/−58
• Majority/Section.hs +2/−2
• Majority/Value.hs +1/−1
• hjugement.cabal +2/−1
• stack.yaml +1/−1
• test/HUnit/Merit.hs +15/−13
• test/HUnit/Rank.hs +42/−17
• test/HUnit/Section.hs +1/−1
• test/QuickCheck.hs +2/−0
• test/QuickCheck/Gauge.hs +1/−1
• test/QuickCheck/Merit.hs +1/−1
• test/QuickCheck/Rank.hs +38/−0
• test/QuickCheck/Utils.hs +1/−1
• test/QuickCheck/Value.hs +17/−14
• test/Types.hs +7/−1

@@ -50,7 +50,7 @@  -- * Type 'Ranked' -- | Helper type to rank data without a good 'Ord' instance.-newtype Ranked a = Ranked (Integer, a)+newtype Ranked a = Ranked (G, a)  deriving (Show,Functor) instance Eq (Ranked a) where 	Ranked (x,_) == Ranked (y,_) = x==y@@ -65,7 +65,11 @@ rankKey :: [(k, a)] -> [(Ranked k, a)] rankKey = List.zipWith (\i (k,a) -> (Ranked (i,k),a)) [0..] -rank :: Ranked a -> Integer+-- ** Type 'G'+-- | Rank of a grade.+type G = Integer++rank :: Ranked a -> G rank (Ranked (r, _x)) = r  unRank :: Ranked a -> a

@@ -1,5 +1,5 @@-{-# OPTIONS -fno-warn-tabs #-} module Majority.Rank where+ import Data.Bool import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..))@@ -9,93 +9,190 @@ import Data.Ratio import Data.Semigroup (Semigroup(..)) import Prelude (Integer, Integral(..), Num(..), RealFrac(..), undefined)+import Text.Show (Show(..))+import qualified Data.List as List  import Majority.Merit hiding (merit) import Majority.Value +-- * Convenient type aliases -- | Number of judges. type JS = Integer -- | Number of grades. type GS = Integer--- | Rank of grade.-type G = Integer+-- | Rank of a 'MajorityValue'.+type Rank = Integer --- | 'rankOfMajorityValue gs mv' returns--- the number of 'MajorityValue' lower than given 'mv'.-rankOfMajorityValue :: GS -> MajorityValue (Ranked grade) -> Integer+-- ** Type 'Median'+-- | A median.+-- First 'G' (lower median) is lower or equal+-- to the second 'G' (higher median).+newtype Median = Median (G,G)+ deriving (Eq, Show)++-- | 'Median' constructor enforcing its invariant.+median :: G -> G -> Median+median l h | l <= h = Median (l,h)+           | otherwise = undefined++-- * Ranking and unranking 'MajorityValue's++-- | @('rankOfMajorityValue' gs mv)@ returns+-- the number of possible 'MajorityValue's lower than given 'mv'.+--+-- @+-- 'rankOfMajorityValue' gs . 'majorityValueOfRank' js gs+--  '<$>' [0..'lastRank' js gs] == [0..'lastRank' js gs]+-- @+rankOfMajorityValue :: GS -> MajorityValue (Ranked grade) -> Rank rankOfMajorityValue gs mv =-	go ((2 *) $ sum $ middleShare <$> mvN) (0,0) mvN+	go ((2 *) $ sum $ middleShare <$> mvN) 0 mvN 	where 	MajorityValue mvN = normalizeMajorityValue mv-	go :: Rational -> (G,G) -> [Middle (Ranked grade)] -> Integer-	go _n _0 [] = 0-	go n (l0,h0) (Middle s low high : ms)-	 | s <= 0 = go n (l0,h0) ms+	go :: Rational -> G -> [Middle (Ranked grade)] -> Rank+	go _n _previousHigh [] = 0+	go n previousHigh (Middle s low high : ms)+	 -- Skip empty Middle.+	 | s <= 0 = go n previousHigh ms+	 -- Add the number of possible 'MajorityValue's+	 -- before the two middle judgments of the current 'Middle',+	 -- and recurse. 	 | otherwise =-		countMiddleFrom (numerator $ n) gs (l0,h0) (rank low, rank high) +-		go (n - dn) (0, rank high) (Middle (s - dn * (1%2)) low high : ms)+		countMediansBefore (numerator n) gs previousHigh (Median (rank low, rank high)) ++		go (n - dn) (rank high) (Middle (s - dn * (1%2)) low high : ms) 		where dn = if denominator s == 1 then 2 else 1 +-- | The inverse of 'rankOfMajorityValue'.+--+-- @+-- 'majorityValueOfRank' js gs . 'rankOfMajorityValue' gs == 'id'+-- @+majorityValueOfRank :: JS -> GS -> Rank -> MajorityValue (Ranked ())+majorityValueOfRank js0 gs rk+ | not (0<=rk && rk<=lastRank js0 gs) = undefined+	-- error $ "rank="<>show rk<>" but lastRank "<>show js0<>" "<>show gs<>"="<>show (lastRank js0 gs)+ | otherwise = MajorityValue $ go 0 js0 rk+	where+	go previousHigh js r+	 | js <= 0 = []+	 | otherwise =+		let ms   = listMediansBefore js gs previousHigh (Median (gs,gs)) in+		let skip = List.takeWhile (<= r) $ List.scanl1 (+) $ countMedian js gs <$> ms in+		let dr   = if null skip then 0 else List.last skip in+		let dj   = if js`mod`2 == 0 then 2 else 1 in+		let Median (l,h) = List.head $ List.drop (length skip) ms in+		-- trace ("majorityValueOfRank: js="<>show js<>" r="<>show r<>" dr="<>show dr<>" "<>show (l,h)) $+		case go h (js - dj) (r - dr) of+		 -- Merge the 'Middle's which have the same 'Median' grades,+		 -- by adding their 'Share'.+		 Middle s rl1@(Ranked (l1, ())) rh1@(Ranked (h1, ())) : mv+		  | l1 == l && h1 == h -> Middle (dj%2 + s) rl1 rh1 : mv+		 mv -> Middle (dj%2) (Ranked (l,())) (Ranked (h,())) : mv+ positionOfMajorityValue :: GS -> MajorityValue (Ranked grade) -> Rational positionOfMajorityValue gs mv = 	rankOfMajorityValue gs mv %-	countMerits (2 * numerator js) gs-	where js = sum $ middleShare <$> unMajorityValue mv+	countMerits (numerator js) gs+	where js = (2 *) $ sum $ middleShare <$> unMajorityValue mv -countMiddleFrom :: JS -> GS -> (G,G) -> (G,G) -> Integer-countMiddleFrom js gs (l0,h0) (l1,h1) =-	sum $ countMiddle js gs <$>-		if js`mod`2 == 0 then even else odd-	where-	even = even1 <> even2 <> even3-	odd = [ (l,l) | l<-[l0..l1-1] ]-	even1 =-	 [ (l,h) | l<-[l0]-	 , h<-[h0..(if l0<l1 then gs-1 else h1-1)]-	 ]-	even2 =-	 [ (l,h) | l<-[l0+1..l1-1]-	 , h<-[max l h0..gs-1]-	 ]-	even3 =-	 [ (l,h) | l<-[l1 | l0 < l1]-	 , h<-[max l h0..h1-1]-	 ] --- | 'countMiddle js gs (l,h)'--- returns the number of 'MajorityValue's of length 'js' and using grades 'gs',--- which have '(l,h)' as lower and upper majority grade.--- This is done by multiplying together--- the 'countMerits' to the left of 'l'--- and the 'countMerits' to the right of 'h'-countMiddle :: JS -> GS -> (G,G) -> Integer-countMiddle js gs (l,h) =-	-- debug ("countMiddle: js="<>show js<>" gs="<>show gs<>" (l,h)="<>show (l,h)) $-	countMerits side (l+1) * -- NOTE: +1 because 'l' starts at 0-	countMerits side (gs-h)-	where side = floor ((js-1)%2)---- | (probaMajorityGrades js gs' compute the probability--- of each grade to be a 'MajorityGrade' given 'js' judges and 'gs' grades.-probaMajorityGrades :: JS -> GS -> [Rational]-probaMajorityGrades js gs =-	[ countMiddle js gs (l,l) % d-	| l <- [0..gs-1]-	] where d = countMerits js gs+-- ** Counting 'Merit's --- | 'countMerits js gs'--- returns the number of 'Merit's of size 'js' possible using grades 'gs'.+-- | @('countMerits' js gs)@+-- returns the number of possible 'Merit's of size 'js' using grades 'gs'. -- That is the number of ways to divide a segment of length 'js' -- into at most 'gs' segments whose size is between '0' and 'js'.+--+-- The formula is: @(js+gs-1)·(js+gs-2)·…·(js+1)·js / (gs-1)·(gs-2)·…·2·1@+-- which is: @(js+gs-1)`nCk`(gs-1)@ countMerits :: JS -> GS -> Integer countMerits js gs = 	-- debug ("countMerits: js="<>show js<>" gs="<>show gs) $ 	(js+gs-1)`nCk`(gs-1) -lastRank :: JS -> GS -> Integer+-- | @('lastRank' js gs)@ returns the rank of the 'MajorityValue'+-- composed of 'js' times the highest grade of 'gs'.+--+-- @'lastRank' js gs == 'countMerits' js gs - 1@.+lastRank :: JS -> GS -> Rank lastRank js gs = countMerits js gs - 1 --- | @'nCk' n k@ returns the number of combinations of size 'k' from a set of size 'n'.+-- ** Counting 'Median's++-- | @('countMedian' js gs ('Median' (l,h)))@+-- returns the number of possible 'Merit's of length 'js' using grades 'gs',+-- which have @(l,h)@ as lower and upper median grades.+-- This is done by multiplying together+-- the 'countMerits' to the left of 'l'+-- and the 'countMerits' to the right of 'h'.+countMedian :: JS -> GS -> Median -> Integer+countMedian js gs (Median (l,h)) =+	-- debug ("countMedian: js="<>show js<>" gs="<>show gs<>" (l,h)="<>show (l,h)) $+	countMerits side (l+1) * -- NOTE: +1 because 'l' starts at 0+	countMerits side (gs-h)+	where side = floor ((js-1)%2)++-- | @('countMediansBefore' js gs previousHigh ('Median' (low,high)))@+-- returns the number of possible 'Merit's with 'js' judges and 'gs' grades,+-- whose @'Median' (l,h)@ is such that @((l,h) < (low, high))@+-- and @(previousHigh <= h)@.+countMediansBefore :: JS -> GS -> G -> Median -> Integer+countMediansBefore js gs previousHigh lh =+	sum $ countMedian js gs <$> listMediansBefore js gs previousHigh lh++-- | @('listMediansBefore' js gs previousHigh ('Median' (low,high)))@+-- returns the 'Median's of possible 'Merit's with 'js' judges and 'gs' grades+-- with a 'Median' strictly lower than @(low,high)@.+listMediansBefore :: JS -> GS -> G -> Median -> [Median]+listMediansBefore js gs previousHigh (Median (l1,h1))+ | js`mod`2 == 0 = evenBegin<>even<>evenEnd+ | otherwise = odd+	where+	l0 = 0+	-- | Walk from the low initial 'l0' upto the low target 'l1'.+	odd = [ Median (l,l) | l<-[l0..l1-1] ]+	-- | Walk from the low initial 'l0', upto:+	-- - the highest (gs-1) if 'l0' is not the low target 'l1',+	-- - or the high target (h1-1) otherwise.+	evenBegin =+	 [ Median (l,h)+	 | l<-[l0]+	 , h<-[{-l`max`-}previousHigh..(if l0<l1 then gs-1 else h1-1)]+	  -- NOTE: useless (max l) since 'l' equals l0',+	  -- which is always lower than or equal to 'previousHigh'.+	 ]+	-- | Walk from the grade after the low initial (l0+1) upto+	-- the grade before the low target (l1-1)+	-- while the high 'h' is walking+	-- from the max of the minimal high and the current low,+	-- to the highest (gs-1).+	-- Beware that when recursing by removing a Middle,+	-- the minimal high is not the low initial,+	-- but the high of the lastly removed Middle.+	even =+	 [ Median (l,h)+	 | l<-[l0+1..l1-1]+	 , h<-[l`max`previousHigh..gs-1]+	 ]+	-- | Walk from the low target (if it hasn't been done yet)+	-- to the high target instead of the highest grade.+	evenEnd =+	 [ Median (l,h)+	 | l<-[l1 | l0 < l1]+	 , h<-[l`max`previousHigh..h1-1]+	 ]++-- | @('probaMedian' js gs)@ compute the probability+-- of each grade to be a 'MajorityGrade' given 'js' judges and 'gs' grades.+probaMedian :: JS -> GS -> [Rational]+probaMedian js gs =+	[ countMedian js gs (Median (l,l)) % d+	| l <- [0..gs-1]+	] where d = countMerits js gs++-- ** Utils+-- | @('nCk' n k)@ returns the binomial coefficient of 'n' and 'k',+-- that is number of combinations of size 'k' from a set of size 'n'. -- -- Computed using the formula: -- @'nCk' n (k+1) == 'nCk' n (k-1) * (n-k+1) / k@@@ -108,3 +205,4 @@         -- which is more efficient and safer         k' = if n`div`2 < k then n-k else k infix 7 `nCk`+

@@ -86,7 +86,7 @@ 	      Either (ErrorSection choice judge grade) 	             (Tree (OpinionsByChoice choice judge grade)) 	go defaultDistJC (Tree.Node (SectionNode _sectionNodeShare currOpinJC) childOpinJCS) =-		-- From current |Tree.Node|'s value.+		-- From current 'Tree.Node''s value. 			let currDistJC :: HM.HashMap choice (HM.HashMap judge (Distribution grade)) = 				-- Collect the 'Distribution' of current 'Tree.Node', 				-- and insert default 'Distribution'@@ -149,7 +149,7 @@ 			Left $ ErrorSection_unknown_judges $ 				HS.fromMap . (() <$) <$> unknownJudgesC 		-- Handle no child 'Tree.Node':-		-- current 'Distribution' is computed from current |Tree.Node|'s value ('currOpinJC')+		-- current 'Distribution' is computed from current 'Tree.Node''s value ('currOpinJC') 		-- and inherited default 'Distribution' ('defaultDistJC'). 		 [] -> Right $ Tree.Node currDistJC [] 		-- Test for invalid shares.

@@ -156,7 +156,7 @@ 		 (quo,_) -> l:concat (replicate (fromIntegral quo) [l, h]) 		-} --- | 'normalizeMajorityValue m' multiply all 'Share's+-- | @'normalizeMajorityValue' m@ multiply all 'Share's -- by their least common denominator to get integral 'Share's. normalizeMajorityValue :: MajorityValue grade -> MajorityValue grade normalizeMajorityValue (MajorityValue mv) =

@@ -2,7 +2,7 @@ -- PVP:  +-+------- breaking API changes --       | | +----- non-breaking API additions --       | | | +--- code changes with no API change-version: 2.0.1.20190208+version: 2.0.2.20190414 category: Politic synopsis: Majority Judgment. description:@@ -86,6 +86,7 @@     QuickCheck     QuickCheck.Gauge     QuickCheck.Merit+    QuickCheck.Rank     QuickCheck.Utils     QuickCheck.Value     Types

@@ -1,3 +1,3 @@-resolver: lts-12.25+resolver: lts-12.26 packages: - '.'

@@ -1,17 +1,20 @@ {-# LANGUAGE OverloadedLists #-} module HUnit.Merit where+ import Control.Arrow (second)-import Data.Int (Int) import Data.Eq (Eq(..)) import Data.Function (($), (.)) import Data.Functor ((<$>)) import Data.Hashable (Hashable)+import Data.Int (Int) import Data.List (zip) import Data.Ord (Ord(..)) import Data.Ratio ((%))+import Data.Set (Set) import GHC.Exts (IsList(..)) import Text.Show (Show(..)) import qualified Data.HashMap.Strict as HM+import qualified Data.Set as Set  import Test.Tasty import Test.Tasty.HUnit@@ -34,30 +37,29 @@ 		 , Middle ( 74 % 1) 'A' 'F' 		 ]) 	 ]- , let m = mkMerit [ToReject .. TooGood] in+ , let m = mkMerit (enum::Set SchoolGrade) in 	testMajorityValueOfMerits-	 [ (This, m [12,10,21,5,5,5,2])-	 , (That, m [12,16,22,3,3,3,1])+	 [ (This, m [12,10,21,5,5,5])+	 , (That, m [12,16,22,3,3,3]) 	 ]-	 [ (This, [ Middle (8 % 1) Acceptable   Acceptable-	          , Middle (5 % 1) Insufficient Acceptable-	          , Middle (5 % 1) Insufficient Good+	 [ (This, [ Middle (7 % 1) Acceptable   Acceptable+	          , Middle (7 % 1) Insufficient Acceptable+	          , Middle (3 % 1) Insufficient Good+	          , Middle (2 % 1) ToReject     Good 	          , Middle (5 % 1) ToReject     VeryGood 	          , Middle (5 % 1) ToReject     Perfect-	          , Middle (2 % 1) ToReject     TooGood 	          ])-	 , (That, [ Middle ( 2 % 1) Acceptable   Acceptable+	 , (That, [ Middle ( 3 % 2) Acceptable   Acceptable 	          , Middle (16 % 1) Insufficient Acceptable-	          , Middle ( 2 % 1) ToReject     Acceptable+	          , Middle ( 3 % 1) ToReject     Acceptable 	          , Middle ( 3 % 1) ToReject     Good 	          , Middle ( 3 % 1) ToReject     VeryGood 	          , Middle ( 3 % 1) ToReject     Perfect-	          , Middle ( 1 % 1) ToReject     TooGood 	          ]) 	 ]  ]-mkMerit :: (Ord grade, Show grade) => [grade] -> [Share] -> Merit grade-mkMerit gs = fromList . (gs`zip`)+mkMerit :: (Ord grade, Show grade) => Set grade -> [Share] -> Merit grade+mkMerit gs = fromList . (Set.toList gs`zip`)  mkMeritByChoice ::  (Eq choice, Hashable choice, Ord grade) =>

@@ -1,4 +1,5 @@ module HUnit.Rank where+ import Data.Bool import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..))@@ -6,8 +7,8 @@ import Data.Functor ((<$>)) import Data.List import Data.Ord (Ord(..))-import Data.Semigroup (Semigroup(..)) import Data.Ratio+import Data.Semigroup (Semigroup(..)) import GHC.Exts (IsList(..)) import Majority.Judgment import Prelude (Integer, Num(..), fromIntegral)@@ -29,38 +30,62 @@ 	 ]  , testGroup "majority" 	 [ testMajRank 1 1+	 , testMajRank 3 2 	 , testMajRank 5 4 	 , testMajRank 5 5+	 , testMajRank 9 5 	 , testMajRank 10 5+	 , testMajRank 11 5+	 , testMajRank 12 5+	 , testMajRank 13 5+	 , testMajRank 14 5 	 , testMajRank 15 5+	 {- 	 , testMajRank 25 4+	 , testMajRank 25 5+	 , testMajRank 20 6+	 , testMajRank 30 4+	 , testMajRank 30 5+	 , testMajRank 10 10+	 -} 	 ]  ]  testLexRank :: JS -> GS -> TestTree testLexRank js gs = 	testGroup ("js="<>show js<>" gs="<>show gs)-	 [ testCase "rankOfMerit" $-		rankOfMerit gs <$> merits js gs+	 [ testCase "lexicographicRankOfMerit" $+		lexicographicRankOfMerit gs <$> merits js gs 		 @?= [0..lastRank js gs]-	 , testCase "Rank -> Merit -> Rank" $+	 , testCase "lexRankOfMerit . meritOfLexRank == id" $ 		let ranks = [0..lastRank js gs] in-		rankOfMerit gs .-		meritOfRank js gs+		lexicographicRankOfMerit gs . meritOfLexicographicRank js gs 		 <$> ranks @?= ranks-	 , testCase "Merit -> Rank -> Merit" $+	 , testCase "meritOfLexRank . lexRankOfMerit == id" $ 		let dists = merits js gs in-		meritOfRank js gs .-		rankOfMerit gs+		meritOfLexicographicRank js gs . lexicographicRankOfMerit gs 		 <$> dists @?= dists 	 ]  testMajRank :: JS -> GS -> TestTree testMajRank js gs =-	testGroup ("js="<>show js<>" gs="<>show gs)-	 [ testCase "rankOfMajorityValue" $-		rankOfMajorityValue gs <$> majorityValues js gs-		 @?= [0..lastRank js gs]+	let mvs = majorityValues js gs in+	testGroup ("js="<>show js<>" gs="<>show gs<>" ("<>show (countMerits js gs)<>" merits)")+	 [ testCase "listMediansBefore" $+		sum (countMedian js gs <$> listMediansBefore js gs 0 (Median (gs,gs)))+		 @?= countMerits js gs+	 , testCase "majorityValueOfRank" $+		majorityValueOfRank js gs <$> [0..lastRank js gs] @?= mvs+	 , testCase "rankOfMajorityValue" $+		rankOfMajorityValue gs <$> mvs @?= [0..lastRank js gs]+	 {- NOTE: already implied by the previous tests.+	 , testCase "rankOfMV . mvOfRank == id" $+		rankOfMajorityValue gs . majorityValueOfRank js gs+		 <$> [0..lastRank js gs] @?= [0..lastRank js gs]+	 , testCase "mvOfRank . rankOfMV == id" $+		majorityValueOfRank js gs . rankOfMajorityValue gs+		 <$> mvs @?= mvs+	 -} 	 ]  -- | Generate all distributions possible, in lexicographic order.@@ -85,8 +110,8 @@ 		 | r <- reverse [0..js] 		 ] -rankOfMerit :: GS -> [Integer] -> Integer-rankOfMerit gsI dist = go 0 ranks dist+lexicographicRankOfMerit :: GS -> [Integer] -> Integer+lexicographicRankOfMerit gsI dist = go 0 ranks dist 	where 	js  = fromIntegral $ length dist 	gs  = fromIntegral gsI@@ -97,8 +122,8 @@ 		where dI = fromIntegral (d - g0) 	go _ _ _ = 0 -meritOfRank :: JS -> GS -> Integer -> [Integer]-meritOfRank jsI gsI = go 0 ranks+meritOfLexicographicRank :: JS -> GS -> Integer -> [Integer]+meritOfLexicographicRank jsI gsI = go 0 ranks 	where 	js = fromIntegral jsI 	gs = fromIntegral gsI

@@ -25,7 +25,7 @@ hunit = testGroup "Section"  [ testSection "0 judge" 	 ([]::Choices C2)-	 ([]::Judges Int G6)+	 ([]::Judges Int SchoolGrade) 	 (node0 []) 	 (Right $ node0 [])  , testSection "1 judge, default grade"

@@ -3,6 +3,7 @@  import qualified QuickCheck.Gauge import qualified QuickCheck.Merit+import qualified QuickCheck.Rank import qualified QuickCheck.Value  quickchecks :: TestTree@@ -11,4 +12,5 @@ 	 [ QuickCheck.Merit.quickcheck 	 , QuickCheck.Value.quickcheck 	 , QuickCheck.Gauge.quickcheck+	 , QuickCheck.Rank.quickcheck 	 ]

@@ -15,7 +15,7 @@ quickcheck = 	testGroup "Gauge" 	 [ testProperty "majorityGauge and majorityValue consistency" $-		 \(SameLength (x::Merit G6, y)) ->+		 \(SameLength (x::Merit SchoolGrade, y)) -> 			case majorityGauge x`compare`majorityGauge y of 			 LT -> majorityValue x < majorityValue y 			 GT -> majorityValue y < majorityValue x

@@ -26,7 +26,7 @@ quickcheck :: TestTree quickcheck = 	testGroup "Merit"-	 [ testProperty "arbitraryMerits" $ \(SameLength (Merit x::Merit G6,Merit y::Merit G6)) ->+	 [ testProperty "arbitraryMerits" $ \(SameLength (Merit x::Merit SchoolGrade,Merit y::Merit SchoolGrade)) -> 		Map.keys x == Map.keys y && 		sum x == sum y 	 ]

@@ -0,0 +1,38 @@+{-# LANGUAGE TypeApplications #-}+module QuickCheck.Rank where+import Data.Bool++import Data.Eq (Eq(..))+import Data.Function (($))+import Data.Functor ((<$>))+import Data.Ratio (numerator)+import Prelude (Enum(..), (*), fromIntegral)+import Test.Tasty+import Test.Tasty.QuickCheck+import qualified Data.List as List++import Majority.Merit+import Majority.Value+import Majority.Rank+import Types+import QuickCheck.Value ()++quickcheck :: TestTree+quickcheck =+	testGroup "Rank"+	 [ testGroup "majorityValueOfRank . rankOfMajorityValue == id"+		 [ testProperty "SchoolGrade" $ testMVRankMV @SchoolGrade+		 , testProperty "DanishSchoolGrade" $ testMVRankMV @DanishSchoolGrade+		 ]+	 ]++testMVRankMV :: forall g. Enum g => MajorityValue g -> Bool+testMVRankMV mv =+	let gs = fromIntegral $ List.length (enumFrom (toEnum 0) :: [g]) in+	let js = numerator $ (2 *) $ List.sum $ middleShare <$> unMajorityValue mv in+	majorityValueOfRank js gs (rankOfMajorityValue gs mv') == mv'+	where+	ranked a = Ranked (fromIntegral (fromEnum a), ())+	mv' = MajorityValue $+		(<$> unMajorityValue mv) $ \(Middle s l h) ->+			Middle s (ranked l) (ranked h)

@@ -39,7 +39,7 @@ 			where 			alpha = (c-a) % (d-b) 			beta = (a%1) - alpha * (b%1)-instance Arbitrary G6 where+instance Arbitrary SchoolGrade where 	arbitrary = arbitraryBoundedEnum instance Arbitrary DanishSchoolGrade where 	arbitrary = arbitraryBoundedEnum

@@ -1,35 +1,38 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module QuickCheck.Value where-import Majority.Value-import Types-import Data.List (head) -import QuickCheck.Merit-import QuickCheck.Utils-+import Data.Bool import Control.Monad (Monad(..))+import Data.Eq (Eq(..)) import Data.Function (($), (.)) import Data.Functor ((<$>))+import Data.Ord (Ord(..))+import Prelude (Enum(..), Bounded(..)) import Test.Tasty import Test.Tasty.QuickCheck-import Data.Eq (Eq(..))-import Data.Ord (Ord(..))-import Prelude (Enum(..), Integral(..), Bounded(..))+import qualified Data.List as List +import Majority.Value+import Types+import QuickCheck.Merit+import QuickCheck.Utils+ quickcheck :: TestTree quickcheck = 	testGroup "Value" 	 [ testGroup "MajorityValue"-		 [ testProperty "compare" $ \(SameLength (x::MajorityValue G6,y)) ->-			expandValue x`compare` expandValue y == x`compare`y+		 [ testProperty "compare" $ \(SameLength (x::MajorityValue SchoolGrade,y)) ->+			expandValue x `compare` expandValue y == x`compare`y 		 ] 	 ]  instance- (Bounded g, Eq g, Integral g, Arbitrary g) =>+ (Bounded g, Enum g, Ord g, Arbitrary g) =>  Arbitrary (MajorityValue g) where-	arbitrary = head . (majorityValue <$>) <$> arbitraryMerits 1-	shrink (MajorityValue vs) = MajorityValue <$> shrink vs+	arbitrary = List.head . (majorityValue <$>) <$> arbitraryMerits 1+	shrink (MajorityValue vs)+	 | List.null vs = []+	 | otherwise = (MajorityValue <$>) $ List.tail $ List.tails vs instance (Bounded g, Enum g) => Arbitrary (Middle g) where 	arbitrary = do 		lowG  <- choose (fromEnum(minBound::g), fromEnum(maxBound::g))

@@ -16,7 +16,13 @@  deriving (Eq, Ord, Show, Generic) instance Hashable C2 -data G6 = ToReject | Insufficient | Acceptable | Good | VeryGood | Perfect | TooGood+data SchoolGrade+ = ToReject+ | Insufficient+ | Acceptable+ | Good+ | VeryGood+ | Perfect  deriving (Bounded, Enum, Eq, Ord, Show)  -- | Note that the grades 1, 2, 4, and 12 are absent.