179 lines
10 KiB
Haskell
179 lines
10 KiB
Haskell
{-# OPTIONS_GHC -Wwarn #-}
|
|
|
|
module Handler.Utils.ExamSpec where
|
|
|
|
import TestImport
|
|
|
|
import ModelSpec () -- instance Arbitrary User
|
|
|
|
import Test.Hspec.QuickCheck (prop)
|
|
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Text as Text
|
|
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
|
|
<*> arbitrary -- examOccurrenceName
|
|
<*> arbitrary -- examOccurrenceRoom
|
|
<*> arbitrary -- examOccurrenceRoomHidden
|
|
<*> elements [10, 20, 50, 100, 200] -- examOccurrenceCapacity
|
|
<*> arbitrary -- examOccurrenceStart
|
|
<*> arbitrary -- examOccurrenceEnd
|
|
<*> arbitrary -- examOccurrenceDescription
|
|
|
|
|
|
data Preselection = NoPreselection | SomePreselection
|
|
|
|
data Nudges = NoNudges | SmallNudges | LargeNudges
|
|
|
|
-- function Handler.Utils.examAutoOccurrence
|
|
-- examAutoOccurrence :: forall seed.
|
|
-- Hashable seed
|
|
-- => seed
|
|
-- -> ExamOccurrenceRule
|
|
-- -> ExamAutoOccurrenceConfig
|
|
-- -> Map ExamOccurrenceId Natural
|
|
-- -> Map UserId (User, Maybe ExamOccurrenceId)
|
|
-- -> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId))
|
|
-- examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users
|
|
spec :: Spec
|
|
spec = do
|
|
describe "examAutoOccurrence" $ do
|
|
describe "Surname" $ do
|
|
let rule :: ExamOccurrenceRule
|
|
rule = ExamRoomSurname
|
|
describe "No Nudges" $ do
|
|
let nudges = NoNudges
|
|
prop "no preselected" $ propertyTest rule nudges NoPreselection
|
|
prop "some preselected" $ propertyTest rule nudges SomePreselection
|
|
describe "Small Nudges" $ do
|
|
let nudges = SmallNudges
|
|
prop "no preselected" $ propertyTest rule nudges NoPreselection
|
|
prop "some preselected" $ propertyTest rule nudges SomePreselection
|
|
describe "Large Nudges" $ do
|
|
let nudges = LargeNudges
|
|
prop "no preselected" $ propertyTest rule nudges NoPreselection
|
|
prop "some preselected" $ propertyTest rule nudges SomePreselection
|
|
-- TODO test with some users fixed/preselected to certain rooms
|
|
-- TODO test with ExamRoomManual, ExamRoomFifo, (ExamRoomSurname), ExamRoomMatriculation, ExamRoomRandom
|
|
where
|
|
seed :: ()
|
|
seed = ()
|
|
-- TODO adjust with different nudges, depended on occurrences list/map
|
|
-- def {eaocNudge = Map.singleton occ20Id (-11)}
|
|
--ExamAutoOccurrenceConfig {eaocMinimizeRooms = False, eaocFinenessCost = 1 % 5, eaocNudge = fromList [(SqlBackendKey {unSqlBackendKey = 4},-11)], eaocNudgeSize = 1 % 20}
|
|
propertyTest :: ExamOccurrenceRule -> Nudges -> Preselection -> Gen Property
|
|
propertyTest rule nudges preselection = do
|
|
(users, occurrences) <- genUsersWithOccurrences preselection
|
|
eaocNudge <- case nudges of
|
|
NoNudges -> pure Map.empty
|
|
SmallNudges -> let nudgeFrequency = [(10, 0), (5, 1), (5, -1), (3, 2), (3, -2), (1, 3), (1, -3)]
|
|
in foldM (genNudge nudgeFrequency) Map.empty $ Map.keys occurrences
|
|
LargeNudges -> let nudgeFrequency = [(7, 0), (5, 3), (5, -3), (3, 6), (3, -6), (2, 9), (2, -9),
|
|
(2, 11), (2, -11), (1, 15), (1,-15), (1, 17), (1, -17)]
|
|
in foldM (genNudge nudgeFrequency) Map.empty $ Map.keys occurrences
|
|
let config :: ExamAutoOccurrenceConfig
|
|
config = def {eaocNudge}
|
|
result@(_maybeMapping, userMap) = examAutoOccurrence seed rule config occurrences users
|
|
pure $ ioProperty $ do
|
|
-- every user got assigned a room
|
|
shouldBe (length userMap) (length users)
|
|
shouldSatisfy userMap $ all isJust
|
|
-- no room is overfull
|
|
shouldSatisfy (occurrences, userMap) $ uncurry fitsInRooms
|
|
-- all users match the shown ranges
|
|
shouldSatisfy (users, result) $ uncurry showsCorrectRanges
|
|
-- | generate users without any pre-assigned rooms
|
|
genUsersWithOccurrences :: Preselection -> Gen (Map UserId (User, Maybe ExamOccurrenceId), Map ExamOccurrenceId Natural)
|
|
genUsersWithOccurrences preselection = do
|
|
rawUsers <- listOf1 $ Entity <$> arbitrary <*> arbitrary
|
|
occurrences <- genOccurrences $ length rawUsers
|
|
-- user surnames anpassen, sodass interessante instanz
|
|
users <- fmap Map.fromList $ forM rawUsers $ \Entity {entityKey, entityVal} -> do
|
|
userSurname <- elements surnames
|
|
assignedRoom <- case preselection of
|
|
NoPreselection -> pure Nothing
|
|
SomePreselection -> frequency [(97, pure Nothing), (3, elements $ map Just $ Map.keys occurrences)]
|
|
pure (entityKey, (entityVal {userSurname}, assignedRoom))
|
|
pure (users, occurrences)
|
|
genOccurrences :: Int -> Gen (Map ExamOccurrenceId Natural)
|
|
genOccurrences numUsers = do
|
|
-- TODO is this realistic?
|
|
-- extra space to get nice borders
|
|
extraSpace <- elements [numUsers `div` 4 .. numUsers `div` 2]
|
|
let totalSpaceRequirement = fromIntegral $ numUsers + extraSpace
|
|
createOccurrences acc
|
|
| sum (map snd acc) < totalSpaceRequirement = do
|
|
Entity {entityKey, entityVal} <- Entity <$> arbitrary <*> arbitrary
|
|
createOccurrences $ (entityKey, examOccurrenceCapacity entityVal) : acc
|
|
| otherwise = pure acc
|
|
Map.fromList <$> createOccurrences []
|
|
genNudge :: [(Int, Integer)] -> Map ExamOccurrenceId Integer -> ExamOccurrenceId -> Gen (Map ExamOccurrenceId Integer)
|
|
genNudge nudgesList acc occurrenceId
|
|
= fmap appendNonZero $ frequency $ map (second pure) nudgesList
|
|
where
|
|
appendNonZero :: Integer -> Map ExamOccurrenceId Integer
|
|
appendNonZero 0 = acc
|
|
appendNonZero nudge = Map.insert occurrenceId nudge acc
|
|
-- name list copied from test/Database/Fill.hs
|
|
surnames :: [Text]
|
|
surnames = [ "Smith", "Johnson", "Williams", "Brown"
|
|
, "Jones", "Miller", "Davis", "Garcia"
|
|
, "Rodriguez", "Wilson", "Martinez", "Anderson"
|
|
, "Taylor", "Thomas", "Hernandez", "Moore"
|
|
, "Martin", "Jackson", "Thompson", "White"
|
|
, "Lopez", "Lee", "Gonzalez", "Harris"
|
|
, "Clark", "Lewis", "Robinson", "Walker"
|
|
, "Perez", "Hall", "Young", "Allen"
|
|
]
|
|
occurrenceMap :: Map UserId (Maybe ExamOccurrenceId) -> Map ExamOccurrenceId [UserId]
|
|
occurrenceMap userMap = foldl' (\acc (userId, maybeOccurrenceId) -> appendJust maybeOccurrenceId userId acc)
|
|
Map.empty $ Map.toAscList userMap
|
|
where
|
|
appendJust :: Maybe ExamOccurrenceId -> UserId -> Map ExamOccurrenceId [UserId] -> Map ExamOccurrenceId [UserId]
|
|
appendJust Nothing _userId = id
|
|
appendJust (Just occurrenceId) userId = Map.insertWith (++) occurrenceId [userId]
|
|
-- | Are all rooms large enough to hold all assigned Users?
|
|
fitsInRooms :: Map ExamOccurrenceId Natural
|
|
-> Map UserId (Maybe ExamOccurrenceId)
|
|
-> Bool
|
|
fitsInRooms occurrences userMap
|
|
= all roomIsBigEnough $ Map.toAscList $ occurrenceMap userMap
|
|
where
|
|
roomIsBigEnough :: (ExamOccurrenceId, [UserId]) -> Bool
|
|
roomIsBigEnough (roomId, userIds) = case lookup roomId occurrences of
|
|
Nothing -> False
|
|
(Just capacity) -> length userIds <= fromIntegral capacity
|
|
-- | Does the (currently surname) User fit to the displayed ranges?
|
|
-- Users with a previously assigned room are checked if the assignment stays the same, regardless of the ranges.
|
|
showsCorrectRanges :: Map UserId (User, Maybe ExamOccurrenceId)
|
|
-> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId))
|
|
-> Bool
|
|
showsCorrectRanges _users (Nothing, _userMap) = False
|
|
showsCorrectRanges users (Just (examOccurrenceMappingMapping -> mappingRanges), userMap)
|
|
= all userFitsInRange $ Map.toAscList $ occurrenceMap userMap
|
|
where
|
|
userFitsInRange :: (ExamOccurrenceId, [UserId]) -> Bool
|
|
userFitsInRange (roomId, userIds) = flip all userIds $ \userId ->
|
|
case (Map.lookup roomId mappingRanges, Map.lookup userId users) of
|
|
(_maybeRanges, Just (User {}, Just fixedRoomId))
|
|
-> roomId == fixedRoomId
|
|
(Just ranges, Just (User {userSurname}, Nothing))
|
|
-> any fitsInRange ranges
|
|
where
|
|
ciSurname :: [CI Char]
|
|
ciSurname = map CI.mk $ Text.unpack userSurname
|
|
fitsInRange :: ExamOccurrenceMappingDescription -> Bool
|
|
fitsInRange ExamOccurrenceMappingRange {eaomrStart, eaomrEnd}
|
|
= eaomrStart <= ciSurname && (take (length eaomrEnd) ciSurname <= eaomrEnd)
|
|
fitsInRange ExamOccurrenceMappingSpecial {}
|
|
= True -- FIXME what is the meaning of special?
|
|
_otherwise -> False
|