show variant information at leaderboard

Handler/Graph.hs

@@ -13,27 +13,29 @@ getChallengeGraphDataR challengeName = submissionsToJSON (\_ -> True) challengeN
 
 submissionsToJSON :: ((Entity Submission) -> Bool) -> Text -> Handler Value
 submissionsToJSON condition challengeName = do
-  challengeEnt@(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName challengeName
+  (Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName
   (evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId
   let mainTestEnt = getMainTest tests
-  let (Entity mainTestId mainTest) = mainTestEnt
+  let (Entity mainTestId _) = mainTestEnt
   let auxSubmissions = getAuxSubmissionEnts mainTestId evaluationMaps
   let naturalRange = getNaturalRange auxSubmissions
-  let submissionIds = map (\(Entity k _, _) -> k) $ concat $ map (\(_, (_, p)) -> p) auxSubmissions
+  let submissionIds = map (\(Entity k _, _, _) -> k) $ concat $ map (\(_, (_, p)) -> p) auxSubmissions
 
   forks <- runDB $ selectList [ForkSource <-. submissionIds, ForkTarget <-. submissionIds] []
 
   return $ object [ "nodes" .= (Data.Maybe.catMaybes $ map (auxSubmissionToNode naturalRange) $ zip [0..] auxSubmissions),
                     "edges" .= map forkToEdge forks ]
 
+getNaturalRange :: [(a1, (a2, [(a3, a4, Evaluation)]))] -> Double
 getNaturalRange auxSubmissions = (2.0 * (interQuantile $ Data.Maybe.catMaybes $ map getScore auxSubmissions))
 
+getScore :: (a1, (a2, [(a3, a4, Evaluation)])) -> Maybe Double
 getScore (_, (_, [])) = Nothing
-getScore (_, (_, [(_, evaluation)])) = evaluationScore evaluation
+getScore (_, (_, [(_, _, evaluation)])) = evaluationScore evaluation
 
-auxSubmissionToNode :: Double -> (Int, (Key User, (User, [(Entity Submission, Evaluation)]))) -> Maybe Value
+auxSubmissionToNode :: Double -> (Int, (Key User, (User, [(Entity Submission, Entity Variant, Evaluation)]))) -> Maybe Value
 auxSubmissionToNode _ (_, (_, (_, []))) = Nothing
-auxSubmissionToNode naturalRange (n, (_, (_, [(Entity submissionId submission, evaluation)]))) = case evaluationScore evaluation of
+auxSubmissionToNode naturalRange (n, (_, (_, [(Entity submissionId submission, Entity variantId _, evaluation)]))) = case evaluationScore evaluation of
   Just score ->  Just $ object [
     "id" .= nodeId submissionId,
     "x"  .= (stampToX $ submissionStamp submission),

Handler/Tables.hs

@@ -27,9 +27,12 @@ data LeaderboardEntry = LeaderboardEntry {
   leaderboardUserId :: UserId,
   leaderboardBestSubmission :: Submission,
   leaderboardBestSubmissionId :: SubmissionId,
+  leaderboardBestVariant :: Variant,
+  leaderboardBestVariantId :: VariantId,
   leaderboardEvaluation :: Evaluation,
   leaderboardNumberOfSubmissions :: Int,
-  leaderboardTags :: [(Entity Tag, Entity SubmissionTag)]
+  leaderboardTags :: [(Entity Tag, Entity SubmissionTag)],
+  leaderboardParams :: [Parameter]
 }
 
 data TableEntry = TableEntry (Entity Submission)
@@ -82,7 +85,11 @@ leaderboardTable mauthId challengeName repoScheme challengeRepo test = mempty
 
 leaderboardDescriptionCell :: Table site (a, LeaderboardEntry)
 leaderboardDescriptionCell = Table.widget "description" (
-  \(_,entry) -> fragmentWithSubmissionTags (submissionDescription $ leaderboardBestSubmission entry) (leaderboardTags entry))
+  \(_,entry) -> fragmentWithSubmissionTags (descriptionToBeShown (leaderboardBestSubmission entry)
+                                                                (leaderboardBestVariant entry)
+                                                                (leaderboardParams entry))
+                                          (leaderboardTags entry)
+  )
 
 
 
@@ -113,22 +120,13 @@ statusCellWidget challengeName repoScheme challengeRepo (submissionId, submissio
                                 else
                                   Nothing
 
-getAuxSubmissions :: Key Test -> [(Entity Submission, Entity User, Map (Key Test) Evaluation)] -> [(Key User, (User, [(Submission, Evaluation)]))]
+getAuxSubmissionEnts :: Key Test -> [TableEntry] -> [(Key User, (User, [(Entity Submission, Entity Variant, Evaluation)]))]
-getAuxSubmissions testId evaluationMaps = map processEvaluationMap evaluationMaps
-   where processEvaluationMap ((Entity _ s), (Entity ui u), m) = (ui, (u, case Map.lookup testId m of
-                                                                                       Just e -> [(s, e)]
-                                                                                       Nothing -> []))
-
-
-getAuxSubmissionEnts :: Key Test -> [TableEntry] -> [(Key User, (User, [((Entity Submission), Evaluation)]))]
 getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluationMaps
-   where processEvaluationMap (TableEntry s _ (Entity ui u) m _ _) = (ui, (u, case Map.lookup testId m of
+   where processEvaluationMap (TableEntry s v (Entity ui u) m _ _) = (ui, (u, case Map.lookup testId m of
-                                                                                       Just e -> [(s, e)]
+                                                                                       Just e -> [(s, v, e)]
                                                                                        Nothing -> []))
 
 
-
-
 getLeaderboardEntries :: Key Challenge -> Handler (Test, [LeaderboardEntry])
 getLeaderboardEntries challengeId = do
   (evaluationMaps, tests) <- getChallengeSubmissionInfos (\_ -> True) challengeId
@@ -142,23 +140,30 @@ getLeaderboardEntries challengeId = do
   return (mainTest, entries)
 
 
-toEntry :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistQueryRead (YesodPersistBackend site), YesodPersist site, Foldable t) => Key Challenge -> Test -> (Key User, (User, t (Entity Submission, Evaluation))) -> HandlerFor site LeaderboardEntry
+toEntry :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistQueryRead (YesodPersistBackend site), YesodPersist site, Foldable t) => Key Challenge -> Test -> (Key User, (User, t (Entity Submission, Entity Variant, Evaluation))) -> HandlerFor site LeaderboardEntry
 toEntry challengeId mainTest (ui, (u, ss)) = do
   let bestOne = DL.maximumBy submissionComparator ss
-  let submissionId = entityKey $ fst bestOne
+  let (bestSubmission, bestVariant, bestEvaluation) = bestOne
+  let submissionId = entityKey bestSubmission
   tagEnts <- runDB $ getTags submissionId
+
+  parameters <- runDB $ selectList [ParameterVariant ==. (entityKey bestVariant)] [Asc ParameterName]
+
   -- get all user submissions, including hidden ones
   allUserSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId, SubmissionSubmitter ==. ui] [Desc SubmissionStamp]
   return $ LeaderboardEntry {
               leaderboardUser = u,
               leaderboardUserId = ui,
-              leaderboardBestSubmission = (\(Entity _ s) -> s) $ fst bestOne,
+              leaderboardBestSubmission = entityVal bestSubmission,
-              leaderboardBestSubmissionId = (\(Entity si _) -> si) $ fst bestOne,
+              leaderboardBestSubmissionId = entityKey bestSubmission,
-              leaderboardEvaluation = snd bestOne,
+              leaderboardBestVariant = entityVal bestVariant,
+              leaderboardBestVariantId = entityKey bestVariant,
+              leaderboardEvaluation = bestEvaluation,
               leaderboardNumberOfSubmissions = length allUserSubmissions,
-              leaderboardTags = tagEnts
+              leaderboardTags = tagEnts,
+              leaderboardParams = map entityVal parameters
               }
-     where submissionComparator (_, e1) (_, e2) = (compareResult mainTest) (evaluationScore e1) (evaluationScore e2)
+     where submissionComparator (_, _, e1) (_, _, e2) = (compareResult mainTest) (evaluationScore e1) (evaluationScore e2)
 
 
 compareResult :: Test -> Maybe Double -> Maybe Double -> Ordering