Added boolean node caching in dynamic graph generation (#1599)

Author: yoonieaj

CHANGELOG.md

@@ -16,6 +16,7 @@
 - Fixed a bug on the generate page causing extraneous ellipses to appear when hovering over a course to highlight its prerequisites
 - Fixed a bug on the generate page where an extraneous info popup would appear when hovering over the top left corner of the graph viewing window
 - Fixed a bug that led code to crash when parsing all pre-generated graphs from svg (i.e., program graphs)
+- Fixed a bug where redundant boolean nodes were being generated
 
 ### 🔧 Internal changes
 

app/DynamicGraphs/GraphGenerator.hs

@@ -23,7 +23,7 @@ import Data.List (elemIndex)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (fromMaybe, mapMaybe)
 import Data.Sequence as Seq
-import Data.Text.Lazy (Text, isInfixOf, isPrefixOf, last, pack, take)
+import Data.Text.Lazy (Text, concat, isInfixOf, isPrefixOf, last, pack, take, unpack)
 import Database.Requirement (Modifier (..), Req (..))
 import DynamicGraphs.CourseFinder (lookupCourses)
 import DynamicGraphs.GraphNodeUtils (formatModOr, maybeHead, paddingSpaces, stringifyModAnd)
@@ -67,7 +67,7 @@ reqsToGraph options reqs = do
     allStmts <- concatUnique <$> mapM (reqToStmts options) reqs
     return $ buildGraph allStmts
     where
-        concatUnique = nubOrd . concat
+        concatUnique = nubOrd . Prelude.concat
 
 data GeneratorState = GeneratorState Integer (Map.Map Text (DotNode Text))
 
@@ -111,7 +111,7 @@ reqToStmts options (name, req) = do
         then do
             node <- makeNode name $ Just (nodeColor options name)
             stmts <- reqToStmtsTree options (nodeID node) req
-            return $ DN node:concat (toList stmts)
+            return $ DN node:Prelude.concat (toList stmts)
         else return []
 
 reqToStmtsTree :: GraphOptions -- ^ Options to toggle dynamic graph
@@ -129,7 +129,7 @@ reqToStmtsTree options parentID (J name2 _) = do
         return (Node [] [])
 -- Two or more required prerequisites.
 reqToStmtsTree options parentID (ReqAnd reqs) = do
-    andNode <- makeBool "and"
+    (andNode, _) <- makeBool "and" reqs
     edge <- makeEdge (nodeID andNode) parentID Nothing
     prereqStmts <- mapM (reqToStmtsTree options (nodeID andNode)) reqs
     let filteredStmts = Prelude.filter (Node [] [] /=) prereqStmts
@@ -142,7 +142,7 @@ reqToStmtsTree options parentID (ReqAnd reqs) = do
         _ -> return $ Node [DN andNode, DE edge] filteredStmts
 -- A choice from two or more prerequisites.
 reqToStmtsTree options parentID (ReqOr reqs) = do
-    orNode <- makeBool "or"
+    (orNode, _) <- makeBool "or" reqs
     edge <- makeEdge (nodeID orNode) parentID Nothing
     prereqStmts <- mapM (reqToStmtsTree options (nodeID orNode)) reqs
     let filteredStmts = Prelude.filter (Node [] [] /=) prereqStmts
@@ -275,13 +275,23 @@ makeNode name nodeCol = do
             return node
         Just node -> return node
 
-makeBool :: Text -> State GeneratorState (DotNode Text)
-makeBool text1 = do
-    GeneratorState i nodesMap <- State.get
-    State.put (GeneratorState (i + 1) nodesMap)
-    let nodeId = mappendTextWithCounter text1 i
-    return $ DotNode nodeId
-                     ([AC.Label (toLabelValue text1), ID nodeId] ++ ellipseAttrs)
+makeBool :: Text -> [Req] -> State GeneratorState (DotNode Text, Text)
+makeBool text1 reqs = do
+    GeneratorState i boolsMap <- State.get
+    reqsList <- mapM generateBoolKey reqs
+    let sortedList = toList (sort $ fromList reqsList)
+    let boolKey = Data.Text.Lazy.concat $ text1 : sortedList
+    case Map.lookup boolKey boolsMap of
+        Nothing -> do
+            let nodeId = mappendTextWithCounter text1 i
+            let boolNode = DotNode nodeId
+                                    ([AC.Label (toLabelValue text1), ID nodeId] ++ ellipseAttrs)
+                boolsMap' = Map.insert boolKey boolNode boolsMap
+            State.put (GeneratorState (i + 1) boolsMap')
+
+            return (boolNode, boolKey)
+        Just node -> do
+            return (node, boolKey)
 
 -- | Create edge from two node ids. Also allow for potential edge label
 makeEdge :: Text -> Text -> Maybe Text -> State GeneratorState (DotEdge Text)
@@ -296,6 +306,20 @@ makeEdge id1 id2 description =
 mappendTextWithCounter :: Text -> Integer -> Text
 mappendTextWithCounter text1 counter = text1 `mappend` "_counter_" `mappend` pack (show counter)
 
+-- | Generates a unique key for each boolean node
+-- May generate lower level nodes that make up the boolean node
+generateBoolKey :: Req -> State GeneratorState Text
+generateBoolKey (J s1 _) = return $ pack ("_" ++ s1)
+generateBoolKey (Grade _ req) = do
+    generateBoolKey req
+generateBoolKey (ReqAnd reqs) = do
+    (_, boolKey)<- makeBool "and" reqs
+    return $ pack ("_[" ++ unpack boolKey ++ "]")
+generateBoolKey (ReqOr reqs) = do
+    (_, boolKey) <- makeBool "or" reqs
+    return $ pack ("_[" ++ unpack boolKey ++ "]")
+generateBoolKey _ = return ""
+
 -- ** Graphviz configuration
 
 -- | With the dot statements converted from original requirement data as input, create the corresponding DotGraph

backend-test/Controllers/GenerateControllerTests.hs

@@ -28,20 +28,28 @@ import TestHelpers (clearDatabase, runServerPartWithGraphGenerate, withDatabase)
 insertCoursesWithPrerequisites :: [(T.Text, Maybe T.Text)] -> SqlPersistM ()
 insertCoursesWithPrerequisites = mapM_ insertCourse
     where
-        insertCourse (code, prereqString) = insert_ (Courses code Nothing Nothing Nothing prereqString Nothing Nothing Nothing Nothing [])
+        insertCourse (code, prereqString) = insert_ (Courses { coursesCode = code, coursesTitle = Nothing, coursesDescription = Nothing, coursesPrereqs = prereqString, coursesExclusions = Nothing, coursesBreadth = Nothing, coursesDistribution = Nothing, coursesPrereqString = prereqString, coursesCoreqs = Nothing, coursesVideoUrls = [] })
 
--- | List of test cases as (input course, course/prereq structure, JSON payload, expected # of nodes in prereq graph)
-findAndSavePrereqsResponseTestCases :: [(String, [(T.Text, Maybe T.Text)], BSL.ByteString, Integer)]
+-- | List of test cases as
+-- (input course, course/prereq structure, JSON payload, expected # of nodes in prereq graph, expected # of boolean nodes in prereq graph)
+findAndSavePrereqsResponseTestCases :: [(String, [(T.Text, Maybe T.Text)], BSL.ByteString, Integer, Integer)]
 findAndSavePrereqsResponseTestCases =
     [("CSC148H1",
     [("CSC108H1", Nothing), ("CSC148H1", Just "CSC108H1")],
     "{\"courses\":[\"CSC148H1\"],\"programs\":[],\"graphOptions\":{\"taken\":[],\"departments\":[\"CSC\",\"MAT\",\"STA\"]}}",
-    2
+    2,
+    0
+    ),
+    ("CSC368H1",
+    [("CSC209H1", Nothing), ("CSC258H1", Nothing), ("CSC368H1", Just "CSC209H1,  CSC258H1"), ("CSC369H1", Just "CSC209H1, CSC258H1")],
+    "{\"courses\":[\"CSC368H1\", \"CSC369H1\"],\"programs\":[],\"graphOptions\":{\"taken\":[],\"departments\":[\"CSC\",\"MAT\",\"STA\"]}}",
+    4,
+    1
     )]
 
 -- | Run a test case (input course, course/prereq structure, JSON payload, expected # of nodes) on the findAndSavePrereqsResponse function.
-runfindAndSavePrereqsResponseTest :: String -> [(T.Text, Maybe T.Text)] -> BSL.ByteString -> Integer -> TestTree
-runfindAndSavePrereqsResponseTest course graphStructure payload expected =
+runfindAndSavePrereqsResponseTest :: String -> [(T.Text, Maybe T.Text)] -> BSL.ByteString -> Integer -> Integer -> TestTree
+runfindAndSavePrereqsResponseTest course graphStructure payload expectedNodes expectedBoolNodes =
     testCase course $ do
         runDb $ do
             clearDatabase
@@ -51,19 +59,27 @@ runfindAndSavePrereqsResponseTest course graphStructure payload expected =
         let body = rsBody response
             Just (Object object) = decode body
             Just (Array shapes)  = KM.lookup (K.fromString "shapes") object
-            actual =
+            actualNodes =
                 fromIntegral . length $ filter isNode (toList shapes)
+            actualBoolNodes =
+                fromIntegral . length $ filter isBoolNode (toList shapes)
 
-        assertEqual ("Unexpected response for " ++ course) expected actual
+        -- TODO: currently, one extra node is being generated, so we subtract 1 from expectedNodes
+        -- This should be changed once the bug is fixed!
+        assertEqual ("Unexpected response for " ++ course) expectedNodes (actualNodes - 1)
+        assertEqual ("Unexpected response for " ++ course) expectedBoolNodes actualBoolNodes
 
     where
         isNode (Object object) =
             KM.lookup (K.fromString "type_") object == Just (String "Node")
         isNode _ = False
+        isBoolNode (Object object) =
+            KM.lookup (K.fromString "type_") object == Just (String "BoolNode")
+        isBoolNode _ = False
 
 -- | Run all the findAndSavePrereqsResponse test cases
 runfindAndSavePrereqsResponseTests :: [TestTree]
-runfindAndSavePrereqsResponseTests = map (\(course, courseStructure, payload, expectedNodes) -> runfindAndSavePrereqsResponseTest course courseStructure payload expectedNodes) findAndSavePrereqsResponseTestCases
+runfindAndSavePrereqsResponseTests = map (\(course, courseStructure, payload, expectedNodes, expectedBoolNodes) -> runfindAndSavePrereqsResponseTest course courseStructure payload expectedNodes expectedBoolNodes) findAndSavePrereqsResponseTestCases
 
 -- | Test suite for Generate Controller Module
 test_generateController :: TestTree

backend-test/TestHelpers.hs

@@ -164,13 +164,13 @@ clearDatabase = do
     deleteWhere ([] :: [Filter Times])
     deleteWhere ([] :: [Filter Breadth])
     deleteWhere ([] :: [Filter Distribution])
-    deleteWhere ([] :: [Filter Graph])
     deleteWhere ([] :: [Filter Database.Tables.Text])
     deleteWhere ([] :: [Filter Shape])
     deleteWhere ([] :: [Filter Path])
     deleteWhere ([] :: [Filter Post])
     deleteWhere ([] :: [Filter PostCategory])
     deleteWhere ([] :: [Filter Building])
+    deleteWhere ([] :: [Filter Graph])
 
 acquireDatabase :: IO ()
 acquireDatabase = do