visualize forks

Handler/Graph.hs

@@ -5,10 +5,10 @@ import Import
 import Handler.Tables
 import Data.Maybe
 import Data.List ((!!))
+import Database.Persist.Sql
 
 getChallengeGraphDataR :: Text -> Handler Value
 getChallengeGraphDataR challengeName = submissionsToJSON (\_ -> True) challengeName
---getChallengeGraphDataR _ = return $ object [ "nodes" .= [node,node']]
 
 submissionsToJSON :: ((Entity Submission) -> Bool) -> Text -> Handler Value
 submissionsToJSON condition challengeName = do
@@ -16,48 +16,48 @@ submissionsToJSON condition challengeName = do
   (evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId
   let mainTestEnt = getMainTest tests
   let (Entity mainTestId mainTest) = mainTestEnt
-  let auxSubmissions = getAuxSubmissions mainTestId evaluationMaps
+  let auxSubmissions = getAuxSubmissionEnts mainTestId evaluationMaps
   let naturalRange = getNaturalRange auxSubmissions
-  return $ object [ "nodes" .= (Data.Maybe.catMaybes $ map (auxSubmissionToNode naturalRange) $ zip [0..] 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 auxSubmissions = (2.0 * (interQuantile $ Data.Maybe.catMaybes $ map getScore auxSubmissions))
 
 getScore (_, (_, [])) = Nothing
 getScore (_, (_, [(_, evaluation)])) = evaluationScore evaluation
 
-auxSubmissionToNode :: Double -> (Int, (Key User, (User, [(Submission, Evaluation)]))) -> Maybe Value
+auxSubmissionToNode :: Double -> (Int, (Key User, (User, [(Entity Submission, Evaluation)]))) -> Maybe Value
 auxSubmissionToNode _ (_, (_, (_, []))) = Nothing
-auxSubmissionToNode naturalRange (n, (_, (_, [(submission, evaluation)]))) = case evaluationScore evaluation of
+auxSubmissionToNode naturalRange (n, (_, (_, [(Entity submissionId submission, evaluation)]))) = case evaluationScore evaluation of
   Just score ->  Just $ object [
-    "id" .= ("n" ++ (show n)),
+    "id" .= nodeId submissionId,
     "x"  .= (stampToX $ submissionStamp submission),
     "y"  .= (- ((score / naturalRange) * 100.0)),
-    "size" .= (3 :: Int),
+    "size" .= (2 :: Int),
     "label" .= submissionDescription submission ]
   Nothing -> Nothing
 
+forkToEdge :: Entity Fork -> Value
+forkToEdge (Entity forkId fork) = object [
+  "source" .= nodeId (forkSource fork),
+  "target" .= nodeId (forkTarget fork),
+  "id"     .= edgeId forkId,
+  "type"   .= ["arrow" :: String]
+  ]
+
+nodeId :: Key Submission -> String
+nodeId = ("n" ++) . show . fromSqlKey
+
+edgeId :: Key Fork -> String
+edgeId = ("e" ++) . show . fromSqlKey
+
 stampToX :: UTCTime -> Integer
 stampToX = toModifiedJulianDay . utctDay
 
-node :: Value
-node = object [
-  "id" .= ("n0" :: String),
-  "x"  .= (0 :: Int),
-  "y"  .= (0 :: Int),
-  "size" .= (3 :: Int),
-  "label" .= ("test" :: String)
-  ]
-
-
-node' :: Value
-node' = object [
-  "id" .= ("n1" :: String),
-  "x"  .= (5 :: Int),
-  "y"  .= (3 :: Int),
-  "size" .= (1 :: Int)
-  ]
-
-
 -- taken from Math.Statistics
 
 interQuantile :: (Fractional b, Ord b) => [b] -> b

Handler/Tables.hs

@@ -50,6 +50,16 @@ getAuxSubmissions testId evaluationMaps = map (processEvaluationMap testId) eval
                                                                                        Just e -> [(s, e)]
                                                                                        Nothing -> []))
 
+
+getAuxSubmissionEnts :: Key Test -> [(Entity Submission, Entity User, Map (Key Test) Evaluation)] -> [(Key User, (User, [((Entity Submission), Evaluation)]))]
+getAuxSubmissionEnts testId evaluationMaps = map (processEvaluationMap testId) evaluationMaps
+   where processEvaluationMap testId (s, (Entity ui u), m) = (ui, (u, case Map.lookup testId m of
+                                                                                       Just e -> [(s, e)]
+                                                                                       Nothing -> []))
+
+
+
+
 getLeaderboardEntries :: Key Challenge -> Handler [LeaderboardEntry]
 getLeaderboardEntries challengeId = do
   (evaluationMaps, tests) <- getChallengeSubmissionInfos (\_ -> True) challengeId

config/models

@@ -47,6 +47,10 @@ Submission
     stamp UTCTime default=now()
     submitter UserId
     UniqueSubmissionRepoCommitChallenge repo commit challenge
+Fork
+    source SubmissionId
+    target SubmissionId
+    UniqueSourceTarget source target
 Evaluation
     test TestId
     checksum SHA1