715 lines
35 KiB
Haskell
715 lines
35 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
|
|
|
|
module Handler.Utils.Exam
|
|
( fetchExamAux
|
|
, fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam
|
|
, examBonus, examBonusPossible, examBonusAchieved
|
|
, examResultBonus, examGrade
|
|
, getRelevantSheetsUpTo, examBonusGrade
|
|
, ExamAutoOccurrenceConfig
|
|
, eaocMinimizeRooms, eaocFinenessCost, eaocNudge, eaocNudgeSize
|
|
, _eaocMinimizeRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize
|
|
, examAutoOccurrence
|
|
, deregisterExamUsersCount, deregisterExamUsers
|
|
, examAidsPresetWidget, examOnlinePresetWidget, examSynchronicityPresetWidget, examRequiredEquipmentPresetWidget
|
|
, evalExamModeDNF
|
|
, showExamOccurrenceRoom
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Database.Persist.Sql (SqlBackendCanRead)
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import qualified Database.Esqueleto.Internal.Internal as E
|
|
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 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 (weighted)
|
|
import Control.Monad.ST (ST, runST)
|
|
|
|
import Data.Array (Array)
|
|
import qualified Data.Array as Array
|
|
|
|
import Data.Array.ST (STArray, STUArray)
|
|
import qualified Data.Array.ST as ST
|
|
|
|
import Data.List (findIndex, unfoldr)
|
|
import qualified Data.List as List
|
|
|
|
import Data.ExtendedReal
|
|
|
|
import qualified Data.Char as Char
|
|
|
|
import qualified Data.RFC5051 as RFC5051
|
|
|
|
import Handler.Utils.I18n
|
|
import Handler.Utils.Sheet
|
|
|
|
|
|
fetchExamAux :: ( SqlBackendCanRead backend
|
|
, E.SqlSelect b a
|
|
, MonadHandler m
|
|
, Typeable a
|
|
)
|
|
=> (E.SqlExpr (Entity Exam) -> E.SqlExpr (Entity Course) -> b)
|
|
-> TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT backend m a
|
|
fetchExamAux prj tid ssh csh examn =
|
|
let cachId = encodeUtf8 $ tshow (tid, ssh, csh, examn)
|
|
in cachedBy cachId $ do
|
|
tutList <- E.select . E.from $ \(course `E.InnerJoin` tut) -> do
|
|
E.on $ course E.^. CourseId E.==. tut E.^. ExamCourse
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.&&. tut E.^. ExamName E.==. E.val examn
|
|
return $ prj tut course
|
|
case tutList of
|
|
[tut] -> return tut
|
|
_other -> notFound
|
|
|
|
fetchExam :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Entity Exam)
|
|
fetchExam = fetchExamAux const
|
|
|
|
fetchExamId :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Exam)
|
|
fetchExamId tid ssh cid examn = E.unValue <$> fetchExamAux (\tutorial _ -> tutorial E.^. ExamId) tid ssh cid examn
|
|
|
|
fetchCourseIdExamId :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Course, Key Exam)
|
|
fetchCourseIdExamId tid ssh cid examn = $(unValueN 2) <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial E.^. ExamId)) tid ssh cid examn
|
|
|
|
fetchCourseIdExam :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Course, Entity Exam)
|
|
fetchCourseIdExam tid ssh cid examn = over _1 E.unValue <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial)) tid ssh cid examn
|
|
|
|
|
|
examBonus :: (MonadHandler m, MonadThrow m) => Entity Exam -> ReaderT SqlBackend m (Map UserId (SheetTypeSummary ExamPartId))
|
|
examBonus (Entity eId Exam{..}) = runConduit $
|
|
let
|
|
rawData = E.selectSource . E.from $ \(((examRegistration `E.LeftOuterJoin` examOccurrence) `E.InnerJoin` sheet) `E.LeftOuterJoin` submission) -> E.distinctOnOrderBy [ E.asc $ examRegistration E.^. ExamRegistrationUser, E.asc $ sheet E.^. SheetId ] $ do
|
|
E.on $ submission E.?. SubmissionSheet E.==. E.just (sheet E.^. SheetId)
|
|
E.&&. E.exists (E.from $ \submissionUser -> E.where_ $ submissionUser E.^. SubmissionUserUser E.==. examRegistration E.^. ExamRegistrationUser
|
|
E.&&. E.just (submissionUser E.^. SubmissionUserSubmission) E.==. submission E.?. SubmissionId
|
|
)
|
|
E.on E.true
|
|
E.on $ examRegistration E.^. ExamRegistrationOccurrence E.==. examOccurrence E.?. ExamOccurrenceId
|
|
E.where_ $ sheet E.^. SheetCourse E.==. E.val examCourse
|
|
E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val eId
|
|
E.where_ $ E.case_
|
|
[ E.when_
|
|
( E.not_ . E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence )
|
|
E.then_
|
|
( E.maybe E.true ((E.<=. examOccurrence E.?. ExamOccurrenceStart) . E.just) (sheet E.^. SheetActiveTo)
|
|
E.&&. sheet E.^. SheetVisibleFrom E.<=. examOccurrence E.?. ExamOccurrenceStart
|
|
)
|
|
]
|
|
( E.else_ . E.not_ . E.isNothing $ sheet E.^. SheetVisibleFrom
|
|
)
|
|
return (examRegistration E.^. ExamRegistrationUser, sheet E.^. SheetType, submission, sheet E.^. SheetCourse)
|
|
accum = C.foldM ?? Map.empty $ \acc (E.Value uid, E.Value sheetType, fmap entityVal -> sub, E.Value cId) -> do
|
|
sheetType' <- fmap entityKey <$> resolveSheetType cId sheetType
|
|
return . flip (Map.insertWith mappend uid) acc . sheetTypeSum sheetType' $ assertM submissionRatingDone sub >>= submissionRatingPoints
|
|
in rawData .| accum
|
|
|
|
examBonusPossible, examBonusAchieved :: Ord epId => UserId -> Map UserId (SheetTypeSummary epId) -> SheetGradeSummary
|
|
examBonusPossible uid bonusMap = normalSummary $ Map.findWithDefault mempty uid bonusMap
|
|
examBonusAchieved uid bonusMap = mappend <$> normalSummary <*> bonusSummary $ Map.findWithDefault mempty uid bonusMap
|
|
|
|
getRelevantSheetsUpTo :: CourseId
|
|
-> UserId
|
|
-> Maybe UTCTime
|
|
-> DB (Map SheetId (SheetType SqlBackendKey, Maybe Points))
|
|
getRelevantSheetsUpTo cid uid mCutoff
|
|
= fmap postprocess . E.select . E.from $ \(sheet `E.LeftOuterJoin` submission) -> E.distinctOnOrderBy [ E.asc $ sheet E.^. SheetId ] $ do
|
|
E.on $ submission E.?. SubmissionSheet E.==. E.just (sheet E.^. SheetId)
|
|
E.&&. E.exists (E.from $ \submissionUser -> E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
|
|
E.&&. E.just (submissionUser E.^. SubmissionUserSubmission) E.==. submission E.?. SubmissionId
|
|
)
|
|
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
|
case mCutoff of
|
|
Just cutoff -> E.where_ $ E.maybe E.true (E.<=. E.val cutoff) (sheet E.^. SheetActiveTo)
|
|
E.&&. E.maybe E.false (E.<=. E.val cutoff) (sheet E.^. SheetVisibleFrom)
|
|
Nothing -> E.where_ . E.not_ . E.isNothing $ sheet E.^. SheetVisibleFrom
|
|
return (sheet E.^. SheetId, sheet E.^. SheetType, submission)
|
|
where
|
|
postprocess :: [(E.Value SheetId, E.Value (SheetType SqlBackendKey), Maybe (Entity Submission))]
|
|
-> Map SheetId (SheetType SqlBackendKey, Maybe Points)
|
|
postprocess = Map.fromList . map postprocess'
|
|
where postprocess' (E.Value sId, E.Value sType, fmap entityVal -> sub)
|
|
= (sId, ) . (sType, ) $ assertM submissionRatingDone sub >>= submissionRatingPoints
|
|
|
|
|
|
|
|
|
|
examResultBonus :: ExamBonusRule
|
|
-> SheetGradeSummary -- ^ `examBonusPossible`
|
|
-> SheetGradeSummary -- ^ `examBonusAchieved`
|
|
-> Maybe Points
|
|
examResultBonus bonusRule bonusPossible bonusAchieved = case bonusRule of
|
|
ExamBonusManual{}
|
|
-> Nothing
|
|
ExamBonusPoints{..}
|
|
-> Just . roundToPoints' bonusRound $ toRational bonusMaxPoints * bonusProp bonusMaxPoints
|
|
where
|
|
bonusProp :: Points -> Rational
|
|
bonusProp mPoints
|
|
| possible <= 0 = 1
|
|
| otherwise = achieved / possible
|
|
where
|
|
achieved = toRational (getSum $ achievedPoints bonusAchieved - achievedPassPoints bonusAchieved) + scalePasses (getSum $ achievedPasses bonusAchieved)
|
|
possible = toRational (getSum $ sumSheetsPoints bonusPossible - sumSheetsPassPoints bonusPossible) + scalePasses (getSum $ numSheetsPasses bonusPossible)
|
|
|
|
scalePasses :: Integer -> Rational
|
|
-- ^ Rescale passes so count of all sheets with pass is worth as many points as sum of all sheets with points
|
|
scalePasses passes
|
|
| pointsPossible <= 0, passesPossible <= 0 = 1 -- This arbitrarily identifies a pass as being worth one point if all sheets are `Bonus`; maybe weird
|
|
| pointsPossible <= 0 = toRational mPoints / fromInteger passesPossible
|
|
| passesPossible <= 0 = 0
|
|
| otherwise = fromInteger passes / fromInteger passesPossible * toRational pointsPossible
|
|
where
|
|
passesPossible = getSum $ numSheetsPasses bonusPossible
|
|
pointsPossible = getSum $ sumSheetsPoints bonusPossible - sumSheetsPassPoints bonusPossible
|
|
|
|
roundToPoints' mult = (* mult) . (realToFrac :: Uni -> Points) . roundToPoints . (/ toRational mult)
|
|
|
|
examGrade :: ( MonoFoldable mono
|
|
, Element mono ~ ExamResultPoints
|
|
)
|
|
=> Exam
|
|
-> Maybe Points -- ^ Bonus
|
|
-> mono -- ^ `ExamPartResult`s
|
|
-> Maybe ExamResultGrade
|
|
examGrade Exam{..} mBonus (otoList -> results)
|
|
= traverse pointsToGrade achievedPoints'
|
|
where
|
|
achievedPoints' :: ExamResultPoints
|
|
achievedPoints' = withBonus . getSum <$> foldMap (fmap Sum) results
|
|
|
|
withBonus :: Points -> Points
|
|
withBonus ps
|
|
| Just bonusRule <- examBonusRule
|
|
= if
|
|
| maybe True not (bonusRule ^? _bonusOnlyPassed)
|
|
|| fmap (view passingGrade) (pointsToGrade ps) == Just (_Wrapped # True)
|
|
-> maybe id (+) mBonus ps
|
|
| otherwise
|
|
-> ps
|
|
| otherwise
|
|
= ps
|
|
|
|
pointsToGrade :: Points -> Maybe ExamGrade
|
|
pointsToGrade ps = examGradingRule <&> \case
|
|
ExamGradingKey{..}
|
|
-> gradeFromKey examGradingKey
|
|
where
|
|
gradeFromKey :: [Points] -> ExamGrade
|
|
gradeFromKey examGradingKey' = maximum $ Grade50 `ncons` [ g | (g, b) <- lowerBounds, b <= ps ]
|
|
where
|
|
lowerBounds :: [(ExamGrade, Points)]
|
|
lowerBounds = zip [Grade40, Grade37 ..] examGradingKey'
|
|
|
|
examBonusGrade :: ( MonoFoldable sheets
|
|
, Element sheets ~ (SheetType epId, Maybe Points)
|
|
, MonoFoldable results
|
|
, Element results ~ ExamResultPoints
|
|
, Ord epId
|
|
)
|
|
=> Exam
|
|
-> Either Points sheets -- ^ `Points` retrieved from relevant `ExamBonus`, iff it exists
|
|
-> results
|
|
-> (Maybe Points, Maybe ExamResultGrade)
|
|
examBonusGrade exam@Exam{..} bonusInp = (mBonus, ) . examGrade exam mBonus
|
|
where mBonus = asum
|
|
[ bonusInp ^? _Left
|
|
, join $ examResultBonus <$> examBonusRule <*> bonusPossible <*> bonusAchieved
|
|
]
|
|
sheetSummary = flip (previews _Right) bonusInp . ofoldMap $ uncurry sheetTypeSum
|
|
bonusPossible = normalSummary <$> sheetSummary
|
|
bonusAchieved = (<>) <$> fmap normalSummary sheetSummary <*> fmap bonusSummary sheetSummary
|
|
|
|
|
|
data ExamAutoOccurrenceConfig = ExamAutoOccurrenceConfig
|
|
{ eaocMinimizeRooms :: Bool
|
|
, eaocFinenessCost :: Rational -- ^ Cost factor incentivising shorter common prefixes on breaks between rooms
|
|
, eaocNudge :: Map ExamOccurrenceId Integer
|
|
, eaocNudgeSize :: Rational
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
instance Default ExamAutoOccurrenceConfig where
|
|
def = ExamAutoOccurrenceConfig
|
|
{ eaocMinimizeRooms = False
|
|
, eaocFinenessCost = 0.2
|
|
, eaocNudge = Map.empty
|
|
, eaocNudgeSize = 0.05
|
|
}
|
|
|
|
makeLenses_ ''ExamAutoOccurrenceConfig
|
|
|
|
deriveJSON defaultOptions
|
|
{ fieldLabelModifier = camelToPathPiece' 1
|
|
} ''ExamAutoOccurrenceConfig
|
|
|
|
|
|
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
|
|
| sum occurrences' < usersCount
|
|
|| sum occurrences' <= 0
|
|
|| Map.null users
|
|
= nullResult
|
|
| otherwise
|
|
= case rule of
|
|
ExamRoomRandom
|
|
-> ( Nothing
|
|
, flip Map.mapWithKey users $ \uid (_, mOcc)
|
|
-> let randomOcc = flip evalRand (mkStdGen $ hashWithSalt seed uid) $
|
|
weighted $ over _2 fromIntegral <$> 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)
|
|
usersCount :: forall a. Num a => a
|
|
usersCount = getSum $ foldMap (Sum . fromIntegral . Set.size) 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 $ unpack matriculation', Set.singleton uid)
|
|
| (uid, (User{..}, Nothing)) <- Map.toList users
|
|
, matriculation' <- userMatrikelnummer ^.. _Just . filtered (not . null)
|
|
]
|
|
in Map.mapKeysWith Set.union (take . F.minimum . Set.map length $ Map.keysSet matrUsers) matrUsers
|
|
_ -> Map.singleton [] $ Map.keysSet users
|
|
|
|
occurrences' :: Map ExamOccurrenceId Natural
|
|
-- ^ reduce room capacity for every pre-assigned user by 1
|
|
occurrences' = foldl' (flip $ Map.update predToPositive) occurrences $ Map.mapMaybe snd users
|
|
-- FIXME what about capacity-0 in occurrences?
|
|
-- what if the first word is too big for the first room?
|
|
where
|
|
predToPositive :: Natural -> Maybe Natural
|
|
predToPositive 0 = Nothing
|
|
predToPositive 1 = Nothing
|
|
predToPositive n = Just $ pred n
|
|
|
|
occurrences'' :: [(ExamOccurrenceId, Natural)]
|
|
-- ^ Minimise number of occurrences used
|
|
--
|
|
-- Prefer occurrences with higher capacity
|
|
--
|
|
-- If a single occurrence can accommodate all participants, pick the one with
|
|
-- the least capacity
|
|
occurrences''
|
|
| not eaocMinimizeRooms
|
|
= Map.toList occurrences'
|
|
| Just largeEnoughs <- fromNullable . filter ((>= usersCount) . view _2) $ Map.toList occurrences'
|
|
= pure $ minimumBy (comparing $ view _2) largeEnoughs
|
|
| otherwise
|
|
= view _2 . foldl' accF (0, []) . sortOn (Down . view _2) $ Map.toList occurrences'
|
|
where
|
|
accF :: (Natural, [(ExamOccurrenceId, Natural)])
|
|
-> (ExamOccurrenceId, Natural)
|
|
-> (Natural, [(ExamOccurrenceId, Natural)])
|
|
accF acc@(accSize, accOccs) occ@(_, occSize)
|
|
| accSize >= usersCount
|
|
= acc
|
|
| otherwise
|
|
= ( accSize + occSize
|
|
, occ : accOccs
|
|
)
|
|
|
|
distribute :: forall wordId lineId cost.
|
|
_
|
|
=> [(wordId, Natural)] -- ^ Word sizes (in order)
|
|
-> [(lineId, Natural)] -- ^ Line sizes (in order)
|
|
-> (lineId -> Integer) -- ^ Nudge
|
|
-> (wordId -> wordId -> Extended Rational) -- ^ Break cost
|
|
-> Maybe (cost, [(lineId, [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 lineNudge breakCost
|
|
| null wordLengths = Just (0, [ (l, []) | (l, _) <- lineLengths ])
|
|
| null lineLengths = Nothing
|
|
| otherwise = let (cost, result) = distribute'
|
|
in case cost of
|
|
Finite c -> Just (fromInteger $ round c, result)
|
|
_other -> Nothing
|
|
where
|
|
longestLine :: Natural
|
|
-- ^ For scaling costs
|
|
longestLine = maximum . mapNonNull (view _2) $ impureNonNull lineLengths
|
|
|
|
wordMap :: Map wordId Natural
|
|
wordMap = Map.fromListWith (+) wordLengths
|
|
|
|
wordIx :: Iso' wordId Int
|
|
wordIx = iso (\wId -> let Just ix' = elemIndex wId $ Array.elems collapsedWords
|
|
in ix'
|
|
)
|
|
(collapsedWords Array.!)
|
|
|
|
collapsedWords :: Array Int wordId
|
|
collapsedWords = Array.array
|
|
(0, pred $ Map.size wordMap)
|
|
[ (ix', wId)
|
|
| wId <- Map.keys wordMap
|
|
, let Just ix' = findIndex ((== wId) . view _1) wordLengths
|
|
]
|
|
|
|
offsets :: Array Int Natural
|
|
offsets = Array.listArray bounds $ unfoldr (uncurry accOffsets) (0, 0)
|
|
where
|
|
accOffsets :: Natural -> Int -> Maybe (Natural, (Natural, Int))
|
|
accOffsets accSize ix'
|
|
| ix' <= 0 = Just (0, (0, 1))
|
|
| Array.inRange bounds ix' = let newSize = accSize + wordMap Map.! (wordIx # pred ix')
|
|
in Just (newSize, (newSize, succ ix'))
|
|
| otherwise = Nothing
|
|
|
|
bounds = (0, Map.size wordMap)
|
|
|
|
distribute' :: (Extended Rational, [(lineId, [wordId])])
|
|
distribute' = runST $ do
|
|
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)
|
|
|
|
-- find current line
|
|
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
|
|
lineIx <- walkBack i
|
|
-- identifier and potential width of current line
|
|
let (l, potWidth)
|
|
| lineIx >= 0
|
|
, lineIx < length lineLengths
|
|
= over _1 Just $ lineLengths List.!! lineIx
|
|
| otherwise
|
|
= (Nothing, 0)
|
|
-- cumulative width for words [i,j), no whitespace required
|
|
w = offsets Array.! j - offsets Array.! i
|
|
prevMin <- ST.readArray minima i
|
|
let cost = prevMin + widthCost l potWidth w + breakCost'
|
|
remainingWords = offsets Array.! Map.size wordMap - offsets Array.! i
|
|
remainingLineSpace = sum (map snd $ drop lineIx lineLengths)
|
|
breakCost'
|
|
| remainingWords > remainingLineSpace
|
|
= PosInf
|
|
| j < Map.size wordMap
|
|
, j > 0
|
|
= breakCost (wordIx # pred j) (wordIx # j)
|
|
| otherwise
|
|
= 0
|
|
-- traceM $ show ( i
|
|
-- , j
|
|
-- , potWidth
|
|
-- , w
|
|
-- , (fromRational :: Rational -> Centi) <$> prevMin
|
|
-- , (fromRational :: Rational -> Centi) <$> widthCost potWidth w
|
|
-- , (fromRational :: Rational -> Centi) <$> breakCost'
|
|
-- )
|
|
when (isFinite cost) $ do
|
|
minCost <- ST.readArray minima j
|
|
when (cost < minCost) $ do
|
|
ST.writeArray minima j cost
|
|
ST.writeArray breaks j i
|
|
go $ succ j
|
|
| otherwise = return ()
|
|
in go $ succ i
|
|
-- traceM . show . map (fmap (fromRational :: Rational -> Centi)) =<< ST.getElems minima
|
|
-- traceM . show =<< ST.getElems breaks
|
|
|
|
usedLines <- walkBack $ Map.size wordMap
|
|
let accumResult lineIx j (accCost, accMap) = do
|
|
i <- ST.readArray breaks j
|
|
accCost' <- (+) accCost <$> ST.readArray minima j
|
|
-- traceM $ show ((fromRational :: Rational -> Centi) <$> accCost', lineIx, (i, pred j))
|
|
let accMap' = (lineIxs List.!! lineIx, map (review wordIx) [i .. pred j]) : accMap
|
|
if
|
|
| i > 0 -> accumResult (succ lineIx) i (accCost', accMap')
|
|
| otherwise -> return (accCost', accMap')
|
|
lineIxs = reverse $ map (view _1) $ take usedLines lineLengths
|
|
in accumResult 0 (Map.size wordMap) (0, [])
|
|
|
|
|
|
widthCost :: Maybe lineId -> Natural -> Natural -> Extended Rational
|
|
widthCost l lineWidth w
|
|
| lineWidth < w = PosInf
|
|
| otherwise = Finite (max 1 . abs $ ((fromIntegral w % fromIntegral lineWidth) - optimumRatio') * fromIntegral longestLine) ^ 2
|
|
where
|
|
optimumRatio = ((%) `on` fromIntegral . sum) (map (view _2) wordLengths) (map (view _2) lineLengths)
|
|
optimumRatio' = maybe 0 (fromIntegral . lineNudge) l * eaocNudgeSize + optimumRatio
|
|
|
|
charCost :: [CI Char] -> [CI Char] -> Extended Rational
|
|
charCost pA pB = Finite (max 1 $ List.genericLength (pA `lcp` pB) * eaocFinenessCost * fromIntegral longestLine) ^ 2
|
|
where
|
|
longestLine = maximum . mapNonNull (view _2) $ impureNonNull occurrences''
|
|
|
|
|
|
lcp :: Eq a => [a] -> [a] -> [a]
|
|
-- ^ Longest common prefix
|
|
lcp [] _ = []
|
|
lcp _ [] = []
|
|
lcp (a:as) (b:bs)
|
|
| a == b = a:lcp as bs
|
|
| otherwise = []
|
|
|
|
lineNudges = fromMaybe 0 . flip Map.lookup eaocNudge
|
|
|
|
bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])]
|
|
bestOption = case rule of
|
|
ExamRoomSurname -> do
|
|
(_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
|
|
return res
|
|
ExamRoomMatriculation -> do
|
|
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'
|
|
|
|
distributeFine :: Natural -> Maybe (Extended Rational, _)
|
|
distributeFine n = distribute (usersFineness n) occurrences'' lineNudges charCost
|
|
|
|
maximumFineness = fromIntegral . F.minimum . Set.map length $ Map.keysSet users'
|
|
|
|
resultFineness :: [(ExamOccurrenceId, [[CI Char]])] -> Natural
|
|
resultFineness (map (view _2) -> res)
|
|
| Just res' <- fromNullable res
|
|
= maybe 0 maximum . fromNullable $ zipWith transFineness res (tail res')
|
|
| otherwise = 0
|
|
where
|
|
transFineness :: [[CI Char]] -> [[CI Char]] -> Natural
|
|
transFineness nsA nsB
|
|
| Just maxA <- nsA ^? _last
|
|
, Just minB <- nsB ^? _head
|
|
= succ . List.genericLength $ maxA `lcp` minB
|
|
| otherwise
|
|
= 0
|
|
|
|
genResults f
|
|
| f > maximumFineness = []
|
|
| otherwise =
|
|
let mRes = distributeFine f
|
|
in (mRes ^.. _Just) ++ bool [] (genResults $ succ f) (maybe True (>= f) $ mRes ^? _Just . _2 . to resultFineness)
|
|
|
|
(_cost, res) <- fmap (minimumBy . comparing $ view _1) . fromNullable $ genResults 1
|
|
return res
|
|
_other -> Nothing
|
|
|
|
postprocess :: [(ExamOccurrenceId, [[CI Char]])]
|
|
-> ( Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription)
|
|
, Map UserId (Maybe ExamOccurrenceId)
|
|
)
|
|
postprocess result = (resultAscList, resultUsers)
|
|
where
|
|
resultAscList = pad . Map.fromListWith Set.union $ accRes (pure <$> Set.lookupMin rangeAlphabet) result
|
|
where
|
|
accRes _ [] = []
|
|
accRes prevEnd ((occA, nsA) : (occB, nsB) : xs)
|
|
| Just minA <- prevEnd <|> preview _head nsA
|
|
, Just maxA <- nsA ^? _last
|
|
, Just minB <- nsB ^? _head
|
|
= let common = maxA `lcp` minB
|
|
in if
|
|
| Just rmaxA <- nsA ^? to (filter . mayRange . succ $ length common) . _last
|
|
, Just rminA <- maybe id (:) prevEnd nsA ^? to (filter . mayRange . succ $ length common) . _head
|
|
, Just rminB <- nsB ^? to (filter . mayRange . succ $ length common) . _head
|
|
, firstA : _ <- CI.foldedCase <$> drop (length common) rmaxA
|
|
, firstB : _ <- CI.foldedCase <$> drop (length common) rminB
|
|
-> let break'
|
|
| occSize occA > 0 || occSize occB > 0
|
|
= (occSize occA * Char.ord firstA + occSize occB * Char.ord firstB) % (occSize occA + occSize occB)
|
|
& floor
|
|
& Char.chr
|
|
& Char.toUpper
|
|
& CI.mk
|
|
& pure
|
|
& (common ++)
|
|
| otherwise = common ++ pure (CI.mk firstA)
|
|
succBreak = fmap reverse . go $ reverse break'
|
|
where
|
|
go [] = Nothing
|
|
go (c:cs)
|
|
| c' <- CI.map succ c
|
|
, c' `Set.member` rangeAlphabet
|
|
= Just $ c' : cs
|
|
| otherwise
|
|
= go cs
|
|
commonLength = max 1 . succ . length $ minA `lcp` break'
|
|
isBreakSpecialStart c = not (mayRange (length rminA ) c) && length (rminA `lcp` c) >= pred (length rminA )
|
|
isBreakSpecialEnd c = not (mayRange (length break') c) && length (break' `lcp` c) >= pred (length break')
|
|
rangeSpecials = Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsA
|
|
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
|
|
-> (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)
|
|
| null nsA
|
|
= accRes prevEnd $ (occB, nsB) : xs
|
|
| otherwise -- null nsB
|
|
= accRes prevEnd $ (occA, nsA) : xs
|
|
accRes prevEnd [(occZ, nsZ)]
|
|
| Just minAlpha <- Set.lookupMin rangeAlphabet
|
|
, Just maxAlpha <- Set.lookupMax rangeAlphabet
|
|
, minZ <- fromMaybe (pure minAlpha) prevEnd
|
|
= let commonLength = max 1 . succ . length $ takeWhile (== maxAlpha) minZ
|
|
isBreakSpecial c = not (mayRange (length minZ) c) && length (minZ `lcp` c) >= pred (length minZ)
|
|
rangeSpecials = Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsZ
|
|
breakSpecials = Set.map (ExamOccurrenceMappingSpecial . take (length minZ)) . Set.filter isBreakSpecial $ Set.fromList nsZ
|
|
in pure (occZ, Set.insert (ExamOccurrenceMappingRange minZ $ replicate commonLength maxAlpha) $ rangeSpecials <> breakSpecials)
|
|
| otherwise
|
|
= pure (occZ, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ maybe 0 length prevEnd)) $ Set.fromList nsZ)
|
|
resultUsers = Map.fromList $ do
|
|
(occId, buckets) <- result
|
|
let matchWord b b' = case rule of
|
|
ExamRoomMatriculation
|
|
-> b `isSuffixOf` b'
|
|
_other
|
|
-> b == b'
|
|
user <- Set.toList $ foldMap (\b -> foldMap snd . filter (\(b', _) -> matchWord b b') $ Map.toList users') buckets
|
|
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 eId uids = do
|
|
partResults <- E.select . E.from $ \(examPart `E.InnerJoin` examPartResult) -> do
|
|
E.on $ examPart E.^. ExamPartId E.==. examPartResult E.^. ExamPartResultExamPart
|
|
E.where_ $ examPart E.^. ExamPartExam E.==. E.val eId
|
|
E.&&. examPartResult E.^. ExamPartResultUser `E.in_` E.valList uids
|
|
return examPartResult
|
|
forM_ partResults $ \(Entity resId ExamPartResult{..}) -> do
|
|
delete resId
|
|
audit $ TransactionExamPartResultDeleted examPartResultExamPart examPartResultUser
|
|
|
|
results <- selectList [ ExamResultExam ==. eId, ExamResultUser <-. uids ] []
|
|
forM_ results $ \(Entity resId ExamResult{..}) -> do
|
|
delete resId
|
|
audit $ TransactionExamResultDeleted examResultExam examResultUser
|
|
|
|
boni <- selectList [ ExamBonusExam ==. eId, ExamBonusUser <-. uids ] []
|
|
forM_ boni $ \(Entity bonusId ExamBonus{..}) -> do
|
|
delete bonusId
|
|
audit $ TransactionExamBonusDeleted examBonusExam examBonusUser
|
|
|
|
regs <- selectList [ ExamRegistrationExam ==. eId, ExamRegistrationUser <-. uids ] []
|
|
fmap (ala Sum foldMap) . forM regs $ \(Entity regId ExamRegistration{..}) -> do
|
|
delete regId
|
|
audit $ TransactionExamDeregister examRegistrationExam examRegistrationUser
|
|
return 1
|
|
|
|
deregisterExamUsers :: (MonadIO m, HandlerSite m ~ UniWorX, MonadHandler m, MonadCatch m) => ExamId -> [UserId] -> SqlPersistT m ()
|
|
deregisterExamUsers eId uids = void $ deregisterExamUsersCount eId uids
|
|
|
|
|
|
examAidsPresetWidget :: ExamAidsPreset -> Widget
|
|
examAidsPresetWidget preset = $(i18nWidgetFile "exam-mode/aids")
|
|
|
|
examOnlinePresetWidget :: ExamOnlinePreset -> Widget
|
|
examOnlinePresetWidget preset = $(i18nWidgetFile "exam-mode/online")
|
|
|
|
examSynchronicityPresetWidget :: ExamSynchronicityPreset -> Widget
|
|
examSynchronicityPresetWidget preset = $(i18nWidgetFile "exam-mode/synchronicity")
|
|
|
|
examRequiredEquipmentPresetWidget :: ExamRequiredEquipmentPreset -> Widget
|
|
examRequiredEquipmentPresetWidget preset = $(i18nWidgetFile "exam-mode/requiredEquipment")
|
|
|
|
|
|
evalExamModeDNF :: ExamModeDNF -> ExamMode -> Bool
|
|
evalExamModeDNF (ExamModeDNF PredDNF{..}) ExamMode{..}
|
|
= dnfTerms
|
|
& map (Set.toList . toNullable) . Set.toList
|
|
& map ( maybe True (ofoldr1 (&&))
|
|
. fromNullable
|
|
. map (\pl -> bool id not (is _PLNegated pl) . evalPred $ plVar pl)
|
|
)
|
|
& maybe False (ofoldr1 (||)) . fromNullable
|
|
where
|
|
evalPred :: ExamModePredicate -> Bool
|
|
evalPred = \case
|
|
ExamModePredAids p
|
|
-> examAids == Just (ExamAidsPreset p)
|
|
ExamModePredOnline p
|
|
-> examOnline == Just (ExamOnlinePreset p)
|
|
ExamModePredSynchronicity p
|
|
-> examSynchronicity == Just (ExamSynchronicityPreset p)
|
|
ExamModePredRequiredEquipment p
|
|
-> examRequiredEquipment == Just (ExamRequiredEquipmentPreset p)
|
|
|
|
showExamOccurrenceRoom :: forall examOccurrence examOccurrenceId examId.
|
|
( E.SqlProject ExamOccurrence ExamOccurrenceId examOccurrence examOccurrenceId
|
|
, E.SqlProject ExamOccurrence ExamId examOccurrence examId
|
|
)
|
|
=> E.SqlExpr (E.Value UserId) -> E.SqlExpr examOccurrence -> E.SqlExpr (E.Value Bool)
|
|
showExamOccurrenceRoom uid occurrence = E.or
|
|
[ E.exists . E.from $ \register ->
|
|
E.where_ $ register E.^. ExamRegistrationUser E.==. uid
|
|
E.&&. E.maybe E.false (\occId -> E.unSqlProjectExpr (Proxy @ExamOccurrence) (Proxy @examOccurrence) occId E.==. occurrence `E.sqlProject` ExamOccurrenceId) (register E.^. ExamRegistrationOccurrence)
|
|
, E.exists . E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` exam) -> do
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
|
E.where_ $ lecturer E.^. LecturerUser E.==. uid
|
|
E.&&. E.unSqlProjectExpr (Proxy @ExamOccurrence) (Proxy @examOccurrence) (exam E.^. ExamId) E.==. occurrence `E.sqlProject` ExamOccurrenceExam
|
|
, E.exists . E.from $ \examCorrector ->
|
|
E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. uid
|
|
E.&&. E.unSqlProjectExpr (Proxy @ExamOccurrence) (Proxy @examOccurrence) (examCorrector E.^. ExamCorrectorExam) E.==. occurrence `E.sqlProject` ExamOccurrenceExam
|
|
]
|