Merge branch 'exam-rooms' into 'master'
Fix problems with examAutoOccurence See merge request uni2work/uni2work!33
This commit is contained in:
Gregor Kleen
commit
578a78f21b
@ -2800,9 +2800,15 @@ BtnExamAutoOccurrenceNudgeUp: +
|
|||||||
BtnExamAutoOccurrenceNudgeDown: -
|
BtnExamAutoOccurrenceNudgeDown: -
|
||||||
ExamRoomMappingSurname: Nachnamen beginnend mit
|
ExamRoomMappingSurname: Nachnamen beginnend mit
|
||||||
ExamRoomMappingMatriculation: Matrikelnummern endend in
|
ExamRoomMappingMatriculation: Matrikelnummern endend in
|
||||||
|
ExamRoomMappingRandom: Verteilung
|
||||||
|
ExamRoomMappingRandomHere: Zufällig
|
||||||
ExamRoomLoad: Auslastung
|
ExamRoomLoad: Auslastung
|
||||||
ExamRegisteredCount: Anmeldungen
|
ExamRegisteredCount: Anmeldungen
|
||||||
ExamRegisteredCountOf num@Int64 count@Int64: #{num}/#{count}
|
ExamRegisteredCountOf num@Int64 count@Int64: #{num}/#{count}
|
||||||
|
ExamAutoOccurrenceExceptionRuleNoOp: Kein Verfahren zur automatischen Verteilung gewählt
|
||||||
|
ExamAutoOccurrenceExceptionNotEnoughSpace: Mehr Teilnehmende als verfügbare Plätze
|
||||||
|
ExamAutoOccurrenceExceptionNoUsers: Nach dem gewähltem Verfahren können keine Teilnehmenden verteilt werden
|
||||||
|
ExamAutoOccurrenceExceptionRoomTooSmall: Automatische Verteilung gescheitert. Ein anderes Verteil-Verfahren kann erfolgreich sein. Alternativ kann es helfen Räume zu minimieren oder kleine Räume zu entfernen.
|
||||||
|
|
||||||
NoFilter: Keine Einschränkung
|
NoFilter: Keine Einschränkung
|
||||||
|
|
||||||
|
|||||||
@ -2792,7 +2792,7 @@ ExamAutoOccurrenceHeading: Automatic occurrence/room distribution
|
|||||||
ExamAutoOccurrenceMinimizeRooms: Minimize number of occurrences used
|
ExamAutoOccurrenceMinimizeRooms: Minimize number of occurrences used
|
||||||
ExamAutoOccurrenceMinimizeRoomsTip: Should the list of occurrences/rooms be reduced prior to distribution? Only as many occurrence/rooms as necessary would be used (starting with the biggest).
|
ExamAutoOccurrenceMinimizeRoomsTip: Should the list of occurrences/rooms be reduced prior to distribution? Only as many occurrence/rooms as necessary would be used (starting with the biggest).
|
||||||
ExamAutoOccurrenceOccurrencesChangedInFlight: Occurrences/rooms changed
|
ExamAutoOccurrenceOccurrencesChangedInFlight: Occurrences/rooms changed
|
||||||
ExamAutoOccurrenceParticipantsAssigned num: Occurrence/room assignment rule saved successfully. Also assigned occurence/room to #{num} #{pluralEN num "participant" "participants"}
|
ExamAutoOccurrenceParticipantsAssigned num: Occurrence/room assignment rule saved successfully. Also assigned occurrence/room to #{num} #{pluralEN num "participant" "participants"}
|
||||||
TitleExamAutoOccurrence tid ssh csh examn: #{tid} - #{ssh} - #{csh} #{examn}: Automatic occurrence/room distribution
|
TitleExamAutoOccurrence tid ssh csh examn: #{tid} - #{ssh} - #{csh} #{examn}: Automatic occurrence/room distribution
|
||||||
BtnExamAutoOccurrenceCalculate: Calculate assignment rules
|
BtnExamAutoOccurrenceCalculate: Calculate assignment rules
|
||||||
BtnExamAutoOccurrenceAccept: Accept assignments
|
BtnExamAutoOccurrenceAccept: Accept assignments
|
||||||
@ -2800,9 +2800,15 @@ BtnExamAutoOccurrenceNudgeUp: +
|
|||||||
BtnExamAutoOccurrenceNudgeDown: -
|
BtnExamAutoOccurrenceNudgeDown: -
|
||||||
ExamRoomMappingSurname: Surnames starting with
|
ExamRoomMappingSurname: Surnames starting with
|
||||||
ExamRoomMappingMatriculation: Matriculation numbers ending in
|
ExamRoomMappingMatriculation: Matriculation numbers ending in
|
||||||
|
ExamRoomMappingRandom: Distribution
|
||||||
|
ExamRoomMappingRandomHere: Random
|
||||||
ExamRoomLoad: Utilisation
|
ExamRoomLoad: Utilisation
|
||||||
ExamRegisteredCount: Registrations
|
ExamRegisteredCount: Registrations
|
||||||
ExamRegisteredCountOf num count: #{num}/#{count}
|
ExamRegisteredCountOf num count: #{num}/#{count}
|
||||||
|
ExamAutoOccurrenceExceptionRuleNoOp: Didn't chose an automatic distribution procedure
|
||||||
|
ExamAutoOccurrenceExceptionNotEnoughSpace: More participants than available space
|
||||||
|
ExamAutoOccurrenceExceptionNoUsers: No participants can be distributed with the chosen procedure
|
||||||
|
ExamAutoOccurrenceExceptionRoomTooSmall: Automatic distribution failed. A different distribution procedure might succeed. Alternatively, minimizing rooms or removing small rooms might help.
|
||||||
|
|
||||||
NoFilter: No restriction
|
NoFilter: No restriction
|
||||||
|
|
||||||
|
|||||||
@ -162,6 +162,8 @@ dependencies:
|
|||||||
- nonce
|
- nonce
|
||||||
- IntervalMap
|
- IntervalMap
|
||||||
- haskell-src-meta
|
- haskell-src-meta
|
||||||
|
- either
|
||||||
|
|
||||||
other-extensions:
|
other-extensions:
|
||||||
- GeneralizedNewtypeDeriving
|
- GeneralizedNewtypeDeriving
|
||||||
- IncoherentInstances
|
- IncoherentInstances
|
||||||
|
|||||||
@ -23,7 +23,7 @@ newtype ExamAutoOccurrenceCalculateForm = ExamAutoOccurrenceCalculateForm
|
|||||||
makeLenses_ ''ExamAutoOccurrenceCalculateForm
|
makeLenses_ ''ExamAutoOccurrenceCalculateForm
|
||||||
|
|
||||||
data ExamAutoOccurrenceAcceptForm = ExamAutoOccurrenceAcceptForm
|
data ExamAutoOccurrenceAcceptForm = ExamAutoOccurrenceAcceptForm
|
||||||
{ eaofMapping :: Maybe (ExamOccurrenceMapping ExamOccurrenceId)
|
{ eaofMapping :: ExamOccurrenceMapping ExamOccurrenceId
|
||||||
, eaofAssignment :: Map UserId (Maybe ExamOccurrenceId)
|
, eaofAssignment :: Map UserId (Maybe ExamOccurrenceId)
|
||||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||||
|
|
||||||
@ -114,7 +114,12 @@ postEAutoOccurrenceR tid ssh csh examn = do
|
|||||||
(Entity uid userRec, Entity _ ExamRegistration{..}) <- participants
|
(Entity uid userRec, Entity _ ExamRegistration{..}) <- participants
|
||||||
return (uid, (userRec, examRegistrationOccurrence))
|
return (uid, (userRec, examRegistrationOccurrence))
|
||||||
occurrences' = Map.fromList $ map (\(Entity eoId ExamOccurrence{..}) -> (eoId, fromIntegral examOccurrenceCapacity)) occurrences
|
occurrences' = Map.fromList $ map (\(Entity eoId ExamOccurrence{..}) -> (eoId, fromIntegral examOccurrenceCapacity)) occurrences
|
||||||
(eaofMapping, eaofAssignment) = examAutoOccurrence eId examOccurrenceRule eaofConfig occurrences' participants'
|
autoOccurrenceResult = examAutoOccurrence eId examOccurrenceRule eaofConfig occurrences' participants'
|
||||||
|
(eaofMapping, eaofAssignment) <- case autoOccurrenceResult of
|
||||||
|
(Left e) -> do
|
||||||
|
addMessageI Error e
|
||||||
|
redirect $ CExamR tid ssh csh examn EUsersR
|
||||||
|
(Right r) -> pure r
|
||||||
return $ Just ExamAutoOccurrenceAcceptForm{..}
|
return $ Just ExamAutoOccurrenceAcceptForm{..}
|
||||||
|
|
||||||
((confirmRes, confirmView), confirmEncoding) <- runFormPost $ examAutoOccurrenceAcceptForm calcResult
|
((confirmRes, confirmView), confirmEncoding) <- runFormPost $ examAutoOccurrenceAcceptForm calcResult
|
||||||
@ -126,14 +131,13 @@ postEAutoOccurrenceR tid ssh csh examn = do
|
|||||||
|
|
||||||
formResult confirmRes $ \ExamAutoOccurrenceAcceptForm{..} -> do
|
formResult confirmRes $ \ExamAutoOccurrenceAcceptForm{..} -> do
|
||||||
Sum assignedCount <- runDB $ do
|
Sum assignedCount <- runDB $ do
|
||||||
let eaofMapping'' :: Maybe (Maybe (ExamOccurrenceMapping ExamOccurrenceName))
|
let eaofMapping'' :: Maybe (ExamOccurrenceMapping ExamOccurrenceName)
|
||||||
eaofMapping'' = (<$> eaofMapping) . traverseExamOccurrenceMapping $ \eoId -> case filter ((== eoId) . entityKey) occurrences of
|
eaofMapping'' = ($ eaofMapping) . traverseExamOccurrenceMapping $ \eoId -> case filter ((== eoId) . entityKey) occurrences of
|
||||||
[Entity _ ExamOccurrence{..}] -> Just examOccurrenceName
|
[Entity _ ExamOccurrence{..}] -> Just examOccurrenceName
|
||||||
_other -> Nothing
|
_other -> Nothing
|
||||||
eaofMapping' <- case eaofMapping'' of
|
eaofMapping' <- case eaofMapping'' of
|
||||||
Nothing -> return Nothing
|
Nothing -> invalidArgsI [MsgExamAutoOccurrenceOccurrencesChangedInFlight]
|
||||||
Just Nothing -> invalidArgsI [MsgExamAutoOccurrenceOccurrencesChangedInFlight]
|
Just x -> return $ Just x
|
||||||
Just (Just x ) -> return $ Just x
|
|
||||||
update eId [ ExamExamOccurrenceMapping =. eaofMapping' ]
|
update eId [ ExamExamOccurrenceMapping =. eaofMapping' ]
|
||||||
fmap fold . iforM eaofAssignment $ \pid occ -> case occ of
|
fmap fold . iforM eaofAssignment $ \pid occ -> case occ of
|
||||||
Just _ -> Sum <$> updateWhereCount [ ExamRegistrationExam ==. eId, ExamRegistrationUser ==. pid, ExamRegistrationOccurrence ==. Nothing ] [ ExamRegistrationOccurrence =. occ ]
|
Just _ -> Sum <$> updateWhereCount [ ExamRegistrationExam ==. eId, ExamRegistrationUser ==. pid, ExamRegistrationOccurrence ==. Nothing ] [ ExamRegistrationOccurrence =. occ ]
|
||||||
@ -158,13 +162,13 @@ postEAutoOccurrenceR tid ssh csh examn = do
|
|||||||
|
|
||||||
occLoad = fromMaybe 0 . flip Map.lookup occLoads
|
occLoad = fromMaybe 0 . flip Map.lookup occLoads
|
||||||
|
|
||||||
occMappingRule = examOccurrenceMappingRule <$> eaofMapping
|
occMappingRule = examOccurrenceMappingRule eaofMapping
|
||||||
|
|
||||||
loadProp curr max'
|
loadProp curr max'
|
||||||
| max' /= 0 = MsgProportion (toMessage curr) (toMessage max') (toRational curr / toRational max')
|
| max' /= 0 = MsgProportion (toMessage curr) (toMessage max') (toRational curr / toRational max')
|
||||||
| otherwise = MsgProportionNoRatio (toMessage curr) (toMessage max')
|
| otherwise = MsgProportionNoRatio (toMessage curr) (toMessage max')
|
||||||
|
|
||||||
occMapping occId = examOccurrenceMappingDescriptionWidget <$> occMappingRule <*> (Map.lookup occId . examOccurrenceMappingMapping =<< eaofMapping)
|
occMapping occId = examOccurrenceMappingDescriptionWidget occMappingRule <$> Map.lookup occId (examOccurrenceMappingMapping eaofMapping)
|
||||||
in $(widgetFile "widgets/exam-occurrence-mapping")
|
in $(widgetFile "widgets/exam-occurrence-mapping")
|
||||||
|
|
||||||
siteLayoutMsg heading $ do
|
siteLayoutMsg heading $ do
|
||||||
|
|||||||
@ -9,6 +9,7 @@ module Handler.Utils.Exam
|
|||||||
, ExamAutoOccurrenceConfig
|
, ExamAutoOccurrenceConfig
|
||||||
, eaocMinimizeRooms, eaocFinenessCost, eaocNudge, eaocNudgeSize
|
, eaocMinimizeRooms, eaocFinenessCost, eaocNudge, eaocNudgeSize
|
||||||
, _eaocMinimizeRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize
|
, _eaocMinimizeRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize
|
||||||
|
, ExamAutoOccurrenceException(..)
|
||||||
, examAutoOccurrence
|
, examAutoOccurrence
|
||||||
, deregisterExamUsersCount, deregisterExamUsers
|
, deregisterExamUsersCount, deregisterExamUsers
|
||||||
, examAidsPresetWidget, examOnlinePresetWidget, examSynchronicityPresetWidget, examRequiredEquipmentPresetWidget
|
, examAidsPresetWidget, examOnlinePresetWidget, examSynchronicityPresetWidget, examRequiredEquipmentPresetWidget
|
||||||
@ -27,15 +28,15 @@ import Database.Esqueleto.Utils.TH
|
|||||||
import qualified Data.Conduit.List as C
|
import qualified Data.Conduit.List as C
|
||||||
|
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
|
import qualified Data.Map.Merge.Lazy as Map
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
import qualified Data.Foldable as F
|
import qualified Data.Foldable as F
|
||||||
|
|
||||||
import qualified Data.CaseInsensitive as CI
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
|
||||||
import Control.Monad.Trans.Random.Lazy (evalRand)
|
|
||||||
import System.Random (mkStdGen)
|
import System.Random (mkStdGen)
|
||||||
import Control.Monad.Random.Class (weighted)
|
import System.Random.Shuffle (shuffle')
|
||||||
import Control.Monad.ST (ST, runST)
|
import Control.Monad.ST (ST, runST)
|
||||||
|
|
||||||
import Data.Array (Array)
|
import Data.Array (Array)
|
||||||
@ -47,9 +48,9 @@ import qualified Data.Array.ST as ST
|
|||||||
import Data.List (findIndex, unfoldr)
|
import Data.List (findIndex, unfoldr)
|
||||||
import qualified Data.List as List
|
import qualified Data.List as List
|
||||||
|
|
||||||
import Data.ExtendedReal
|
import Data.Either.Combinators (maybeToRight)
|
||||||
|
|
||||||
import qualified Data.Char as Char
|
import Data.ExtendedReal
|
||||||
|
|
||||||
import qualified Data.RFC5051 as RFC5051
|
import qualified Data.RFC5051 as RFC5051
|
||||||
|
|
||||||
@ -257,6 +258,16 @@ deriveJSON defaultOptions
|
|||||||
{ fieldLabelModifier = camelToPathPiece' 1
|
{ fieldLabelModifier = camelToPathPiece' 1
|
||||||
} ''ExamAutoOccurrenceConfig
|
} ''ExamAutoOccurrenceConfig
|
||||||
|
|
||||||
|
data ExamAutoOccurrenceException
|
||||||
|
= ExamAutoOccurrenceExceptionRuleNoOp
|
||||||
|
| ExamAutoOccurrenceExceptionNotEnoughSpace
|
||||||
|
| ExamAutoOccurrenceExceptionNoUsers
|
||||||
|
| ExamAutoOccurrenceExceptionRoomTooSmall
|
||||||
|
deriving (Show, Generic, Typeable)
|
||||||
|
|
||||||
|
instance Exception ExamAutoOccurrenceException
|
||||||
|
|
||||||
|
embedRenderMessage ''UniWorX ''ExamAutoOccurrenceException id
|
||||||
|
|
||||||
examAutoOccurrence :: forall seed.
|
examAutoOccurrence :: forall seed.
|
||||||
Hashable seed
|
Hashable seed
|
||||||
@ -265,28 +276,58 @@ examAutoOccurrence :: forall seed.
|
|||||||
-> ExamAutoOccurrenceConfig
|
-> ExamAutoOccurrenceConfig
|
||||||
-> Map ExamOccurrenceId Natural
|
-> Map ExamOccurrenceId Natural
|
||||||
-> Map UserId (User, Maybe ExamOccurrenceId)
|
-> Map UserId (User, Maybe ExamOccurrenceId)
|
||||||
-> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId))
|
-> Either ExamAutoOccurrenceException (ExamOccurrenceMapping ExamOccurrenceId, Map UserId (Maybe ExamOccurrenceId))
|
||||||
examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users
|
examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users
|
||||||
| sum occurrences < usersCount
|
| Map.null users'
|
||||||
|| sum occurrences <= 0
|
= Left ExamAutoOccurrenceExceptionNoUsers
|
||||||
|| Map.null users
|
| sum occurrences' < usersCount
|
||||||
= nullResult
|
|| sum occurrences' <= 0
|
||||||
|
= Left ExamAutoOccurrenceExceptionNotEnoughSpace
|
||||||
| otherwise
|
| otherwise
|
||||||
= case rule of
|
= case rule of
|
||||||
ExamRoomRandom
|
ExamRoomRandom
|
||||||
-> ( Nothing
|
-> Right ( ExamOccurrenceMapping {
|
||||||
, flip Map.mapWithKey users $ \uid (_, mOcc)
|
examOccurrenceMappingRule = rule,
|
||||||
-> let randomOcc = flip evalRand (mkStdGen $ hashWithSalt seed uid) $
|
examOccurrenceMappingMapping = Map.fromList $ set _2 (Set.singleton ExamOccurrenceMappingRandom) <$> occurrences''
|
||||||
weighted $ over _2 fromIntegral <$> occurrences'
|
}
|
||||||
in Just $ fromMaybe randomOcc mOcc
|
, Map.union (view _2 <$> assignedUsers) randomlyAssignedUsers
|
||||||
)
|
)
|
||||||
_ | Just (postprocess -> (resMapping, result)) <- bestOption
|
where
|
||||||
-> ( Just $ ExamOccurrenceMapping rule resMapping
|
assignedUsers,unassignedUsers :: Map UserId (User, Maybe ExamOccurrenceId)
|
||||||
, Map.unionWith (<|>) (view _2 <$> users) result
|
(assignedUsers, unassignedUsers) = Map.partition (has $ _2 . _Just) users
|
||||||
)
|
shuffledUsers :: [UserId]
|
||||||
_ -> nullResult
|
shuffledUsers = shuffle' (Map.keys unassignedUsers) (length unassignedUsers) (mkStdGen seed)
|
||||||
|
occurrencesMap :: Map ExamOccurrenceId Natural
|
||||||
|
occurrencesMap = Map.fromList occurrences''
|
||||||
|
-- reduce available space until to excess space is left while keeping the filling ratio as equal as possible
|
||||||
|
decreaseBiggestOutlier :: Natural -> Map ExamOccurrenceId Natural -> Map ExamOccurrenceId Natural
|
||||||
|
decreaseBiggestOutlier 0 currentOccurrences = currentOccurrences
|
||||||
|
decreaseBiggestOutlier n currentOccurrences = decreaseBiggestOutlier (pred n)
|
||||||
|
$ Map.update predToPositive biggestOutlier currentOccurrences
|
||||||
|
where
|
||||||
|
currentRatios :: Map ExamOccurrenceId Rational
|
||||||
|
currentRatios = Map.merge Map.dropMissing Map.dropMissing (Map.zipWithMatched calculateRatio)
|
||||||
|
currentOccurrences occurrencesMap
|
||||||
|
calculateRatio :: ExamOccurrenceId -> Natural -> Natural -> Rational
|
||||||
|
calculateRatio k c m = fromIntegral c % fromIntegral m - eaocNudgeSize * fromIntegral (lineNudges k)
|
||||||
|
biggestOutlier :: ExamOccurrenceId
|
||||||
|
biggestOutlier = fst . List.maximumBy (comparing $ view _2) $ Map.toList currentRatios
|
||||||
|
extraCapacity :: Natural
|
||||||
|
extraCapacity = sumOf (folded . _2) occurrences'' - fromIntegral (length unassignedUsers)
|
||||||
|
finalOccurrences :: [(ExamOccurrenceId, Natural)]
|
||||||
|
finalOccurrences = Map.toList $ decreaseBiggestOutlier extraCapacity occurrencesMap
|
||||||
|
-- fill in users in a random order
|
||||||
|
randomlyAssignedUsers :: Map UserId (Maybe ExamOccurrenceId)
|
||||||
|
randomlyAssignedUsers = Map.fromList $ fst $ foldl' addUsers ([], shuffledUsers) finalOccurrences
|
||||||
|
addUsers :: ([(UserId, Maybe ExamOccurrenceId)], [UserId])
|
||||||
|
-> (ExamOccurrenceId, Natural)
|
||||||
|
-> ([(UserId, Maybe ExamOccurrenceId)], [UserId])
|
||||||
|
addUsers (acc, userList) (roomId, roomSize) = (map (, Just roomId) newUsers ++ acc, remainingUsers)
|
||||||
|
where
|
||||||
|
newUsers, remainingUsers :: [UserId]
|
||||||
|
(newUsers, remainingUsers) = List.genericSplitAt roomSize userList
|
||||||
|
_ -> bimap (ExamOccurrenceMapping rule) (Map.unionWith (<|>) (view _2 <$> users)) . postprocess <$> bestOption
|
||||||
where
|
where
|
||||||
nullResult = (Nothing, view _2 <$> users)
|
|
||||||
usersCount :: forall a. Num a => a
|
usersCount :: forall a. Num a => a
|
||||||
usersCount = getSum $ foldMap (Sum . fromIntegral . Set.size) users'
|
usersCount = getSum $ foldMap (Sum . fromIntegral . Set.size) users'
|
||||||
|
|
||||||
@ -306,24 +347,35 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
|
|||||||
| (uid, (User{..}, Nothing)) <- Map.toList users
|
| (uid, (User{..}, Nothing)) <- Map.toList users
|
||||||
, matriculation' <- userMatrikelnummer ^.. _Just . filtered (not . null)
|
, matriculation' <- userMatrikelnummer ^.. _Just . filtered (not . null)
|
||||||
]
|
]
|
||||||
in Map.mapKeysWith Set.union (take . F.minimum . Set.map length $ Map.keysSet matrUsers) matrUsers
|
takeEnd n chars = drop (length chars - n) chars
|
||||||
_ -> Map.singleton [] $ Map.keysSet users
|
in Map.mapKeysWith Set.union (takeEnd . F.minimum . Set.map length $ Map.keysSet matrUsers) matrUsers
|
||||||
|
_ | null users-> Map.empty
|
||||||
|
| otherwise -> Map.singleton [] $ Map.keysSet users
|
||||||
|
|
||||||
|
occurrences' :: Map ExamOccurrenceId Natural
|
||||||
|
-- ^ reduce room capacity for every pre-assigned user by 1
|
||||||
|
-- also remove empty/pre-filled rooms
|
||||||
|
occurrences' = foldl' (flip $ Map.update predToPositive) (Map.filter (> 0) occurrences) $ Map.mapMaybe snd users
|
||||||
|
|
||||||
occurrences' :: [(ExamOccurrenceId, Natural)]
|
predToPositive :: Natural -> Maybe Natural
|
||||||
|
predToPositive 0 = Nothing
|
||||||
|
predToPositive 1 = Nothing
|
||||||
|
predToPositive n = Just $ pred n
|
||||||
|
|
||||||
|
occurrences'' :: [(ExamOccurrenceId, Natural)]
|
||||||
-- ^ Minimise number of occurrences used
|
-- ^ Minimise number of occurrences used
|
||||||
--
|
--
|
||||||
-- Prefer occurrences with higher capacity
|
-- Prefer occurrences with higher capacity
|
||||||
--
|
--
|
||||||
-- If a single occurrence can accomodate all participants, pick the one with
|
-- If a single occurrence can accommodate all participants, pick the one with
|
||||||
-- the least capacity
|
-- the least capacity
|
||||||
occurrences'
|
occurrences''
|
||||||
| not eaocMinimizeRooms
|
| not eaocMinimizeRooms
|
||||||
= Map.toList occurrences
|
= Map.toList occurrences'
|
||||||
| Just largeEnoughs <- fromNullable . filter ((>= usersCount) . view _2) $ Map.toList occurrences
|
| Just largeEnoughs <- fromNullable . filter ((>= usersCount) . view _2) $ Map.toList occurrences'
|
||||||
= pure $ minimumBy (comparing $ view _2) largeEnoughs
|
= pure $ minimumBy (comparing $ view _2) largeEnoughs
|
||||||
| otherwise
|
| otherwise
|
||||||
= view _2 . foldl' accF (0, []) . sortOn (Down . view _2) $ Map.toList occurrences
|
= view _2 . foldl' accF (0, []) . sortOn (Down . view _2) $ Map.toList occurrences'
|
||||||
where
|
where
|
||||||
accF :: (Natural, [(ExamOccurrenceId, Natural)])
|
accF :: (Natural, [(ExamOccurrenceId, Natural)])
|
||||||
-> (ExamOccurrenceId, Natural)
|
-> (ExamOccurrenceId, Natural)
|
||||||
@ -396,23 +448,31 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
|
|||||||
minima <- ST.newListArray (0, Map.size wordMap) $ 0 : repeat PosInf :: forall s. ST s (STArray s Int (Extended Rational))
|
minima <- ST.newListArray (0, Map.size wordMap) $ 0 : repeat PosInf :: forall s. ST s (STArray s Int (Extended Rational))
|
||||||
breaks <- ST.newArray (0, Map.size wordMap) 0 :: forall s. ST s (STUArray s Int Int)
|
breaks <- ST.newArray (0, Map.size wordMap) 0 :: forall s. ST s (STUArray s Int Int)
|
||||||
|
|
||||||
forM_ (Array.range (0, Map.size wordMap)) $ \i' -> do
|
-- find current line
|
||||||
let go i j
|
let
|
||||||
|
walkBack 0 = return 0
|
||||||
|
walkBack i'' = fmap succ $ walkBack =<< ST.readArray breaks i''
|
||||||
|
-- calculate line breaks
|
||||||
|
forM_ (Array.range (0, Map.size wordMap)) $ \i -> do
|
||||||
|
let go j
|
||||||
| j <= Map.size wordMap = do
|
| j <= Map.size wordMap = do
|
||||||
let
|
|
||||||
walkBack 0 = return 0
|
|
||||||
walkBack i'' = fmap succ $ walkBack =<< ST.readArray breaks i''
|
|
||||||
lineIx <- walkBack i
|
lineIx <- walkBack i
|
||||||
|
-- identifier and potential width of current line
|
||||||
let (l, potWidth)
|
let (l, potWidth)
|
||||||
| lineIx >= 0
|
| lineIx >= 0
|
||||||
, lineIx < length lineLengths
|
, lineIx < length lineLengths
|
||||||
= over _1 Just $ lineLengths List.!! lineIx
|
= over _1 Just $ lineLengths List.!! lineIx
|
||||||
| otherwise
|
| otherwise
|
||||||
= (Nothing, 0)
|
= (Nothing, 0)
|
||||||
|
-- cumulative width for words [i,j), no whitespace required
|
||||||
w = offsets Array.! j - offsets Array.! i
|
w = offsets Array.! j - offsets Array.! i
|
||||||
prevMin <- ST.readArray minima i
|
prevMin <- ST.readArray minima i
|
||||||
let cost = prevMin + widthCost l potWidth w + breakCost'
|
let cost = prevMin + widthCost l potWidth w + breakCost'
|
||||||
|
remainingWords = offsets Array.! Map.size wordMap - offsets Array.! i
|
||||||
|
remainingLineSpace = sumOf (folded . _2) $ drop lineIx lineLengths
|
||||||
breakCost'
|
breakCost'
|
||||||
|
| remainingWords > remainingLineSpace
|
||||||
|
= PosInf
|
||||||
| j < Map.size wordMap
|
| j < Map.size wordMap
|
||||||
, j > 0
|
, j > 0
|
||||||
= breakCost (wordIx # pred j) (wordIx # j)
|
= breakCost (wordIx # pred j) (wordIx # j)
|
||||||
@ -431,21 +491,22 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
|
|||||||
when (cost < minCost) $ do
|
when (cost < minCost) $ do
|
||||||
ST.writeArray minima j cost
|
ST.writeArray minima j cost
|
||||||
ST.writeArray breaks j i
|
ST.writeArray breaks j i
|
||||||
go i' $ succ j
|
go $ succ j
|
||||||
| otherwise = return ()
|
| otherwise = return ()
|
||||||
in go i' $ succ i'
|
in go $ succ i
|
||||||
-- traceM . show . map (fmap (fromRational :: Rational -> Centi)) =<< ST.getElems minima
|
-- traceM . show . map (fmap (fromRational :: Rational -> Centi)) =<< ST.getElems minima
|
||||||
-- traceM . show =<< ST.getElems breaks
|
-- traceM . show =<< ST.getElems breaks
|
||||||
|
|
||||||
|
usedLines <- walkBack $ Map.size wordMap
|
||||||
let accumResult lineIx j (accCost, accMap) = do
|
let accumResult lineIx j (accCost, accMap) = do
|
||||||
i <- ST.readArray breaks j
|
i <- ST.readArray breaks j
|
||||||
accCost' <- (+) accCost <$> ST.readArray minima j
|
accCost' <- (+) accCost <$> ST.readArray minima j
|
||||||
-- traceM $ show ((fromRational :: Rational -> Centi) <$> accCost', lineIx, (i, pred j))
|
-- traceM $ show ((fromRational :: Rational -> Centi) <$> accCost', lineIx, (i, pred j))
|
||||||
let accMap' = (lineIxs List.!! lineIx, map (review wordIx) [i .. pred j]) : accMap
|
let accMap' = (lineIxs List.!! lineIx, map (review wordIx) [i .. pred j]) : accMap
|
||||||
if
|
if i > 0
|
||||||
| i > 0 -> accumResult (succ lineIx) i (accCost', accMap')
|
then accumResult (succ lineIx) i (accCost', accMap')
|
||||||
| otherwise -> return (accCost', accMap')
|
else return (accCost', accMap')
|
||||||
lineIxs = reverse $ map (view _1) lineLengths
|
lineIxs = reverse $ map (view _1) $ take usedLines lineLengths
|
||||||
in accumResult 0 (Map.size wordMap) (0, [])
|
in accumResult 0 (Map.size wordMap) (0, [])
|
||||||
|
|
||||||
|
|
||||||
@ -460,7 +521,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
|
|||||||
charCost :: [CI Char] -> [CI Char] -> Extended Rational
|
charCost :: [CI Char] -> [CI Char] -> Extended Rational
|
||||||
charCost pA pB = Finite (max 1 $ List.genericLength (pA `lcp` pB) * eaocFinenessCost * fromIntegral longestLine) ^ 2
|
charCost pA pB = Finite (max 1 $ List.genericLength (pA `lcp` pB) * eaocFinenessCost * fromIntegral longestLine) ^ 2
|
||||||
where
|
where
|
||||||
longestLine = maximum . mapNonNull (view _2) $ impureNonNull occurrences'
|
longestLine = maximum . mapNonNull (view _2) $ impureNonNull occurrences''
|
||||||
|
|
||||||
|
|
||||||
lcp :: Eq a => [a] -> [a] -> [a]
|
lcp :: Eq a => [a] -> [a] -> [a]
|
||||||
@ -473,18 +534,18 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
|
|||||||
|
|
||||||
lineNudges = fromMaybe 0 . flip Map.lookup eaocNudge
|
lineNudges = fromMaybe 0 . flip Map.lookup eaocNudge
|
||||||
|
|
||||||
bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])]
|
bestOption :: Either ExamAutoOccurrenceException [(ExamOccurrenceId, [[CI Char]])]
|
||||||
bestOption = case rule of
|
bestOption = case rule of
|
||||||
ExamRoomSurname -> do
|
ExamRoomSurname -> maybeToRight ExamAutoOccurrenceExceptionRoomTooSmall $ do
|
||||||
(_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` (pack . toListOf (_1 . folded . to CI.foldedCase))) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' lineNudges charCost
|
(_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` (pack . toListOf (_1 . folded . to CI.foldedCase))) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences'' lineNudges charCost
|
||||||
-- traceM $ show cost
|
-- traceM $ show cost
|
||||||
return res
|
return res
|
||||||
ExamRoomMatriculation -> do
|
ExamRoomMatriculation -> maybeToRight ExamAutoOccurrenceExceptionRoomTooSmall $ do
|
||||||
let usersFineness n = Map.toAscList $ fromIntegral . Set.size <$> Map.mapKeysWith Set.union (reverse . take (fromIntegral n) . reverse) users'
|
let usersFineness n = Map.toAscList $ fromIntegral . Set.size <$> Map.mapKeysWith Set.union (reverse . take (fromIntegral n) . reverse) users'
|
||||||
-- finenessCost n = Finite (max 1 $ fromIntegral n * eaocFinenessCost * fromIntegral longestLine) ^ 2 * length occurrences'
|
-- finenessCost n = Finite (max 1 $ fromIntegral n * eaocFinenessCost * fromIntegral longestLine) ^ 2 * length occurrences'
|
||||||
|
|
||||||
distributeFine :: Natural -> Maybe (Extended Rational, _)
|
distributeFine :: Natural -> Maybe (Extended Rational, _)
|
||||||
distributeFine n = distribute (usersFineness n) occurrences' lineNudges charCost
|
distributeFine n = distribute (usersFineness n) occurrences'' lineNudges charCost
|
||||||
|
|
||||||
maximumFineness = fromIntegral . F.minimum . Set.map length $ Map.keysSet users'
|
maximumFineness = fromIntegral . F.minimum . Set.map length $ Map.keysSet users'
|
||||||
|
|
||||||
@ -510,7 +571,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
|
|||||||
|
|
||||||
(_cost, res) <- fmap (minimumBy . comparing $ view _1) . fromNullable $ genResults 1
|
(_cost, res) <- fmap (minimumBy . comparing $ view _1) . fromNullable $ genResults 1
|
||||||
return res
|
return res
|
||||||
_other -> Nothing
|
_other -> Left ExamAutoOccurrenceExceptionRuleNoOp
|
||||||
|
|
||||||
postprocess :: [(ExamOccurrenceId, [[CI Char]])]
|
postprocess :: [(ExamOccurrenceId, [[CI Char]])]
|
||||||
-> ( Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription)
|
-> ( Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription)
|
||||||
@ -518,63 +579,135 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
|
|||||||
)
|
)
|
||||||
postprocess result = (resultAscList, resultUsers)
|
postprocess result = (resultAscList, resultUsers)
|
||||||
where
|
where
|
||||||
resultAscList = pad . Map.fromListWith Set.union $ accRes (pure <$> Set.lookupMin rangeAlphabet) result
|
maxTagLength :: Int
|
||||||
where
|
maxTagLength = maybe 0 maximum $ fromNullable $ concatMap (map length . snd) result
|
||||||
accRes _ [] = []
|
|
||||||
accRes prevEnd ((occA, nsA) : (occB, nsB) : xs)
|
rangeAlphabet :: [CI Char]
|
||||||
| Just minA <- prevEnd <|> preview _head nsA
|
rangeAlphabet = case rule of
|
||||||
, Just maxA <- nsA ^? _last
|
ExamRoomSurname -> map CI.mk ['A'..'Z']
|
||||||
, Just minB <- nsB ^? _head
|
ExamRoomMatriculation-> map CI.mk ['0'..'9']
|
||||||
= let common = maxA `lcp` minB
|
_rule -> []
|
||||||
in if
|
|
||||||
| Just rmaxA <- nsA ^? to (filter . mayRange . succ $ length common) . _last
|
resultAscList :: Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription)
|
||||||
, Just rminA <- maybe id (:) prevEnd nsA ^? to (filter . mayRange . succ $ length common) . _head
|
resultAscList = case fromNullable rangeAlphabet of
|
||||||
, Just rminB <- nsB ^? to (filter . mayRange . succ $ length common) . _head
|
Nothing -> Map.empty
|
||||||
, firstA : _ <- CI.foldedCase <$> drop (length common) rmaxA
|
(Just alphabet) -> Map.fromList $ go (singleton $ head alphabet) 1 [] result
|
||||||
, firstB : _ <- CI.foldedCase <$> drop (length common) rminB
|
where
|
||||||
-> let break'
|
go :: NonNull [CI Char]
|
||||||
| occSize occA > 0 || occSize occB > 0
|
-> Int
|
||||||
= (occSize occA * Char.ord firstA + occSize occB * Char.ord firstB) % (occSize occA + occSize occB)
|
-> [(ExamOccurrenceId, Set ExamOccurrenceMappingDescription)]
|
||||||
& floor
|
-> [(ExamOccurrenceId, [[CI Char]])]
|
||||||
& Char.chr
|
-> [(ExamOccurrenceId, Set ExamOccurrenceMappingDescription)]
|
||||||
& Char.toUpper
|
go _start _borderLength acc [] = acc
|
||||||
& CI.mk
|
-- special case necessary, so ranges always end on last alphabet
|
||||||
& pure
|
go start _borderLength acc [(_occurrenceId, [])] = case acc of
|
||||||
& (common ++)
|
[] -> []
|
||||||
| otherwise = common ++ pure (CI.mk firstA)
|
((occurrenceId, mappingDescription):t) -> (occurrenceId, Set.map extendEnd mappingDescription) : t
|
||||||
succBreak = fmap reverse . go $ reverse break'
|
where
|
||||||
where
|
extendEnd :: ExamOccurrenceMappingDescription -> ExamOccurrenceMappingDescription
|
||||||
go [] = Nothing
|
extendEnd ExamOccurrenceMappingRange {eaomrStart} = ExamOccurrenceMappingRange {eaomrStart, eaomrEnd}
|
||||||
go (c:cs)
|
extendEnd examOccurrenceMappingSpecial = examOccurrenceMappingSpecial
|
||||||
| c' <- CI.map succ c
|
eaomrEnd :: [CI Char]
|
||||||
, c' `Set.member` rangeAlphabet
|
eaomrEnd = replicate (length start) $ last alphabet
|
||||||
= Just $ c' : cs
|
go start borderLength acc ((_occurrenceId, []):t) = go start borderLength acc t
|
||||||
| otherwise
|
go start borderLength acc ((occurrenceId, userTags):t)
|
||||||
= go cs
|
| matchMappingDescription mappingDescription userTags
|
||||||
commonLength = max 1 . succ . length $ minA `lcp` break'
|
&& (null t || toNullable nextStart > end)
|
||||||
isBreakSpecialStart c = not (mayRange (length rminA ) c) && length (rminA `lcp` c) >= pred (length rminA )
|
= go nextStart borderLength ((occurrenceId, mappingDescription) : acc) t
|
||||||
isBreakSpecialEnd c = not (mayRange (length break') c) && length (break' `lcp` c) >= pred (length break')
|
| borderLength < maxTagLength
|
||||||
rangeSpecials = Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsA
|
= go restartStart restartBorderLength [] result
|
||||||
breakSpecialsStart = Set.map (ExamOccurrenceMappingSpecial . take (length rminA)) . Set.filter isBreakSpecialStart $ Set.fromList nsA
|
|
||||||
breakSpecialsEnd = Set.map (ExamOccurrenceMappingSpecial . take (length break')) . Set.filter isBreakSpecialEnd $ Set.fromList nsA
|
|
||||||
in (occA, Set.insert (ExamOccurrenceMappingRange rminA break') $ breakSpecialsStart <> breakSpecialsEnd <> rangeSpecials) : accRes succBreak ((occB, nsB) : xs)
|
|
||||||
| otherwise
|
| otherwise
|
||||||
-> (occA, Set.map (ExamOccurrenceMappingSpecial . take (max 1 . max (succ $ length common) $ maybe 0 length prevEnd)) $ Set.fromList nsA) : accRes (Just $ take (succ $ length common) minB) ((occB, nsB) : xs)
|
= [] -- shouldn't happen, but ensures termination on invalid input (e.g. non-monotonic)
|
||||||
| null nsA
|
where
|
||||||
= accRes prevEnd $ (occB, nsB) : xs
|
restartBorderLength :: Int
|
||||||
| otherwise -- null nsB
|
restartBorderLength = succ borderLength
|
||||||
= accRes prevEnd $ (occA, nsA) : xs
|
|
||||||
accRes prevEnd [(occZ, nsZ)]
|
restartStart :: NonNull [CI Char]
|
||||||
| Just minAlpha <- Set.lookupMin rangeAlphabet
|
restartStart = case rule of
|
||||||
, Just maxAlpha <- Set.lookupMax rangeAlphabet
|
ExamRoomMatriculation -> impureNonNull $ replicate restartBorderLength $ head alphabet
|
||||||
, minZ <- fromMaybe (pure minAlpha) prevEnd
|
_rule -> singleton $ head alphabet
|
||||||
= let commonLength = max 1 . succ . length $ takeWhile (== maxAlpha) minZ
|
|
||||||
isBreakSpecial c = not (mayRange (length minZ) c) && length (minZ `lcp` c) >= pred (length minZ)
|
mappingDescription :: Set ExamOccurrenceMappingDescription
|
||||||
rangeSpecials = Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsZ
|
mappingDescription
|
||||||
breakSpecials = Set.map (ExamOccurrenceMappingSpecial . take (length minZ)) . Set.filter isBreakSpecial $ Set.fromList nsZ
|
-- if start > end, the room only consists of users with a non-ascii tag directly adjacent to the last room
|
||||||
in pure (occZ, Set.insert (ExamOccurrenceMappingRange minZ $ replicate commonLength maxAlpha) $ rangeSpecials <> breakSpecials)
|
-- therefore, leave out a potentially confusing range description
|
||||||
| otherwise
|
| toNullable start > end = Set.fromList specialMapping
|
||||||
= pure (occZ, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ maybe 0 length prevEnd)) $ Set.fromList nsZ)
|
| otherwise = Set.fromList $ ExamOccurrenceMappingRange (toNullable start) end : specialMapping
|
||||||
|
|
||||||
|
specialMapping :: [ExamOccurrenceMappingDescription]
|
||||||
|
specialMapping
|
||||||
|
= [ExamOccurrenceMappingSpecial {eaomrSpecial=tag}
|
||||||
|
| (transformTag borderLength -> tag) <- userTags
|
||||||
|
, not $ all (`elem` alphabet) tag]
|
||||||
|
|
||||||
|
-- | pre/suffix of largest user tag
|
||||||
|
-- special (i.e. non-ascii) tags use the largest smaller ascii-char according to RFC5051.compareUnicode,
|
||||||
|
-- ending the tag with ..ZZZ-padding
|
||||||
|
end :: [CI Char]
|
||||||
|
end = case t of
|
||||||
|
[] -> replicate borderLength $ last alphabet
|
||||||
|
_nonEmpty -> withAlphabetChars
|
||||||
|
$ transformTag borderLength
|
||||||
|
$ maximumBy (\a b -> RFC5051.compareUnicode (pack $ map CI.foldedCase a) (pack $ map CI.foldedCase b))
|
||||||
|
-- userTags is guaranteed non-null
|
||||||
|
$ impureNonNull userTags
|
||||||
|
where
|
||||||
|
withAlphabetChars :: [CI Char] -> [CI Char]
|
||||||
|
withAlphabetChars [] = []
|
||||||
|
withAlphabetChars (c:cs)
|
||||||
|
| c `elem` alphabet = c : withAlphabetChars cs
|
||||||
|
| otherwise= case previousAlphabetChar c of
|
||||||
|
Nothing -> []
|
||||||
|
(Just c') -> c' : replicate (length cs) (last alphabet)
|
||||||
|
previousAlphabetChar :: CI Char -> Maybe (CI Char)
|
||||||
|
previousAlphabetChar c = fmap last $ fromNullable $ nfilter ((== GT) . compareChars c) alphabet
|
||||||
|
compareChars :: CI Char -> CI Char -> Ordering
|
||||||
|
compareChars a b = RFC5051.compareUnicode (pack [CI.foldedCase a]) (pack [CI.foldedCase b])
|
||||||
|
nextStart :: NonNull [CI Char]
|
||||||
|
-- end is guaranteed nonNull, all empty tags are filtered out in users'
|
||||||
|
nextStart
|
||||||
|
| length end < borderLength
|
||||||
|
= impureNonNull $ end <> [head alphabet]
|
||||||
|
| otherwise
|
||||||
|
= impureNonNull $ reverse $ increase $ reverse end
|
||||||
|
alphabetCycle :: [CI Char]
|
||||||
|
alphabetCycle = List.cycle $ toNullable alphabet
|
||||||
|
increase :: [CI Char] -> [CI Char]
|
||||||
|
increase [] = []
|
||||||
|
increase (c:cs)
|
||||||
|
| nextChar == head alphabet, rule == ExamRoomMatriculation
|
||||||
|
= nextChar : increase cs
|
||||||
|
| nextChar == head alphabet
|
||||||
|
= increase cs
|
||||||
|
| otherwise
|
||||||
|
= nextChar : cs
|
||||||
|
where
|
||||||
|
nextChar :: CI Char
|
||||||
|
nextChar
|
||||||
|
| c `elem` alphabet
|
||||||
|
= dropWhile (/= c) alphabetCycle List.!! 1
|
||||||
|
| otherwise -- shouldn't happen, simply use head alphabet as a fallback
|
||||||
|
= head alphabet
|
||||||
|
|
||||||
|
transformTag :: Int -> [CI Char] -> [CI Char]
|
||||||
|
transformTag l tag = case rule of
|
||||||
|
ExamRoomMatriculation -> drop (max 0 $ length tag - l) tag
|
||||||
|
_rule -> take l tag
|
||||||
|
|
||||||
|
matchMappingDescription :: Set ExamOccurrenceMappingDescription -> [[CI Char]] -> Bool
|
||||||
|
matchMappingDescription mappingDescription userTags = flip all userTags $ \tag -> flip any mappingDescription $ \case
|
||||||
|
ExamOccurrenceMappingRange {eaomrStart, eaomrEnd}
|
||||||
|
-- non-rangeAlphabet-chars get a special mapping, so <= is fine here
|
||||||
|
-> (eaomrStart <= transformTag (length eaomrStart) tag) && (transformTag (length eaomrEnd) tag <= eaomrEnd)
|
||||||
|
ExamOccurrenceMappingSpecial {eaomrSpecial} -> checkSpecial eaomrSpecial tag
|
||||||
|
where
|
||||||
|
checkSpecial :: [CI Char] -> [CI Char] -> Bool
|
||||||
|
checkSpecial = case rule of
|
||||||
|
ExamRoomMatriculation -> isSuffixOf
|
||||||
|
_rule -> isPrefixOf
|
||||||
|
ExamOccurrenceMappingRandom -> False -- Something went wrong, throw an error instead?
|
||||||
|
|
||||||
|
resultUsers :: Map UserId (Maybe ExamOccurrenceId)
|
||||||
resultUsers = Map.fromList $ do
|
resultUsers = Map.fromList $ do
|
||||||
(occId, buckets) <- result
|
(occId, buckets) <- result
|
||||||
let matchWord b b' = case rule of
|
let matchWord b b' = case rule of
|
||||||
@ -585,30 +718,6 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
|
|||||||
user <- Set.toList $ foldMap (\b -> foldMap snd . filter (\(b', _) -> matchWord b b') $ Map.toList users') buckets
|
user <- Set.toList $ foldMap (\b -> foldMap snd . filter (\(b', _) -> matchWord b b') $ Map.toList users') buckets
|
||||||
return (user, Just occId)
|
return (user, Just occId)
|
||||||
|
|
||||||
occSize :: Num a => ExamOccurrenceId -> a
|
|
||||||
occSize occId = fromIntegral . length $ Map.filter (== Just occId) resultUsers
|
|
||||||
|
|
||||||
rangeAlphabet :: Set (CI Char)
|
|
||||||
rangeAlphabet
|
|
||||||
| ExamRoomSurname <- rule
|
|
||||||
= Set.fromList $ map CI.mk ['A'..'Z']
|
|
||||||
| ExamRoomMatriculation <- rule
|
|
||||||
= Set.fromList $ map CI.mk ['0'..'9']
|
|
||||||
| otherwise
|
|
||||||
= mempty
|
|
||||||
mayRange :: Int -> [CI Char] -> Bool
|
|
||||||
mayRange l = all (`Set.member` rangeAlphabet) . take l
|
|
||||||
|
|
||||||
pad :: Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription) -> Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription)
|
|
||||||
pad res
|
|
||||||
| ExamRoomMatriculation <- rule
|
|
||||||
, Just minAlpha <- Set.lookupMin rangeAlphabet
|
|
||||||
= let maxLength' = maybe 0 maximum . fromNullable $ res ^.. folded . folded . (_eaomrStart <> _eaomrEnd <> _eaomrSpecial) . to length
|
|
||||||
padSuff cs = replicate (maxLength' - length cs) minAlpha ++ cs
|
|
||||||
in Set.map (appEndo $ foldMap Endo [ over l padSuff | l <- [_eaomrStart, _eaomrEnd, _eaomrSpecial]]) <$> res
|
|
||||||
| otherwise
|
|
||||||
= res
|
|
||||||
|
|
||||||
|
|
||||||
deregisterExamUsersCount :: (MonadIO m, HandlerSite m ~ UniWorX, MonadHandler m, MonadCatch m) => ExamId -> [UserId] -> SqlPersistT m Int64
|
deregisterExamUsersCount :: (MonadIO m, HandlerSite m ~ UniWorX, MonadHandler m, MonadCatch m) => ExamId -> [UserId] -> SqlPersistT m Int64
|
||||||
deregisterExamUsersCount eId uids = do
|
deregisterExamUsersCount eId uids = do
|
||||||
|
|||||||
@ -29,21 +29,22 @@ makePrisms ''ChangelogItemKind
|
|||||||
|
|
||||||
classifyChangelogItem :: ChangelogItem -> ChangelogItemKind
|
classifyChangelogItem :: ChangelogItem -> ChangelogItemKind
|
||||||
classifyChangelogItem = \case
|
classifyChangelogItem = \case
|
||||||
ChangelogHaskellCampusLogin -> ChangelogItemBugfix
|
ChangelogHaskellCampusLogin -> ChangelogItemBugfix
|
||||||
ChangelogTooltipsWithoutJavascript -> ChangelogItemBugfix
|
ChangelogTooltipsWithoutJavascript -> ChangelogItemBugfix
|
||||||
ChangelogButtonsWorkWithoutJavascript -> ChangelogItemBugfix
|
ChangelogButtonsWorkWithoutJavascript -> ChangelogItemBugfix
|
||||||
ChangelogTableFormsWorkAfterAjax -> ChangelogItemBugfix
|
ChangelogTableFormsWorkAfterAjax -> ChangelogItemBugfix
|
||||||
ChangelogPassingByPointsWorks -> ChangelogItemBugfix
|
ChangelogPassingByPointsWorks -> ChangelogItemBugfix
|
||||||
ChangelogErrorMessagesForTableItemVanish -> ChangelogItemBugfix
|
ChangelogErrorMessagesForTableItemVanish -> ChangelogItemBugfix
|
||||||
ChangelogExamAchievementParticipantDuplication -> ChangelogItemBugfix
|
ChangelogExamAchievementParticipantDuplication -> ChangelogItemBugfix
|
||||||
ChangelogFormsTimesReset -> ChangelogItemBugfix
|
ChangelogFormsTimesReset -> ChangelogItemBugfix
|
||||||
ChangelogAllocationCourseAcceptSubstitutesFixed -> ChangelogItemBugfix
|
ChangelogAllocationCourseAcceptSubstitutesFixed -> ChangelogItemBugfix
|
||||||
ChangelogStoredMarkup -> ChangelogItemBugfix
|
ChangelogStoredMarkup -> ChangelogItemBugfix
|
||||||
ChangelogFixPersonalisedSheetFilesKeep -> ChangelogItemBugfix
|
ChangelogFixPersonalisedSheetFilesKeep -> ChangelogItemBugfix
|
||||||
ChangelogHonorRoomHidden -> ChangelogItemBugfix
|
ChangelogHonorRoomHidden -> ChangelogItemBugfix
|
||||||
ChangelogFixSheetBonusRounding -> ChangelogItemBugfix
|
ChangelogFixSheetBonusRounding -> ChangelogItemBugfix
|
||||||
ChangelogFixExamBonusAllSheetsBonus -> ChangelogItemBugfix
|
ChangelogFixExamBonusAllSheetsBonus -> ChangelogItemBugfix
|
||||||
_other -> ChangelogItemFeature
|
ChangelogExamAutomaticRoomDistributionRespectSize -> ChangelogItemBugfix
|
||||||
|
_other -> ChangelogItemFeature
|
||||||
|
|
||||||
changelogItemDays :: Map ChangelogItem Day
|
changelogItemDays :: Map ChangelogItem Day
|
||||||
changelogItemDays = Map.fromListWithKey (\k d1 d2 -> bool (error $ "Duplicate changelog days for " <> show k) d1 $ d1 /= d2)
|
changelogItemDays = Map.fromListWithKey (\k d1 d2 -> bool (error $ "Duplicate changelog days for " <> show k) d1 $ d1 /= d2)
|
||||||
|
|||||||
@ -191,6 +191,7 @@ examOccurrenceRuleAutomatic x = any ($ x)
|
|||||||
data ExamOccurrenceMappingDescription
|
data ExamOccurrenceMappingDescription
|
||||||
= ExamOccurrenceMappingRange { eaomrStart, eaomrEnd :: [CI Char] }
|
= ExamOccurrenceMappingRange { eaomrStart, eaomrEnd :: [CI Char] }
|
||||||
| ExamOccurrenceMappingSpecial { eaomrSpecial :: [CI Char] }
|
| ExamOccurrenceMappingSpecial { eaomrSpecial :: [CI Char] }
|
||||||
|
| ExamOccurrenceMappingRandom
|
||||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||||
deriveJSON defaultOptions
|
deriveJSON defaultOptions
|
||||||
{ fieldLabelModifier = camelToPathPiece' 1
|
{ fieldLabelModifier = camelToPathPiece' 1
|
||||||
|
|||||||
@ -0,0 +1,2 @@
|
|||||||
|
$newline never
|
||||||
|
Diverse Verbesserungen an der automatischen Zuteilung von Klausurteilnehmern auf Termine/Räume
|
||||||
@ -0,0 +1,2 @@
|
|||||||
|
$newline never
|
||||||
|
Several improvements for the automated distribution of exam participants to occurrences/rooms
|
||||||
@ -1,12 +1,11 @@
|
|||||||
$newline never
|
$newline never
|
||||||
<p>
|
<p>
|
||||||
Bei der Berechnung der Verteilung werden stets alle #
|
Bei der Berechnung der Verteilung werden nur neu zugewiesene #
|
||||||
Klausurteilnehmer berücksichtigt, unabhängig davon, ob ihnen bereits #
|
Klausurteilnehmer berücksichtigt.
|
||||||
ein Raum/Termin zugewiesen ist, oder nicht.
|
|
||||||
|
|
||||||
<br />
|
<br />
|
||||||
|
|
||||||
Es werden dennoch nur Klausurteilnehmer anhand der neu berechneten #
|
Es werden nur Klausurteilnehmer anhand der neu berechneten #
|
||||||
Verteilung zugewiesen, die aktuell keinen zugewiesenen Raum/Termin #
|
Verteilung zugewiesen, die aktuell keinen zugewiesenen Raum/Termin #
|
||||||
haben.
|
haben.
|
||||||
|
|
||||||
|
|||||||
@ -1,18 +1,17 @@
|
|||||||
$newline never
|
$newline never
|
||||||
<p>
|
<p>
|
||||||
When assignment rules are calculated all exam participants are #
|
When assignment rules are calculated only newly assigned #
|
||||||
considered, regardless of whether they are already assigned to an #
|
exam participants are considered.
|
||||||
occurrence/room.
|
|
||||||
|
|
||||||
<br />
|
<br />
|
||||||
|
|
||||||
Nonetheless only exam participants, who are not already assigned to #
|
Only exam participants, who are not already assigned to #
|
||||||
an occurrence/room, will be assigned according to the newly #
|
an occurrence/room, will be assigned according to the newly #
|
||||||
calculated assignment rules.
|
calculated assignment rules.
|
||||||
|
|
||||||
<br />
|
<br />
|
||||||
|
|
||||||
Thus calculating new assignment rules multiple times may lead to a #
|
Thus, calculating new assignment rules multiple times may lead to a #
|
||||||
situation in which the occurrence/room assignments of most #
|
situation in which the occurrence/room assignments of most #
|
||||||
participants do not match the newest assignment rules.
|
participants do not match the newest assignment rules.
|
||||||
|
|
||||||
|
|||||||
@ -29,3 +29,4 @@ $newline never
|
|||||||
<li>Steffen Jost
|
<li>Steffen Jost
|
||||||
<li>Gregor Kleen
|
<li>Gregor Kleen
|
||||||
<li>Sarah Vaupel
|
<li>Sarah Vaupel
|
||||||
|
<li>Wolfgang Witt
|
||||||
|
|||||||
@ -28,3 +28,4 @@ $newline never
|
|||||||
<li>Steffen Jost
|
<li>Steffen Jost
|
||||||
<li>Gregor Kleen
|
<li>Gregor Kleen
|
||||||
<li>Sarah Vaupel
|
<li>Sarah Vaupel
|
||||||
|
<li>Wolfgang Witt
|
||||||
|
|||||||
@ -13,3 +13,5 @@ $newline never
|
|||||||
#{titleCase special}…
|
#{titleCase special}…
|
||||||
$else
|
$else
|
||||||
…#{titleCase special}
|
…#{titleCase special}
|
||||||
|
$of ExamOccurrenceMappingRandom
|
||||||
|
_{MsgExamRoomMappingRandomHere}
|
||||||
|
|||||||
@ -6,16 +6,18 @@ $newline never
|
|||||||
_{MsgExamRoomName}
|
_{MsgExamRoomName}
|
||||||
<th .table__th colspan=2>
|
<th .table__th colspan=2>
|
||||||
_{MsgExamRoomLoad}
|
_{MsgExamRoomLoad}
|
||||||
$maybe rule <- occMappingRule
|
$case occMappingRule
|
||||||
$case rule
|
$of ExamRoomSurname
|
||||||
$of ExamRoomSurname
|
<th .table__th>
|
||||||
<th .table__th>
|
_{MsgExamRoomMappingSurname}
|
||||||
_{MsgExamRoomMappingSurname}
|
$of ExamRoomMatriculation
|
||||||
$of ExamRoomMatriculation
|
<th .table__th>
|
||||||
<th .table__th>
|
_{MsgExamRoomMappingMatriculation}
|
||||||
_{MsgExamRoomMappingMatriculation}
|
$of ExamRoomRandom
|
||||||
$of _
|
<th .table__th>
|
||||||
<th .table__td>
|
_{MsgExamRoomMappingRandom}
|
||||||
|
$of _
|
||||||
|
<th .table__td>
|
||||||
<th .table__th>
|
<th .table__th>
|
||||||
_{MsgExamRoom}
|
_{MsgExamRoom}
|
||||||
<th .table__th>
|
<th .table__th>
|
||||||
|
|||||||
374
test/Handler/Utils/ExamSpec.hs
Normal file
374
test/Handler/Utils/ExamSpec.hs
Normal file
@ -0,0 +1,374 @@
|
|||||||
|
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
|
||||||
|
|
||||||
|
module Handler.Utils.ExamSpec (spec) where
|
||||||
|
|
||||||
|
import TestImport
|
||||||
|
import Data.Universe (Universe, Finite, universeF)
|
||||||
|
|
||||||
|
import ModelSpec () -- instance Arbitrary User
|
||||||
|
|
||||||
|
import Test.Hspec.QuickCheck (prop)
|
||||||
|
import Test.HUnit.Lang (HUnitFailure(..), FailureReason(..))
|
||||||
|
|
||||||
|
import qualified Data.Map as Map
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
import qualified Data.Text as Text
|
||||||
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
import qualified Data.Foldable as Foldable
|
||||||
|
|
||||||
|
import qualified Data.RFC5051 as RFC5051
|
||||||
|
|
||||||
|
import Handler.Utils.Exam
|
||||||
|
|
||||||
|
|
||||||
|
-- direct copy&paste from an (currently) unmerged pull request for hspec-expectations
|
||||||
|
-- https://github.com/hspec/hspec-expectations/blob/6b4a475e42b0d44008c150727dea25dd79f568f2/src/Test/Hspec/Expectations.hs
|
||||||
|
-- |
|
||||||
|
-- If you have a test case that has multiple assertions, you can use the
|
||||||
|
-- 'annotate' function to provide a string message that will be attached to
|
||||||
|
-- the 'Expectation'.
|
||||||
|
--
|
||||||
|
-- @
|
||||||
|
-- describe "annotate" $ do
|
||||||
|
-- it "adds the message" $ do
|
||||||
|
-- annotate "obvious falsehood" $ do
|
||||||
|
-- True `shouldBe` False
|
||||||
|
--
|
||||||
|
-- ========>
|
||||||
|
--
|
||||||
|
-- 1) annotate, adds the message
|
||||||
|
-- obvious falsehood
|
||||||
|
-- expected: False
|
||||||
|
-- but got: True
|
||||||
|
-- @
|
||||||
|
myAnnotate :: HasCallStack => String -> Expectation -> Expectation
|
||||||
|
myAnnotate msg = handle $ \(HUnitFailure loc exn) ->
|
||||||
|
throwIO $ HUnitFailure loc $ case exn of
|
||||||
|
Reason str ->
|
||||||
|
Reason $ msg ++
|
||||||
|
if null str then str else ": " <> str
|
||||||
|
ExpectedButGot mmsg expected got ->
|
||||||
|
let
|
||||||
|
mmsg' =
|
||||||
|
Just $ msg <> maybe "" (": " <>) mmsg
|
||||||
|
in
|
||||||
|
ExpectedButGot mmsg' expected got
|
||||||
|
|
||||||
|
|
||||||
|
instance Arbitrary ExamOccurrence where
|
||||||
|
arbitrary = ExamOccurrence
|
||||||
|
<$> arbitrary -- examOccurrenceExam
|
||||||
|
<*> arbitrary -- examOccurrenceName
|
||||||
|
<*> arbitrary -- examOccurrenceRoom
|
||||||
|
<*> arbitrary -- examOccurrenceRoomHidden
|
||||||
|
<*> frequency [(let d = fromIntegral i in ceiling $ 100 * exp(- d*d / 50), pure i) | i <- [10 ..1000]] -- examOccurrenceCapacity
|
||||||
|
<*> arbitrary -- examOccurrenceStart
|
||||||
|
<*> arbitrary -- examOccurrenceEnd
|
||||||
|
<*> arbitrary -- examOccurrenceDescription
|
||||||
|
|
||||||
|
|
||||||
|
data Preselection = NoPreselection | SomePreselection
|
||||||
|
deriving stock (Show, Bounded, Enum)
|
||||||
|
deriving anyclass (Universe, Finite)
|
||||||
|
|
||||||
|
data Nudges = NoNudges | SmallNudges | LargeNudges
|
||||||
|
deriving stock (Show, Bounded, Enum)
|
||||||
|
deriving anyclass (Universe, Finite)
|
||||||
|
|
||||||
|
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)
|
||||||
|
newtype UserProperties = UserProperties {user :: User}
|
||||||
|
|
||||||
|
instance Show UserProperties where
|
||||||
|
--show :: UserProperties -> String
|
||||||
|
show UserProperties {user=User {userSurname, userMatrikelnummer}}
|
||||||
|
= "User {userSurname=" ++ show userSurname
|
||||||
|
++ ", userMatrikelnummer=" ++ show userMatrikelnummer ++ "}"
|
||||||
|
|
||||||
|
-- function Handler.Utils.examAutoOccurrence
|
||||||
|
spec :: Spec
|
||||||
|
spec = do
|
||||||
|
describe "examAutoOccurrence" $ do
|
||||||
|
describe "Surname" $ testWithRule ExamRoomSurname
|
||||||
|
describe "Matriculation" $ testWithRule ExamRoomMatriculation
|
||||||
|
describe "Random" $ testWithRule ExamRoomRandom
|
||||||
|
where
|
||||||
|
testWithRule :: ExamOccurrenceRule -> Spec
|
||||||
|
testWithRule rule =
|
||||||
|
forM_ universeF $ \nudges -> describe (show nudges) $
|
||||||
|
forM_ universeF $ \preselection ->
|
||||||
|
prop (show preselection) $ propertyTest rule nudges preselection
|
||||||
|
seed :: ()
|
||||||
|
seed = ()
|
||||||
|
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}
|
||||||
|
autoOccurrenceResult = examAutoOccurrence seed rule config occurrences users
|
||||||
|
pure $ ioProperty $ do
|
||||||
|
let userProperties :: Map UserId (UserProperties, Maybe ExamOccurrenceId)
|
||||||
|
userProperties = Map.map (first UserProperties) users
|
||||||
|
case autoOccurrenceResult of
|
||||||
|
(Right (occurrenceMapping, userMap)) -> do
|
||||||
|
-- user count stays constant
|
||||||
|
myAnnotate "number of users changed" $ shouldBe (length userMap) (length users)
|
||||||
|
-- no room is overfull
|
||||||
|
myAnnotate "room capacity exceeded" $ shouldSatisfy (userProperties, occurrences, userMap) $ uncurry3 fitsInRooms
|
||||||
|
-- mapping is a valid description
|
||||||
|
myAnnotate "invalid mapping description" $ shouldSatisfy (rule, occurrenceMapping) $ uncurry validRangeDescription
|
||||||
|
-- every (relevant) user got assigned a room
|
||||||
|
let foldFn :: (UserId, Maybe ExamOccurrenceId) -> Bool -> Bool
|
||||||
|
foldFn _userMapping False = False
|
||||||
|
foldFn (_userId, Just _occurrenceId) True = True
|
||||||
|
foldFn (userId, Nothing) True
|
||||||
|
= (rule == ExamRoomMatriculation)
|
||||||
|
-- every user with a userMatrikelnummer got a room
|
||||||
|
-- fail on unknown user
|
||||||
|
|| maybe False (isNothing . userMatrikelnummer . fst) (Map.lookup userId users)
|
||||||
|
myAnnotate "user didn't get a room" $ shouldSatisfy userMap $ foldr foldFn True . Map.toList
|
||||||
|
-- all users match the shown ranges
|
||||||
|
myAnnotate "shown ranges don't match userMap"
|
||||||
|
$ shouldSatisfy (rule, userProperties, occurrenceMapping, userMap) $ uncurry4 showsCorrectRanges
|
||||||
|
-- is a nullResult justified?
|
||||||
|
(Left autoOccurrenceException) ->
|
||||||
|
-- disabled for now, probably not correct with the current implementation
|
||||||
|
myAnnotate "unjustified nullResult"
|
||||||
|
$ shouldSatisfy (autoOccurrenceException, rule, userProperties, occurrences) $ uncurry4 isNullResultJustified
|
||||||
|
-- | generate users without any pre-assigned rooms
|
||||||
|
genUsersWithOccurrences :: Preselection -> Gen (Map UserId (User, Maybe ExamOccurrenceId), Map ExamOccurrenceId Natural)
|
||||||
|
genUsersWithOccurrences preselection = do
|
||||||
|
rawUsers <- scale (50 *) $ listOf $ 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
|
||||||
|
-- extra space to allow nice borders
|
||||||
|
extraSpace <- elements [numUsers `div` 5 .. numUsers `div` 2]
|
||||||
|
let totalSpaceRequirement = fromIntegral $ numUsers + extraSpace
|
||||||
|
createOccurrences acc
|
||||||
|
| sum (map snd acc) < totalSpaceRequirement = do
|
||||||
|
Entity {entityKey, entityVal} <- Entity <$> arbitrary <*> arbitrary
|
||||||
|
createOccurrences $ (entityKey, fromIntegral $ 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", "zu Allen", "Fu"
|
||||||
|
, "Meier", "Meyer", "Maier", "Mayer"
|
||||||
|
, "Meir", "Müller", "Schulze", "Schmitt"
|
||||||
|
, "FTB Modul", "Mártinèz", "zu Walker", "Schmidt"
|
||||||
|
, "Únîcòdé", "Ähm-Ümlaüte", "von Leerzeichen"
|
||||||
|
]
|
||||||
|
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 UserId (UserProperties, Maybe ExamOccurrenceId)
|
||||||
|
-> Map ExamOccurrenceId Natural
|
||||||
|
-> Map UserId (Maybe ExamOccurrenceId)
|
||||||
|
-> Bool
|
||||||
|
fitsInRooms userProperties 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
|
||||||
|
|| all (isJust . snd) (Map.restrictKeys userProperties $ Set.fromList userIds)
|
||||||
|
-- | No range overlap for different rooms + end is always the greater value
|
||||||
|
validRangeDescription :: ExamOccurrenceRule -> ExamOccurrenceMapping ExamOccurrenceId -> Bool
|
||||||
|
validRangeDescription rule ExamOccurrenceMapping {examOccurrenceMappingMapping}
|
||||||
|
= all (\(roomId, ranges) -> all (descriptionValid roomId) ranges) $ Map.toAscList examOccurrenceMappingMapping
|
||||||
|
where
|
||||||
|
descriptionValid:: ExamOccurrenceId -> ExamOccurrenceMappingDescription -> Bool
|
||||||
|
descriptionValid roomId description
|
||||||
|
= endAfterStart description
|
||||||
|
&& all (all $ noDirectOverlap description) (Map.delete roomId examOccurrenceMappingMapping)
|
||||||
|
endAfterStart :: ExamOccurrenceMappingDescription -> Bool
|
||||||
|
endAfterStart
|
||||||
|
ExamOccurrenceMappingRange {eaomrStart=(pack . map CI.foldedCase -> start), eaomrEnd=(pack . map CI.foldedCase -> end)}
|
||||||
|
= RFC5051.compareUnicode start end /= GT
|
||||||
|
endAfterStart _mappingDescription = True
|
||||||
|
-- also check for equal length with ExamRoomMatriculation
|
||||||
|
noDirectOverlap :: ExamOccurrenceMappingDescription -> ExamOccurrenceMappingDescription -> Bool
|
||||||
|
noDirectOverlap ExamOccurrenceMappingRandom other = other == ExamOccurrenceMappingRandom
|
||||||
|
noDirectOverlap other ExamOccurrenceMappingRandom = other == ExamOccurrenceMappingRandom
|
||||||
|
noDirectOverlap
|
||||||
|
ExamOccurrenceMappingRange {eaomrStart=cs0@(pack . map CI.foldedCase -> s0), eaomrEnd=ce0@(pack . map CI.foldedCase -> e0)}
|
||||||
|
ExamOccurrenceMappingRange {eaomrStart=cs1@(pack . map CI.foldedCase -> s1), eaomrEnd=ce1@(pack . map CI.foldedCase -> e1)}
|
||||||
|
= equalLengthForMatriculation [cs0, ce0, cs1, ce1]
|
||||||
|
&& ((RFC5051.compareUnicode s0 s1 == LT && RFC5051.compareUnicode e0 s1 == LT)
|
||||||
|
|| (RFC5051.compareUnicode s0 e1 == GT && RFC5051.compareUnicode e0 s1 == GT))
|
||||||
|
noDirectOverlap
|
||||||
|
ExamOccurrenceMappingRange {eaomrStart, eaomrEnd}
|
||||||
|
ExamOccurrenceMappingSpecial {eaomrSpecial}
|
||||||
|
= equalLengthForMatriculation [eaomrStart, eaomrEnd, eaomrSpecial]
|
||||||
|
&& noDirectOverlapRangeSpecial eaomrStart eaomrEnd eaomrSpecial
|
||||||
|
noDirectOverlap
|
||||||
|
ExamOccurrenceMappingSpecial {eaomrSpecial}
|
||||||
|
ExamOccurrenceMappingRange {eaomrStart, eaomrEnd}
|
||||||
|
= equalLengthForMatriculation [eaomrStart, eaomrEnd, eaomrSpecial]
|
||||||
|
&& noDirectOverlapRangeSpecial eaomrStart eaomrEnd eaomrSpecial
|
||||||
|
noDirectOverlap ExamOccurrenceMappingSpecial {eaomrSpecial=s0} ExamOccurrenceMappingSpecial {eaomrSpecial=s1}
|
||||||
|
= equalLengthForMatriculation [s0, s1] && s0 /= s1
|
||||||
|
equalLengthForMatriculation :: [[CI Char]] -> Bool
|
||||||
|
equalLengthForMatriculation [] = True
|
||||||
|
equalLengthForMatriculation (h:t) = (rule /= ExamRoomMatriculation) || all (== length h) (length <$> t)
|
||||||
|
noDirectOverlapRangeSpecial :: [CI Char] -> [CI Char] -> [CI Char] -> Bool
|
||||||
|
noDirectOverlapRangeSpecial
|
||||||
|
(pack . map CI.foldedCase -> start)
|
||||||
|
(pack . map CI.foldedCase -> end)
|
||||||
|
(pack . map CI.foldedCase -> special)
|
||||||
|
= RFC5051.compareUnicode special start == LT || RFC5051.compareUnicode special end == GT
|
||||||
|
-- RFC5051.compareUnicode :: Text -> Text -> Ordering
|
||||||
|
-- | 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 :: ExamOccurrenceRule
|
||||||
|
-> Map UserId (UserProperties, Maybe ExamOccurrenceId)
|
||||||
|
-> ExamOccurrenceMapping ExamOccurrenceId
|
||||||
|
-> Map UserId (Maybe ExamOccurrenceId)
|
||||||
|
-> Bool
|
||||||
|
showsCorrectRanges rule userProperties ExamOccurrenceMapping {examOccurrenceMappingMapping} userMap
|
||||||
|
= all userFitsInRange $ Map.toAscList $ occurrenceMap userMap
|
||||||
|
where
|
||||||
|
userFitsInRange :: (ExamOccurrenceId, [UserId]) -> Bool
|
||||||
|
userFitsInRange (roomId, userIds) = flip all userIds $ \userId ->
|
||||||
|
case (Map.lookup roomId examOccurrenceMappingMapping, Map.lookup userId userProperties) of
|
||||||
|
(_maybeRanges, Just (_userProperty, Just fixedRoomId))
|
||||||
|
-> roomId == fixedRoomId
|
||||||
|
(Just ranges, Just (UserProperties User {userSurname, userMatrikelnummer}, Nothing))
|
||||||
|
-> any fitsInRange ranges
|
||||||
|
where
|
||||||
|
ciTag :: Maybe [CI Char]
|
||||||
|
ciTag = map CI.mk . Text.unpack <$> case rule of
|
||||||
|
ExamRoomSurname
|
||||||
|
| Text.null userSurname -> Nothing
|
||||||
|
| otherwise-> Just userSurname
|
||||||
|
ExamRoomMatriculation
|
||||||
|
| maybe True Text.null userMatrikelnummer -> Nothing
|
||||||
|
| otherwise -> userMatrikelnummer
|
||||||
|
_rule -> Nothing
|
||||||
|
fitsInRange :: ExamOccurrenceMappingDescription -> Bool
|
||||||
|
fitsInRange mappingDescription = case (ciTag, mappingDescription) of
|
||||||
|
(_tag, ExamOccurrenceMappingRandom) -> True
|
||||||
|
(Nothing, _mappingDescription) -> True
|
||||||
|
(Just tag, ExamOccurrenceMappingRange {eaomrStart=(pack . map CI.foldedCase -> start), eaomrEnd=(pack . map CI.foldedCase-> end)})
|
||||||
|
-> (RFC5051.compareUnicode start (pack $ map CI.foldedCase $ transformTag start tag) /= GT)
|
||||||
|
&& (RFC5051.compareUnicode end (pack $ map CI.foldedCase $ transformTag end tag) /= LT)
|
||||||
|
(Just tag, ExamOccurrenceMappingSpecial {eaomrSpecial})
|
||||||
|
-> checkSpecial eaomrSpecial tag
|
||||||
|
transformTag :: (MonoFoldable f) => f -> [CI Char] -> [CI Char]
|
||||||
|
transformTag (length -> rangeLength) = case rule of
|
||||||
|
ExamRoomMatriculation -> reverse . take rangeLength . reverse
|
||||||
|
_rule -> take rangeLength
|
||||||
|
checkSpecial :: [CI Char] -> [CI Char] -> Bool
|
||||||
|
checkSpecial = case rule of
|
||||||
|
ExamRoomMatriculation -> isSuffixOf
|
||||||
|
_rule -> isPrefixOf
|
||||||
|
_otherwise -> (rule /= ExamRoomSurname) && (rule /= ExamRoomMatriculation)
|
||||||
|
-- | Is mapping impossible due to the given reason?
|
||||||
|
isNullResultJustified :: ExamAutoOccurrenceException
|
||||||
|
-> ExamOccurrenceRule
|
||||||
|
-> Map UserId (UserProperties, Maybe ExamOccurrenceId)
|
||||||
|
-> Map ExamOccurrenceId Natural -> Bool
|
||||||
|
isNullResultJustified ExamAutoOccurrenceExceptionRuleNoOp rule _userProperties _occurrences
|
||||||
|
= not $ examOccurrenceRuleAutomatic rule
|
||||||
|
isNullResultJustified ExamAutoOccurrenceExceptionNotEnoughSpace rule userProperties occurrences
|
||||||
|
= fromIntegral (length $ relevantUsers rule userProperties) > sum occurrences
|
||||||
|
isNullResultJustified ExamAutoOccurrenceExceptionNoUsers rule userProperties _occurrences
|
||||||
|
= noRelevantUsers rule userProperties
|
||||||
|
isNullResultJustified ExamAutoOccurrenceExceptionRoomTooSmall rule userProperties occurrences
|
||||||
|
= mappingImpossiblePlausible rule userProperties occurrences
|
||||||
|
noRelevantUsers :: ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Bool
|
||||||
|
noRelevantUsers rule = null . relevantUsers rule
|
||||||
|
relevantUsers :: ExamOccurrenceRule
|
||||||
|
-> Map UserId (UserProperties, Maybe ExamOccurrenceId)
|
||||||
|
-> Map UserId (UserProperties, Maybe ExamOccurrenceId)
|
||||||
|
relevantUsers rule = Map.filter $ isRelevantUser rule
|
||||||
|
isRelevantUser :: ExamOccurrenceRule -> (UserProperties, Maybe ExamOccurrenceId) -> Bool
|
||||||
|
isRelevantUser _rule (_user, Just _assignedRoom) = False
|
||||||
|
isRelevantUser rule (UserProperties User {userSurname, userMatrikelnummer}, Nothing) = case rule of
|
||||||
|
ExamRoomSurname -> not $ null userSurname
|
||||||
|
ExamRoomMatriculation -> maybe False (not . null) userMatrikelnummer
|
||||||
|
ExamRoomRandom -> True
|
||||||
|
_rule -> False
|
||||||
|
mappingImpossiblePlausible :: ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map ExamOccurrenceId Natural -> Bool
|
||||||
|
mappingImpossiblePlausible
|
||||||
|
rule
|
||||||
|
userProperties@(sortBy RFC5051.compareUnicode . mapRuleProperty rule . Map.elems . relevantUsers rule -> users')
|
||||||
|
(map snd . Map.toList . adjustOccurrences userProperties -> occurrences') = go 0 users' occurrences'
|
||||||
|
where
|
||||||
|
smallestRoom :: Natural
|
||||||
|
smallestRoom = maybe 0 minimum $ fromNullable occurrences'
|
||||||
|
-- If there exists a bucket with the same tag bigger than the smallest room a nullResult might be returned
|
||||||
|
-- It may still work, but is not guaranteed (e.g. both the first bucket)
|
||||||
|
go :: forall a. Eq a => Natural -> [a] -> [Natural] -> Bool
|
||||||
|
go biggestUserBucket [] _occurrences = biggestUserBucket > smallestRoom
|
||||||
|
go _biggestUserBucket _remainingUsers [] = True
|
||||||
|
go biggestUserBucket remainingUsers (0:t) = go biggestUserBucket remainingUsers t
|
||||||
|
go biggestUserBucket remainingUsers@(h:_t) (firstOccurrence:laterOccurrences)
|
||||||
|
| nextUsers <= firstOccurrence
|
||||||
|
= go (max biggestUserBucket nextUsers) remainingUsers' $ firstOccurrence - nextUsers : laterOccurrences
|
||||||
|
| otherwise
|
||||||
|
= go biggestUserBucket remainingUsers laterOccurrences
|
||||||
|
where
|
||||||
|
nextUsers :: Natural
|
||||||
|
remainingUsers' :: [a]
|
||||||
|
(fromIntegral . length -> nextUsers, remainingUsers') = span (== h) remainingUsers
|
||||||
|
mapRuleProperty :: ExamOccurrenceRule -> [(UserProperties, b)] -> [Text]
|
||||||
|
mapRuleProperty rule (map fst -> users') = map (ruleProperty rule minMatrLength) users'
|
||||||
|
where
|
||||||
|
minMatrLength :: Int
|
||||||
|
minMatrLength = Foldable.minimum $ map (maybe 0 Text.length . userMatrikelnummer . user) users'
|
||||||
|
ruleProperty :: ExamOccurrenceRule -> Int -> UserProperties -> Text
|
||||||
|
ruleProperty rule n = case rule of
|
||||||
|
ExamRoomSurname -> userSurname . user
|
||||||
|
ExamRoomMatriculation -> maybe Text.empty (Text.takeEnd n) . userMatrikelnummer . user
|
||||||
|
_rule -> const $ pack $ show rule
|
||||||
|
-- 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) (Map.filter (> 0) occurrences) $ Map.mapMaybe snd userProperties
|
||||||
|
predToPositive :: Natural -> Maybe Natural
|
||||||
|
predToPositive 0 = Nothing
|
||||||
|
predToPositive 1 = Nothing
|
||||||
|
predToPositive n = Just $ pred n
|
||||||
Reference in New Issue
Block a user