feat(exam): start work on automatic exam-occurrence assignment
This commit is contained in:
Gregor Kleen
Gregor Kleen
parent
a7b7bdbea7
commit
282df86bc2
@ -3,9 +3,10 @@ module Handler.Utils.Exam
|
||||
, fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam
|
||||
, examBonus, examBonusPossible, examBonusAchieved
|
||||
, examResultBonus, examGrade
|
||||
, examAutoOccurrence
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
import Import.NoFoundation hiding (distribute)
|
||||
|
||||
import Database.Persist.Sql (SqlBackendCanRead)
|
||||
import qualified Database.Esqueleto as E
|
||||
@ -16,8 +17,16 @@ import Database.Esqueleto.Utils.TH
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Data.Fixed (Fixed(..))
|
||||
import qualified Data.Foldable as F
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Control.Monad.Trans.Random.Lazy (evalRand)
|
||||
import System.Random (mkStdGen)
|
||||
import Control.Monad.Random.Class (uniform)
|
||||
|
||||
|
||||
fetchExamAux :: ( SqlBackendCanRead backend
|
||||
@ -161,3 +170,149 @@ examGrade Exam{..} mBonus (otoList -> results)
|
||||
lowerBounds :: [(ExamGrade, Points)]
|
||||
lowerBounds = zip [Grade40, Grade37 ..] examGradingKey'
|
||||
|
||||
|
||||
examAutoOccurrence :: forall seed.
|
||||
Hashable seed
|
||||
=> seed
|
||||
-> ExamOccurrenceRule
|
||||
-> Map ExamOccurrenceId Natural
|
||||
-> Map UserId (User, Maybe ExamOccurrenceId)
|
||||
-> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId))
|
||||
examAutoOccurrence (hash -> seed) rule occurrences users
|
||||
| sum occurrences < fromIntegral (Map.size users)
|
||||
|| Map.null users
|
||||
= nullResult
|
||||
| otherwise
|
||||
= case rule of
|
||||
ExamRoomRandom
|
||||
-> ( Nothing
|
||||
, flip Map.mapWithKey users $ \uid (_, mOcc)
|
||||
-> let randomOcc = flip evalRand (mkStdGen $ hashWithSalt seed uid) $
|
||||
uniform $ Map.keysSet occurrences
|
||||
in Just $ fromMaybe randomOcc mOcc
|
||||
)
|
||||
_ | Just (postprocess -> (resMapping, result)) <- bestOption
|
||||
-> ( Just $ ExamOccurrenceMapping rule resMapping
|
||||
, Map.unionWith (<|>) (view _2 <$> users) result
|
||||
)
|
||||
_ -> nullResult
|
||||
where
|
||||
nullResult = (Nothing, view _2 <$> users)
|
||||
|
||||
users' :: Map [CI Char] (Set UserId)
|
||||
-- ^ Finest partition of users
|
||||
users' = case rule of
|
||||
ExamRoomSurname
|
||||
-> Map.fromListWith Set.union
|
||||
[ (map CI.mk $ unpack userSurname, Set.singleton uid)
|
||||
| (uid, (User{..}, Nothing)) <- Map.toList users
|
||||
, not $ null userSurname
|
||||
]
|
||||
ExamRoomMatriculation
|
||||
-> let matrUsers
|
||||
= Map.fromListWith Set.union
|
||||
[ (map CI.mk . reverse $ unpack matriculation, Set.singleton uid)
|
||||
| (uid, (User{..}, Nothing)) <- Map.toList users
|
||||
, let Just matriculation = userMatrikelnummer
|
||||
, not $ null matriculation
|
||||
]
|
||||
in Map.mapKeysWith Set.union (take . F.minimum . Set.map length $ Map.keysSet matrUsers) matrUsers
|
||||
_ -> Map.singleton [] $ Map.keysSet users
|
||||
|
||||
usersGroups :: Natural -- ^ fineness
|
||||
-> Map [CI Char] (Set UserId)
|
||||
-- ^ Partition users into monotonously finer partitions
|
||||
usersGroups (fromIntegral -> c) = Map.mapKeysWith Set.union (take c) users'
|
||||
|
||||
maximumFineness :: Natural
|
||||
-- ^ Fineness at which `usersGroups` becomes constant
|
||||
maximumFineness = fromIntegral . F.maximum . Set.map length $ Map.keysSet users'
|
||||
|
||||
occurrences' :: [(ExamOccurrenceId, Natural)]
|
||||
-- ^ Minimise number of occurrences used
|
||||
--
|
||||
-- Prefer occurrences with higher capacity
|
||||
--
|
||||
-- If a single occurrence can accomodate all participants, pick the one with
|
||||
-- the least capacity
|
||||
occurrences'
|
||||
| Just largeEnoughs <- fromNullable . filter ((>= usersCount) . view _2) $ Map.toList occurrences
|
||||
= pure $ minimumBy (comparing $ view _2) largeEnoughs
|
||||
| otherwise
|
||||
= view _2 . foldr accF (0, []) . sortOn (Down . view _2) $ Map.toList occurrences
|
||||
where
|
||||
usersCount = fromIntegral $ Map.size users
|
||||
|
||||
accF :: (ExamOccurrenceId, Natural)
|
||||
-> (Natural, [(ExamOccurrenceId, Natural)])
|
||||
-> (Natural, [(ExamOccurrenceId, Natural)])
|
||||
accF occ@(_, occSize) acc@(accSize, accOccs)
|
||||
| accSize >= usersCount
|
||||
= acc
|
||||
| otherwise
|
||||
= ( accSize + occSize
|
||||
, accOccs ++ [occ]
|
||||
)
|
||||
|
||||
largestOccurrence :: Num a => a
|
||||
largestOccurrence = fromIntegral . maximum . mapNonNull (view _2) $ impureNonNull occurrences'
|
||||
|
||||
finenessCost :: Natural -> Natural
|
||||
finenessCost x = round (finenessConst * largestOccurrence) * fromIntegral (length occurrences') * x * x
|
||||
where
|
||||
finenessConst :: Rational
|
||||
-- ^ Cost (scaled to proportion of occurrence) of having higher fineness
|
||||
finenessConst = 1 % 20 -- TODO: tweak
|
||||
|
||||
|
||||
distribute :: forall wordId lineId cost.
|
||||
( Num cost
|
||||
, Ord wordId, Ord lineId
|
||||
)
|
||||
=> [(wordId, Natural)]
|
||||
-> [(lineId, Natural)]
|
||||
-> Maybe (cost, Map lineId (Set wordId))
|
||||
-- ^ Distribute the given items (@wordId@s) with associated size in
|
||||
-- contiguous blocks into the given buckets (@lineId@s) such that they are
|
||||
-- filled as evenly as possible (proportionally)
|
||||
--
|
||||
-- Return a cost scaled to item-size squared
|
||||
--
|
||||
-- See <https://xxyxyz.org/line-breaking/> under \"Shortest Path\"
|
||||
distribute wordLengths lineLengths
|
||||
| null wordLengths = Just (0, Map.empty)
|
||||
| null lineLengths = Nothing
|
||||
| otherwise = Just distribute'
|
||||
where
|
||||
_longestLine :: cost
|
||||
-- ^ For scaling costs
|
||||
_longestLine = fromIntegral . maximum . mapNonNull (view _2) $ impureNonNull lineLengths
|
||||
|
||||
distribute' = error "not implemented" -- TODO: implement
|
||||
|
||||
|
||||
options :: [(Natural, (Natural, Map ExamOccurrenceId (Set [CI Char])))]
|
||||
options = do
|
||||
fineness <- [0..maximumFineness]
|
||||
let
|
||||
packets :: [([CI Char], Natural)]
|
||||
packets = Map.toAscList . fmap (fromIntegral . Set.size) $ usersGroups fineness
|
||||
(resultCost, result) <- hoistMaybe $ distribute packets occurrences'
|
||||
return (fineness, (resultCost, result))
|
||||
bestOption :: Maybe (Map ExamOccurrenceId (Set [CI Char]))
|
||||
bestOption = options
|
||||
& takeWhile (\(fineness, (resCost, _)) -> finenessCost fineness < resCost)
|
||||
& map (view $ _2 . _2)
|
||||
& fmap last . fromNullable
|
||||
|
||||
postprocess :: Map ExamOccurrenceId (Set [CI Char])
|
||||
-> ( [(ExamOccurrenceId, [CI Char])]
|
||||
, Map UserId (Maybe ExamOccurrenceId)
|
||||
)
|
||||
postprocess result = (resultAscList, resultUsers)
|
||||
where
|
||||
resultAscList = sortOn (view _2) . map (over _2 Set.findMax) $ Map.toList result
|
||||
resultUsers = Map.fromList $ do
|
||||
(occId, buckets) <- Map.toList result
|
||||
user <- Set.toList $ foldMap (flip (Map.findWithDefault Set.empty) users') buckets
|
||||
return (user, Just occId)
|
||||
|
||||
@ -11,6 +11,7 @@ module Model.Types.Exam
|
||||
, _examResult
|
||||
, ExamBonusRule(..)
|
||||
, ExamOccurrenceRule(..)
|
||||
, ExamOccurrenceMapping(..)
|
||||
, ExamGrade(..)
|
||||
, numberGrade
|
||||
, ExamGradeDefCenter(..)
|
||||
@ -152,6 +153,18 @@ deriveJSON defaultOptions
|
||||
} ''ExamOccurrenceRule
|
||||
derivePersistFieldJSON ''ExamOccurrenceRule
|
||||
|
||||
data ExamOccurrenceMapping roomId = ExamOccurrenceMapping
|
||||
{ examOccurrenceMappingRule :: ExamOccurrenceRule
|
||||
, examOccurrenceMappingMapping :: [(roomId, [CI Char])]
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 3
|
||||
, constructorTagModifier = camelToPathPiece' 1
|
||||
, tagSingleConstructors = False
|
||||
} ''ExamOccurrenceMapping
|
||||
derivePersistFieldJSON ''ExamOccurrenceMapping
|
||||
|
||||
|
||||
data ExamGrade
|
||||
= Grade50
|
||||
| Grade40
|
||||
|
||||
Loading…
Reference in New Issue
Block a user