chore(test): allow valid nullResults
ExamRoomMatriculation sometimes shows incorrect ranges
This commit is contained in:
Wolfgang Witt
Wolfgang Witt
parent
9d8a94717a
commit
48ee67f6d6
@ -16,9 +16,6 @@ import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Handler.Utils.Exam
|
||||
|
||||
-- TODO
|
||||
-- use frequency instead of elements?
|
||||
-- are these capacity values realistic?
|
||||
instance Arbitrary ExamOccurrence where
|
||||
arbitrary = ExamOccurrence
|
||||
<$> arbitrary -- examOccurrenceExam
|
||||
@ -42,6 +39,9 @@ data Nudges = NoNudges | SmallNudges | LargeNudges
|
||||
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
|
||||
uncurry3 f (a, b, c) = f a b c
|
||||
|
||||
uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
|
||||
uncurry4 f (a, b, c, d) = f a b c d
|
||||
|
||||
-- | Kopie der User-Datenstruktur beschränkt auf interessante Felder (besser verständliche Show-Instanz)
|
||||
data UserProperties = UserProperties {pSurname :: Text, pMatrikelnummer :: Maybe Text}
|
||||
deriving (Show)
|
||||
@ -62,14 +62,12 @@ extractProperties User {userSurname, userMatrikelnummer} = UserProperties userSu
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "examAutoOccurrence" $ do
|
||||
{-
|
||||
describe "Surname" $ do
|
||||
let rule :: ExamOccurrenceRule
|
||||
rule = ExamRoomSurname
|
||||
forM_ universeF $ \nudges -> describe (show nudges) $
|
||||
forM_ universeF $ \preselection ->
|
||||
prop (show preselection) $ propertyTest rule nudges preselection
|
||||
-}
|
||||
describe "Matriculation" $ do
|
||||
let rule :: ExamOccurrenceRule
|
||||
rule = ExamRoomMatriculation
|
||||
@ -92,7 +90,7 @@ spec = do
|
||||
in foldM (genNudge nudgeFrequency) Map.empty $ Map.keys occurrences
|
||||
let config :: ExamAutoOccurrenceConfig
|
||||
config = def {eaocNudge}
|
||||
result@(_maybeMapping, userMap) = examAutoOccurrence seed rule config occurrences users
|
||||
(maybeMapping, userMap) = examAutoOccurrence seed rule config occurrences users
|
||||
pure $ ioProperty $ do
|
||||
-- every (relevant) user got assigned a room
|
||||
shouldBe (length userMap) (length users)
|
||||
@ -109,8 +107,12 @@ spec = do
|
||||
let userProperties :: Map UserId (UserProperties, Maybe ExamOccurrenceId)
|
||||
userProperties = Map.map (first extractProperties) users
|
||||
shouldSatisfy (userProperties, occurrences, userMap) $ uncurry3 fitsInRooms
|
||||
-- all users match the shown ranges
|
||||
shouldSatisfy (rule, userProperties, result) $ uncurry3 showsCorrectRanges
|
||||
case maybeMapping of
|
||||
-- all users match the shown ranges
|
||||
(Just occurrenceMapping)
|
||||
-> shouldSatisfy (rule, userProperties, occurrenceMapping, userMap) $ uncurry4 showsCorrectRanges
|
||||
-- is a nullResult justified?
|
||||
Nothing -> shouldSatisfy (rule, userProperties, occurrences) $ uncurry3 isNullResultJustified
|
||||
-- | generate users without any pre-assigned rooms
|
||||
genUsersWithOccurrences :: Preselection -> Gen (Map UserId (User, Maybe ExamOccurrenceId), Map ExamOccurrenceId Natural)
|
||||
genUsersWithOccurrences preselection = do
|
||||
@ -178,10 +180,10 @@ spec = do
|
||||
-- Users with a previously assigned room are checked if the assignment stays the same, regardless of the ranges.
|
||||
showsCorrectRanges :: ExamOccurrenceRule
|
||||
-> Map UserId (UserProperties, Maybe ExamOccurrenceId)
|
||||
-> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId))
|
||||
-> ExamOccurrenceMapping ExamOccurrenceId
|
||||
-> Map UserId (Maybe ExamOccurrenceId)
|
||||
-> Bool
|
||||
showsCorrectRanges _rule _userProperties (Nothing, _userMap) = False
|
||||
showsCorrectRanges rule userProperties (Just (examOccurrenceMappingMapping -> mappingRanges), userMap)
|
||||
showsCorrectRanges rule userProperties (examOccurrenceMappingMapping -> mappingRanges) userMap
|
||||
= all userFitsInRange $ Map.toAscList $ occurrenceMap userMap
|
||||
where
|
||||
userFitsInRange :: (ExamOccurrenceId, [UserId]) -> Bool
|
||||
@ -204,3 +206,47 @@ spec = do
|
||||
fitsInRange ExamOccurrenceMappingSpecial {}
|
||||
= True -- FIXME what is the meaning of special?
|
||||
_otherwise -> False
|
||||
-- | Is mapping impossible?
|
||||
isNullResultJustified :: ExamOccurrenceRule
|
||||
-> Map UserId (UserProperties, Maybe ExamOccurrenceId)
|
||||
-> Map ExamOccurrenceId Natural -> Bool
|
||||
isNullResultJustified rule userProperties occurrences
|
||||
= noRelevantUsers rule userProperties || mappingImpossible rule userProperties occurrences
|
||||
noRelevantUsers :: ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Bool
|
||||
noRelevantUsers rule = null . Map.filter (isRelevantUser rule)
|
||||
isRelevantUser :: ExamOccurrenceRule -> (UserProperties, Maybe ExamOccurrenceId) -> Bool
|
||||
isRelevantUser _rule (_user, Just _assignedRoom) = False
|
||||
isRelevantUser rule (UserProperties {pSurname, pMatrikelnummer}, Nothing) = case rule of
|
||||
ExamRoomSurname -> not $ null pSurname
|
||||
ExamRoomMatriculation -> maybe False (not . null) pMatrikelnummer
|
||||
_rule -> False
|
||||
mappingImpossible :: ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map ExamOccurrenceId Natural -> Bool
|
||||
mappingImpossible
|
||||
rule
|
||||
userProperties@(sort . map (ruleProperty rule . fst) . Map.elems . Map.filter (isRelevantUser rule) -> relevantUsers)
|
||||
(map snd . Map.toList . adjustOccurrences userProperties -> occurrences') = go relevantUsers occurrences'
|
||||
where
|
||||
go :: [Maybe Text] -> [Natural] -> Bool
|
||||
go [] _occurrences = False
|
||||
go _remainingUsers [] = True
|
||||
go remainingUsers (0:t) = go remainingUsers t
|
||||
go remainingUsers@(h:_t) (firstOccurrence:laterOccurrences)
|
||||
| nextUsers <= firstOccurrence = go remainingUsers' $ firstOccurrence - nextUsers : laterOccurrences
|
||||
| otherwise = go remainingUsers laterOccurrences
|
||||
where
|
||||
(fromIntegral . length -> nextUsers, remainingUsers') = span (== h) remainingUsers
|
||||
ruleProperty :: ExamOccurrenceRule -> UserProperties -> Maybe Text
|
||||
ruleProperty rule = case rule of
|
||||
ExamRoomSurname -> Just . pSurname
|
||||
ExamRoomMatriculation -> pMatrikelnummer
|
||||
_rule -> const Nothing
|
||||
-- copied and adjusted from Hander.Utils.Exam
|
||||
adjustOccurrences :: Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map ExamOccurrenceId Natural -> Map ExamOccurrenceId Natural
|
||||
-- ^ reduce room capacity for every pre-assigned user by 1
|
||||
adjustOccurrences userProperties occurrences = foldl' (flip $ Map.update predToPositive) occurrences $ Map.mapMaybe snd userProperties
|
||||
-- FIXME what about capacity-0 in occurrences?
|
||||
-- what if the first word is too big for the first room?
|
||||
predToPositive :: Natural -> Maybe Natural
|
||||
predToPositive 0 = Nothing
|
||||
predToPositive 1 = Nothing
|
||||
predToPositive n = Just $ pred n
|
||||
|
||||
Loading…
Reference in New Issue
Block a user