63641c74-d139-4ebc-aa78-209950f26a95

Committed 19 Aug 2025 08:42PM UTC coverage: 57.075% (+3.0%) from 54.119%

Build # 63641c74-d139-4ebc-aa78-209950f26a95

Build Type

Pull #1599

circleci

Committed by

web-flow

Commit Message

Merge branch 'master' into cache-nodes

Pull Request Pull Request #1599: Add boolean node caching

Run Details

528 of 952 branches covered (55.46%)

Branch coverage included in aggregate %.

19 of 29 new or added lines in 1 file covered. (65.52%)

2 existing lines in 2 files now uncovered.

2247 of 3910 relevant lines covered (57.47%)

174.61 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

47.0

/app/DynamicGraphs/GraphGenerator.hs

{-# LANGUAGE OverloadedStrings #-}

module DynamicGraphs.GraphGenerator
  ( sampleGraph
  , coursesToPrereqGraph
  , coursesToPrereqGraphExcluding
  , graphProfileHash
  )
  where

import Control.Monad.State (State)
import qualified Control.Monad.State as State
import Css.Constants (nodeFontSize)
import Data.Containers.ListUtils (nubOrd)
import Data.Foldable (toList)
import Data.Graph (Tree (Node))
import Data.GraphViz.Attributes as A
import Data.GraphViz.Attributes.Complete as AC
import Data.GraphViz.Types.Generalised (DotEdge (..), DotGraph (..), DotNode (..),
                                        DotStatement (..), GlobalAttributes (..))
import Data.Hash.MD5 (Str (Str), md5s)
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, concat, isInfixOf, isPrefixOf, last, pack, take, unpack)
import Database.Requirement (Modifier (..), Req (..))
import DynamicGraphs.CourseFinder (lookupCourses)
import DynamicGraphs.GraphNodeUtils (formatModOr, maybeHead, paddingSpaces, stringifyModAnd)
import DynamicGraphs.GraphOptions (GraphOptions (..), defaultGraphOptions)
import Prelude hiding (last)

-- | Generates a DotGraph dependency graph including all the given courses and their recursive dependecies
coursesToPrereqGraph :: [String] -- ^ courses to generate
                        -> IO (DotGraph Text)
coursesToPrereqGraph rootCourses = coursesToPrereqGraphExcluding (map pack rootCourses) defaultGraphOptions

-- | Takes a list of courses we wish to generate a dependency graph for, along with graph options
-- for the courses we want to include. The generated graph will not contain the dependencies of the courses
-- from excluded departments. In addition, it will neither include any of the taken courses,
-- nor the dependencies of taken courses (unless they are depended on by other courses)
coursesToPrereqGraphExcluding :: [Text] -> GraphOptions -> IO (DotGraph Text)
coursesToPrereqGraphExcluding rootCourses options = do
    reqs <- lookupCourses options rootCourses
    let reqs' = Map.toList reqs
    return $ fst $ State.runState (reqsToGraph options reqs') initialState
    where
        initialState = GeneratorState 0 Map.empty

sampleGraph :: DotGraph Text
sampleGraph = fst $ State.runState (reqsToGraph
    defaultGraphOptions
    [("MAT237H1", J "MAT137H1" ""),
    ("MAT133H1", None),
    ("CSC148H1", ReqAnd [J "CSC108H1" "", J "CSC104H1" ""]),
    ("CSC265H1", ReqAnd [J "CSC148H1" "", J "CSC236H1" ""])
    ])
    (GeneratorState 0 Map.empty)

-- ** Main algorithm for converting requirements into a DotGraph

-- | Convert a list of coursenames and requirements to a DotGraph object for
--  drawing using Dot. Also prunes any repeated edges that arise from
--  multiple Reqs using the same Grade requirement
reqsToGraph :: GraphOptions -> [(Text, Req)] -> State GeneratorState (DotGraph Text)
reqsToGraph options reqs = do
    allStmts <- concatUnique <$> mapM (reqToStmts options) reqs
    return $ buildGraph allStmts
    where
        concatUnique = nubOrd . Prelude.concat

data GeneratorState = GeneratorState Integer (Map.Map Text (DotNode Text))

pickCourse :: GraphOptions -> Text -> Bool
pickCourse options name =
    pickCourseByDepartment options name &&
    pickCourseByLocation options name

pickCourseByDepartment :: GraphOptions -> Text -> Bool
pickCourseByDepartment options name =
    Prelude.null (departments options) ||
    prefixedByOneOf name (departments options)

pickCourseByLocation :: GraphOptions -> Text -> Bool
pickCourseByLocation options name =
    Prelude.null (location options) ||
    courseLocation `elem` mapMaybe locationNum (location options)
    where
        courseLocation = last name
        locationNum l = case l of
            "utsg" -> Just '1'
            "utsc" -> Just '3'
            "utm" -> Just '5'
            _ -> Nothing

nodeColor :: GraphOptions -> Text -> Color
nodeColor options name = colors !! depIndex
    where colors :: [Color]
          colors = cycle $ map toColor
            [Orchid, Orange, CornFlowerBlue, Salmon, Aquamarine, Yellow, OliveDrab]
          depIndex :: Int
          depIndex = fromMaybe 0 (elemIndex courseDep (departments options))
          courseDep :: Text
          courseDep = Data.Text.Lazy.take 3 name

-- | Convert the original requirement data into dot statements that can be used by buildGraph to create the
-- corresponding DotGraph objects.
reqToStmts :: GraphOptions -> (Text, Req) -> State GeneratorState [DotStatement Text]
reqToStmts options (name, req) = do
    if pickCourse options name
        then do
            node <- makeNode name $ Just (nodeColor options name)
            stmts <- reqToStmtsTree options (nodeID node) req
            return $ DN node:Prelude.concat (toList stmts)
        else return []

reqToStmtsTree :: GraphOptions -- ^ Options to toggle dynamic graph
               -> Text -- ^ Name of parent course
               -> Req  -- ^ Requirement to generate dep tree for
               -> State GeneratorState (Tree [DotStatement Text])
reqToStmtsTree _ _ None = return (Node [] [])
reqToStmtsTree options parentID (J name2 _) = do
    let name = pack name2
    if pickCourse options name then do
        prereq <- makeNode name $ Just (nodeColor options name)
        edge <- makeEdge (nodeID prereq) parentID Nothing
        return (Node [DN prereq, DE edge] [])
    else
        return (Node [] [])
-- Two or more required prerequisites.
reqToStmtsTree options parentID (ReqAnd reqs) = do
    (andNode, _) <- makeBool "and" reqs
    edge <- makeEdge (nodeID andNode) parentID Nothing
    prereqStmts <- mapM (reqToStmtsTree options (nodeID andNode)) reqs
    let filteredStmts = Prelude.filter (Node [] [] /=) prereqStmts
    case filteredStmts of
        [] -> return $ Node [] []
        [Node (DN node:_) xs] -> do
            -- make new edge with parent id and single child id
            newEdge <- makeEdge (nodeID node) parentID Nothing
            return $ Node [DN node, DE newEdge] xs
        _ -> return $ Node [DN andNode, DE edge] filteredStmts
-- A choice from two or more prerequisites.
reqToStmtsTree options parentID (ReqOr reqs) = do
    (orNode, _) <- makeBool "or" reqs
    edge <- makeEdge (nodeID orNode) parentID Nothing
    prereqStmts <- mapM (reqToStmtsTree options (nodeID orNode)) reqs
    let filteredStmts = Prelude.filter (Node [] [] /=) prereqStmts
    case filteredStmts of
        [] -> return $ Node [] []
        [Node (DN node:_) xs] -> do
            -- make new edge with parent id and single child id
            newEdge <- makeEdge (nodeID node) parentID Nothing
            return $ Node [DN node, DE newEdge] xs
        _  -> return $ Node [DN orNode, DE edge] filteredStmts

-- A prerequisite with a grade requirement.
reqToStmtsTree options parentID (Grade description req) = do
    if includeGrades options then do
        Node root rest <- reqToStmtsTree options parentID req
        case root of
            DN gradeNode:_ -> do
                -- make an annotated edge
                gradeEdge <- makeEdge (nodeID gradeNode)
                                      parentID
                                      (Just $ pack $ description ++ "%")
                -- swap out top edge of prereqStmt tree with annotated edge
                return $ Node [DN gradeNode, DE gradeEdge] rest
            _ -> return $ Node [] [] -- ERROR
    else reqToStmtsTree options parentID req

-- A raw string description of a prerequisite.
reqToStmtsTree options parentID (Raw rawText) =
    if not (includeRaws options) || "High school" `isInfixOf` pack rawText || rawText == ""
        then return $ Node [] []
        else do
            prereq <- makeNode (pack rawText) Nothing
            edge <- makeEdge (nodeID prereq) parentID Nothing
            return $ Node [DN prereq, DE edge] []

--A prerequisite concerning a given number of earned credits
reqToStmtsTree _ parentID (Fces creds (Requirement (Raw ""))) = do
    fceNode <- makeNode (pack $ show creds ++ " FCEs") Nothing
    edge <- makeEdge (nodeID fceNode) parentID Nothing
    return $ Node [DN fceNode, DE edge] []

--A prerequisite concerning a given number of earned credits in some raw string
reqToStmtsTree _ parentID (Fces creds (Requirement (Raw text))) = do
    fceNode <- makeNode (pack $ show creds ++ " FCEs from " ++ text ++ paddingSpaces 18) Nothing
    edge <- makeEdge (nodeID fceNode) parentID Nothing
    return $ Node [DN fceNode, DE edge] []

--A prerequisite concerning a given number of earned credits in some course(s)
reqToStmtsTree options parentID (Fces creds (Requirement req)) = do
    fceNode <- makeNode (pack $ show creds ++ " FCEs") Nothing
    edge <- makeEdge (nodeID fceNode) parentID Nothing
    prereqStmts <- reqToStmtsTree options (nodeID fceNode) req
    return $ Node [DN fceNode, DE edge] [prereqStmts]

--A prerequisite concerning a given number of earned credits in a department
reqToStmtsTree _ parentID (Fces creds (Department dept)) = do
    fceNode <- makeNode (pack $ show creds ++ " " ++ dept ++ " FCEs") Nothing
    edge <- makeEdge (nodeID fceNode) parentID Nothing
    return $ Node [DN fceNode, DE edge] []

--A prerequisite concerning a given number of earned credits at a given level
reqToStmtsTree _ parentID (Fces creds (Level level)) = do
    fceNode <- makeNode (pack $ show creds ++ " FCEs at the " ++ level ++ " level" ++ paddingSpaces 18) Nothing
    edge <- makeEdge (nodeID fceNode) parentID Nothing
    return $ Node [DN fceNode, DE edge] []

-- | A prerequisite concerning a given number of earned credits with a combination
-- | of some modifiers related through ModAnds
-- | Assumes each modifier constructor appears in modifiers at most once
-- | The ModOr constructor may appear more than once, but each occurrence
-- | of ModOr contains exactly one constructor for all its elements
-- | and such constructor does not appear anywhere else in ModAnd
reqToStmtsTree options parentID (Fces creds (ModAnd modifiers)) = do
    fceNode <- makeNode (pack $ stringifyModAnd creds modifiers ++ paddingSpaces 10) Nothing
    edge <- makeEdge (nodeID fceNode) parentID Nothing

    case maybeHead [req | Requirement req <- modifiers] of
        Nothing -> return $ Node [DN fceNode, DE edge] []
        Just req -> do
            prereqStmts <- reqToStmtsTree options (nodeID fceNode) req
            return $ Node [DN fceNode, DE edge] [prereqStmts]

-- | A prerequisite concerning a given number of earned credits with a combination
-- | of some modifiers related through a ModOr
-- | Assumes all modifiers in the list have the same constructor
reqToStmtsTree options parentID (Fces creds (ModOr modifiers)) = do
    fceNode <- makeNode (pack $ formatModOr creds modifiers) Nothing
    edge <- makeEdge (nodeID fceNode) parentID Nothing

    case maybeHead [req | Requirement req <- modifiers] of
        Nothing -> return $ Node [DN fceNode, DE edge] []
        Just req -> do
            prereqStmts <- reqToStmtsTree options (nodeID fceNode) req
            return $ Node [DN fceNode, DE edge] [prereqStmts]

-- A program requirement
reqToStmtsTree _ parentID (Program prog) = do
    -- FIXME: weird width calculation from the library with the prog
    -- so we padded the string with prog again to work around it
    progNode <- makeNode (pack $ "Enrolled in " ++ prog ++ Prelude.replicate (Prelude.length prog) ' ') Nothing
    edge <- makeEdge (nodeID progNode) parentID Nothing
    return $ Node [DN progNode, DE edge] []

-- a cGPA requirement
reqToStmtsTree _ parentID (Gpa float string) = do
    gpaNode <- makeNode (pack $ "Minimum cGPA of " ++ show float ++ string) Nothing
    edge <-  makeEdge (nodeID gpaNode) parentID Nothing
    return $ Node [DN gpaNode, DE edge] []

prefixedByOneOf :: Text -> [Text] -> Bool
prefixedByOneOf name = any (`isPrefixOf` name)

makeNode :: Text -> Maybe Color -> State GeneratorState (DotNode Text)
makeNode name nodeCol = do
    GeneratorState i nodesMap <- State.get
    case Map.lookup name nodesMap of
        Nothing -> do
            let nodeId = mappendTextWithCounter name i
                actualColor = case nodeCol of
                    Nothing -> toColor Gray
                    Just c -> c
                node = DotNode nodeId
                               [AC.Label $ toLabelValue name,
                                ID nodeId,
                                AC.FixedSize AC.GrowAsNeeded,
                                AC.FontSize nodeFontSize,
                                FillColor $ toColorList [actualColor]]
                nodesMap' = Map.insert name node nodesMap
            State.put (GeneratorState (i + 1) nodesMap')
            return node
        Just node -> return node

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 = pack $ unpack text1 ++ mconcat (map (fromMaybe "") sortedList)
    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)
makeEdge id1 id2 description =
    return $ DotEdge id1 id2
                     (ID (id1 `mappend` "|" `mappend` id2) : textLabelList)
    where
        textLabelList = case description of
            Nothing -> []
            Just a -> [textLabel a]

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
-- object with predefined hyperparameters (here, the hyperparameters defines that 1.graph can have multi-edges
-- 2.graph edges have directions 3.graphID not defined(not so clear) 4.the graph layout, node shape, edge shape
-- are defined by the attributes as below)
buildGraph :: [DotStatement Text] -> DotGraph Text
buildGraph statements = DotGraph {
    strictGraph = False,
    directedGraph = True,
    graphID = Nothing,
    graphStatements = Seq.fromList $ [
        GA graphAttrs,
        GA nodeAttrs,
        GA edgeAttrs
        ] ++ statements
    }

graphProfileHash :: String
graphProfileHash = md5s . Str . show $ (buildGraph [], ellipseAttrs)

-- | Means the layout of the full graph is from left to right.
graphAttrs :: GlobalAttributes
graphAttrs = GraphAttrs
    [ AC.RankDir AC.FromTop
    , AC.Splines AC.Ortho
    , AC.Concentrate False
    ]

nodeAttrs :: GlobalAttributes
nodeAttrs = NodeAttrs
    [ A.shape A.BoxShape
    , AC.FixedSize GrowAsNeeded
    , A.style A.filled
    ]

ellipseAttrs :: A.Attributes
ellipseAttrs =
    [ A.shape A.Ellipse
    , AC.Width 0.20     -- min 0.01
    , AC.Height 0.15    -- min 0.01
    , AC.FixedSize SetNodeSize
    , A.fillColor White
    , AC.FontSize 6.0  -- min 1.0
    ]

edgeAttrs :: GlobalAttributes
edgeAttrs = EdgeAttrs [
    ArrowHead (AType [(ArrMod FilledArrow BothSides, Normal)])
    ]

1	{-# LANGUAGE OverloadedStrings #-}
2
3	module DynamicGraphs.GraphGenerator
4	( sampleGraph
5	, coursesToPrereqGraph
6	, coursesToPrereqGraphExcluding
7	, graphProfileHash
8	)
9	where
10
11	import Control.Monad.State (State)
12	import qualified Control.Monad.State as State
13	import Css.Constants (nodeFontSize)
14	import Data.Containers.ListUtils (nubOrd)
15	import Data.Foldable (toList)
16	import Data.Graph (Tree (Node))
17	import Data.GraphViz.Attributes as A
18	import Data.GraphViz.Attributes.Complete as AC
19	import Data.GraphViz.Types.Generalised (DotEdge (..), DotGraph (..), DotNode (..),
20	DotStatement (..), GlobalAttributes (..))
21	import Data.Hash.MD5 (Str (Str), md5s)
22	import Data.List (elemIndex)
23	import qualified Data.Map.Strict as Map
24	import Data.Maybe (fromMaybe, mapMaybe)
25	import Data.Sequence as Seq
26	import Data.Text.Lazy (Text, concat, isInfixOf, isPrefixOf, last, pack, take, unpack)
27	import Database.Requirement (Modifier (..), Req (..))
28	import DynamicGraphs.CourseFinder (lookupCourses)
29	import DynamicGraphs.GraphNodeUtils (formatModOr, maybeHead, paddingSpaces, stringifyModAnd)
30	import DynamicGraphs.GraphOptions (GraphOptions (..), defaultGraphOptions)
31	import Prelude hiding (last)
32
33	-- \| Generates a DotGraph dependency graph including all the given courses and their recursive dependecies
34	coursesToPrereqGraph :: [String] -- ^ courses to generate
35	-> IO (DotGraph Text)
36	coursesToPrereqGraph rootCourses = coursesToPrereqGraphExcluding (map pack rootCourses) defaultGraphOptions	×
37
38	-- \| Takes a list of courses we wish to generate a dependency graph for, along with graph options
39	-- for the courses we want to include. The generated graph will not contain the dependencies of the courses
40	-- from excluded departments. In addition, it will neither include any of the taken courses,
41	-- nor the dependencies of taken courses (unless they are depended on by other courses)
42	coursesToPrereqGraphExcluding :: [Text] -> GraphOptions -> IO (DotGraph Text)
43	coursesToPrereqGraphExcluding rootCourses options = do	2✔
44	reqs <- lookupCourses options rootCourses	2✔
45	let reqs' = Map.toList reqs	2✔
46	return $ fst $ State.runState (reqsToGraph options reqs') initialState	2✔
47	where
48	initialState = GeneratorState 0 Map.empty	2✔
49
50	sampleGraph :: DotGraph Text
51	sampleGraph = fst $ State.runState (reqsToGraph	×
52	defaultGraphOptions	×
53	[("MAT237H1", J "MAT137H1" ""),	×
54	("MAT133H1", None),	×
55	("CSC148H1", ReqAnd [J "CSC108H1" "", J "CSC104H1" ""]),	×
56	("CSC265H1", ReqAnd [J "CSC148H1" "", J "CSC236H1" ""])	×
57	])
58	(GeneratorState 0 Map.empty)	×
59
60	-- ** Main algorithm for converting requirements into a DotGraph
61
62	-- \| Convert a list of coursenames and requirements to a DotGraph object for
63	-- drawing using Dot. Also prunes any repeated edges that arise from
64	-- multiple Reqs using the same Grade requirement
65	reqsToGraph :: GraphOptions -> [(Text, Req)] -> State GeneratorState (DotGraph Text)
66	reqsToGraph options reqs = do	2✔
67	allStmts <- concatUnique <$> mapM (reqToStmts options) reqs	2✔
68	return $ buildGraph allStmts	2✔
69	where
70	concatUnique = nubOrd . Prelude.concat	1✔
71
72	data GeneratorState = GeneratorState Integer (Map.Map Text (DotNode Text))
73
74	pickCourse :: GraphOptions -> Text -> Bool
75	pickCourse options name =
76	pickCourseByDepartment options name &&	8✔
77	pickCourseByLocation options name	8✔
78
79	pickCourseByDepartment :: GraphOptions -> Text -> Bool
80	pickCourseByDepartment options name =
81	Prelude.null (departments options) \|\|	8✔
82	prefixedByOneOf name (departments options)	×
83
84	pickCourseByLocation :: GraphOptions -> Text -> Bool
85	pickCourseByLocation options name =
86	Prelude.null (location options) \|\|	8✔
87	courseLocation `elem` mapMaybe locationNum (location options)	×
88	where
89	courseLocation = last name	×
90	locationNum l = case l of	×
91	"utsg" -> Just '1'	×
92	"utsc" -> Just '3'	×
93	"utm" -> Just '5'	×
94	_ -> Nothing	×
95
96	nodeColor :: GraphOptions -> Text -> Color
97	nodeColor options name = colors !! depIndex	6✔
98	where colors :: [Color]
99	colors = cycle $ map toColor	6✔
100	[Orchid, Orange, CornFlowerBlue, Salmon, Aquamarine, Yellow, OliveDrab]	1✔
101	depIndex :: Int
102	depIndex = fromMaybe 0 (elemIndex courseDep (departments options))	6✔
103	courseDep :: Text
104	courseDep = Data.Text.Lazy.take 3 name	×
105
106	-- \| Convert the original requirement data into dot statements that can be used by buildGraph to create the
107	-- corresponding DotGraph objects.
108	reqToStmts :: GraphOptions -> (Text, Req) -> State GeneratorState [DotStatement Text]
109	reqToStmts options (name, req) = do	3✔
110	if pickCourse options name	3!
111	then do	3✔
112	node <- makeNode name $ Just (nodeColor options name)	3✔
113	stmts <- reqToStmtsTree options (nodeID node) req	3✔
114	return $ DN node:Prelude.concat (toList stmts)	3✔
115	else return []	×
116
117	reqToStmtsTree :: GraphOptions -- ^ Options to toggle dynamic graph
118	-> Text -- ^ Name of parent course
119	-> Req -- ^ Requirement to generate dep tree for
120	-> State GeneratorState (Tree [DotStatement Text])
UNCOV 121	reqToStmtsTree _ _ None = return (Node [] [])	×
122	reqToStmtsTree options parentID (J name2 _) = do	5✔
123	let name = pack name2	5✔
124	if pickCourse options name then do	5!
125	prereq <- makeNode name $ Just (nodeColor options name)	5✔
126	edge <- makeEdge (nodeID prereq) parentID Nothing	5✔
127	return (Node [DN prereq, DE edge] [])	5✔
128	else
129	return (Node [] [])	×
130	-- Two or more required prerequisites.
131	reqToStmtsTree options parentID (ReqAnd reqs) = do	2✔
132	(andNode, _) <- makeBool "and" reqs	2✔
133	edge <- makeEdge (nodeID andNode) parentID Nothing	2✔
134	prereqStmts <- mapM (reqToStmtsTree options (nodeID andNode)) reqs	2✔
135	let filteredStmts = Prelude.filter (Node [] [] /=) prereqStmts	2✔
136	case filteredStmts of	2✔
137	[] -> return $ Node [] []	×
138	[Node (DN node:_) xs] -> do	×
139	-- make new edge with parent id and single child id
140	newEdge <- makeEdge (nodeID node) parentID Nothing	×
141	return $ Node [DN node, DE newEdge] xs	×
142	_ -> return $ Node [DN andNode, DE edge] filteredStmts	2✔
143	-- A choice from two or more prerequisites.
144	reqToStmtsTree options parentID (ReqOr reqs) = do	×
NEW 145	(orNode, _) <- makeBool "or" reqs	×
146	edge <- makeEdge (nodeID orNode) parentID Nothing	×
147	prereqStmts <- mapM (reqToStmtsTree options (nodeID orNode)) reqs	×
148	let filteredStmts = Prelude.filter (Node [] [] /=) prereqStmts	×
149	case filteredStmts of	×
150	[] -> return $ Node [] []	×
151	[Node (DN node:_) xs] -> do	×
152	-- make new edge with parent id and single child id
153	newEdge <- makeEdge (nodeID node) parentID Nothing	×
154	return $ Node [DN node, DE newEdge] xs	×
155	_ -> return $ Node [DN orNode, DE edge] filteredStmts	×
156
157	-- A prerequisite with a grade requirement.
158	reqToStmtsTree options parentID (Grade description req) = do	×
159	if includeGrades options then do	×
160	Node root rest <- reqToStmtsTree options parentID req	×
161	case root of	×
162	DN gradeNode:_ -> do	×
163	-- make an annotated edge
164	gradeEdge <- makeEdge (nodeID gradeNode)	×
165	parentID	×
166	(Just $ pack $ description ++ "%")	×
167	-- swap out top edge of prereqStmt tree with annotated edge
168	return $ Node [DN gradeNode, DE gradeEdge] rest	×
169	_ -> return $ Node [] [] -- ERROR	×
170	else reqToStmtsTree options parentID req	×
171
172	-- A raw string description of a prerequisite.
173	reqToStmtsTree options parentID (Raw rawText) =
174	if not (includeRaws options) \|\| "High school" `isInfixOf` pack rawText \|\| rawText == ""	×
175	then return $ Node [] []	×
176	else do	×
177	prereq <- makeNode (pack rawText) Nothing	×
178	edge <- makeEdge (nodeID prereq) parentID Nothing	×
179	return $ Node [DN prereq, DE edge] []	×
180
181	--A prerequisite concerning a given number of earned credits
182	reqToStmtsTree _ parentID (Fces creds (Requirement (Raw ""))) = do	×
183	fceNode <- makeNode (pack $ show creds ++ " FCEs") Nothing	×
184	edge <- makeEdge (nodeID fceNode) parentID Nothing	×
185	return $ Node [DN fceNode, DE edge] []	×
186
187	--A prerequisite concerning a given number of earned credits in some raw string
188	reqToStmtsTree _ parentID (Fces creds (Requirement (Raw text))) = do	×
189	fceNode <- makeNode (pack $ show creds ++ " FCEs from " ++ text ++ paddingSpaces 18) Nothing	×
190	edge <- makeEdge (nodeID fceNode) parentID Nothing	×
191	return $ Node [DN fceNode, DE edge] []	×
192
193	--A prerequisite concerning a given number of earned credits in some course(s)
194	reqToStmtsTree options parentID (Fces creds (Requirement req)) = do	×
195	fceNode <- makeNode (pack $ show creds ++ " FCEs") Nothing	×
196	edge <- makeEdge (nodeID fceNode) parentID Nothing	×
197	prereqStmts <- reqToStmtsTree options (nodeID fceNode) req	×
198	return $ Node [DN fceNode, DE edge] [prereqStmts]	×
199
200	--A prerequisite concerning a given number of earned credits in a department
201	reqToStmtsTree _ parentID (Fces creds (Department dept)) = do	×
202	fceNode <- makeNode (pack $ show creds ++ " " ++ dept ++ " FCEs") Nothing	×
203	edge <- makeEdge (nodeID fceNode) parentID Nothing	×
204	return $ Node [DN fceNode, DE edge] []	×
205
206	--A prerequisite concerning a given number of earned credits at a given level
207	reqToStmtsTree _ parentID (Fces creds (Level level)) = do	×
208	fceNode <- makeNode (pack $ show creds ++ " FCEs at the " ++ level ++ " level" ++ paddingSpaces 18) Nothing	×
209	edge <- makeEdge (nodeID fceNode) parentID Nothing	×
210	return $ Node [DN fceNode, DE edge] []	×
211
212	-- \| A prerequisite concerning a given number of earned credits with a combination
213	-- \| of some modifiers related through ModAnds
214	-- \| Assumes each modifier constructor appears in modifiers at most once
215	-- \| The ModOr constructor may appear more than once, but each occurrence
216	-- \| of ModOr contains exactly one constructor for all its elements
217	-- \| and such constructor does not appear anywhere else in ModAnd
218	reqToStmtsTree options parentID (Fces creds (ModAnd modifiers)) = do	×
219	fceNode <- makeNode (pack $ stringifyModAnd creds modifiers ++ paddingSpaces 10) Nothing	×
220	edge <- makeEdge (nodeID fceNode) parentID Nothing	×
221
222	case maybeHead [req \| Requirement req <- modifiers] of	×
223	Nothing -> return $ Node [DN fceNode, DE edge] []	×
224	Just req -> do	×
225	prereqStmts <- reqToStmtsTree options (nodeID fceNode) req	×
226	return $ Node [DN fceNode, DE edge] [prereqStmts]	×
227
228	-- \| A prerequisite concerning a given number of earned credits with a combination
229	-- \| of some modifiers related through a ModOr
230	-- \| Assumes all modifiers in the list have the same constructor
231	reqToStmtsTree options parentID (Fces creds (ModOr modifiers)) = do	×
232	fceNode <- makeNode (pack $ formatModOr creds modifiers) Nothing	×
233	edge <- makeEdge (nodeID fceNode) parentID Nothing	×
234
235	case maybeHead [req \| Requirement req <- modifiers] of	×
236	Nothing -> return $ Node [DN fceNode, DE edge] []	×
237	Just req -> do	×
238	prereqStmts <- reqToStmtsTree options (nodeID fceNode) req	×
239	return $ Node [DN fceNode, DE edge] [prereqStmts]	×
240
241	-- A program requirement
242	reqToStmtsTree _ parentID (Program prog) = do	×
243	-- FIXME: weird width calculation from the library with the prog
244	-- so we padded the string with prog again to work around it
245	progNode <- makeNode (pack $ "Enrolled in " ++ prog ++ Prelude.replicate (Prelude.length prog) ' ') Nothing	×
246	edge <- makeEdge (nodeID progNode) parentID Nothing	×
247	return $ Node [DN progNode, DE edge] []	×
248
249	-- a cGPA requirement
250	reqToStmtsTree _ parentID (Gpa float string) = do	×
251	gpaNode <- makeNode (pack $ "Minimum cGPA of " ++ show float ++ string) Nothing	×
252	edge <- makeEdge (nodeID gpaNode) parentID Nothing	×
253	return $ Node [DN gpaNode, DE edge] []	×
254
255	prefixedByOneOf :: Text -> [Text] -> Bool
256	prefixedByOneOf name = any (`isPrefixOf` name)	×
257
258	makeNode :: Text -> Maybe Color -> State GeneratorState (DotNode Text)
259	makeNode name nodeCol = do	8✔
260	GeneratorState i nodesMap <- State.get	1✔
261	case Map.lookup name nodesMap of	8✔
262	Nothing -> do	6✔
263	let nodeId = mappendTextWithCounter name i	6✔
264	actualColor = case nodeCol of	6✔
265	Nothing -> toColor Gray	×
266	Just c -> c	6✔
267	node = DotNode nodeId	6✔
268	[AC.Label $ toLabelValue name,	6✔
269	ID nodeId,	6✔
270	AC.FixedSize AC.GrowAsNeeded,	6✔
271	AC.FontSize nodeFontSize,	6✔
272	FillColor $ toColorList [actualColor]]	6✔
273	nodesMap' = Map.insert name node nodesMap	5✔
274	State.put (GeneratorState (i + 1) nodesMap')	5✔
275	return node	6✔
276	Just node -> return node	2✔
277
278	makeBool :: Text -> [Req] -> State GeneratorState (DotNode Text, Text)
279	makeBool text1 reqs = do	2✔
280	GeneratorState i boolsMap <- State.get	1✔
281	reqsList <- mapM generateBoolKey reqs	2✔
282	let sortedList = toList (sort $ fromList reqsList)	2✔
283	-- let boolKey = pack $ unpack text1 ++ mconcat (map (fromMaybe "") sortedList)
284	let boolKey = Data.Text.Lazy.concat $ text1 : sortedList	2✔
285	case Map.lookup boolKey boolsMap of	2✔
286	Nothing -> do	1✔
287	let nodeId = mappendTextWithCounter text1 i	1✔
288	let boolNode = DotNode nodeId	1✔
289	([AC.Label (toLabelValue text1), ID nodeId] ++ ellipseAttrs)	1✔
290	boolsMap' = Map.insert boolKey boolNode boolsMap	1✔
291	State.put (GeneratorState (i + 1) boolsMap')	1✔
292
293	return (boolNode, boolKey)	1✔
294	Just node -> do	1✔
295	return (node, boolKey)	1✔
296
297	-- \| Create edge from two node ids. Also allow for potential edge label
298	makeEdge :: Text -> Text -> Maybe Text -> State GeneratorState (DotEdge Text)
299	makeEdge id1 id2 description =
300	return $ DotEdge id1 id2	7✔
301	(ID (id1 `mappend` "\|" `mappend` id2) : textLabelList)	7✔
302	where
303	textLabelList = case description of	7✔
304	Nothing -> []	1✔
305	Just a -> [textLabel a]	×
306
307	mappendTextWithCounter :: Text -> Integer -> Text
308	mappendTextWithCounter text1 counter = text1 `mappend` "_counter_" `mappend` pack (show counter)	7✔
309
310	-- \| Generates a unique key for each boolean node
311	-- May generate lower level nodes that make up the boolean node
312	generateBoolKey :: Req -> State GeneratorState Text
313	generateBoolKey (J s1 _) = return $ pack ("_" ++ s1)	4✔
NEW 314	generateBoolKey (Grade _ req) = do	×
NEW 315	generateBoolKey req	×
NEW 316	generateBoolKey (ReqAnd reqs) = do	×
NEW 317	(_, boolKey)<- makeBool "and" reqs	×
NEW 318	return $ pack ("_[" ++ unpack boolKey ++ "]")	×
NEW 319	generateBoolKey (ReqOr reqs) = do	×
NEW 320	(_, boolKey) <- makeBool "or" reqs	×
NEW 321	return $ pack ("_[" ++ unpack boolKey ++ "]")	×
NEW 322	generateBoolKey _ = return ""	×
323
324	-- ** Graphviz configuration
325
326	-- \| With the dot statements converted from original requirement data as input, create the corresponding DotGraph
327	-- object with predefined hyperparameters (here, the hyperparameters defines that 1.graph can have multi-edges
328	-- 2.graph edges have directions 3.graphID not defined(not so clear) 4.the graph layout, node shape, edge shape
329	-- are defined by the attributes as below)
330	buildGraph :: [DotStatement Text] -> DotGraph Text
331	buildGraph statements = DotGraph {	3✔
332	strictGraph = False,	3✔
333	directedGraph = True,	3✔
334	graphID = Nothing,	1✔
335	graphStatements = Seq.fromList $ [	3✔
336	GA graphAttrs,	1✔
337	GA nodeAttrs,	1✔
338	GA edgeAttrs	1✔
339	] ++ statements	3✔
340	}
341
342	graphProfileHash :: String
343	graphProfileHash = md5s . Str . show $ (buildGraph [], ellipseAttrs)	1✔
344
345	-- \| Means the layout of the full graph is from left to right.
346	graphAttrs :: GlobalAttributes
347	graphAttrs = GraphAttrs	1✔
348	[ AC.RankDir AC.FromTop	1✔
349	, AC.Splines AC.Ortho	1✔
350	, AC.Concentrate False	1✔
351	]
352
353	nodeAttrs :: GlobalAttributes
354	nodeAttrs = NodeAttrs	1✔
355	[ A.shape A.BoxShape	1✔
356	, AC.FixedSize GrowAsNeeded	1✔
357	, A.style A.filled	1✔
358	]
359
360	ellipseAttrs :: A.Attributes
361	ellipseAttrs =
362	[ A.shape A.Ellipse	1✔
363	, AC.Width 0.20 -- min 0.01	1✔
364	, AC.Height 0.15 -- min 0.01	1✔
365	, AC.FixedSize SetNodeSize	1✔
366	, A.fillColor White	1✔
367	, AC.FontSize 6.0 -- min 1.0	1✔
368	]
369
370	edgeAttrs :: GlobalAttributes
371	edgeAttrs = EdgeAttrs [	1✔
372	ArrowHead (AType [(ArrMod FilledArrow BothSides, Normal)])	1✔
373	]

Courseography / courseography / 63641c74-d139-4ebc-aa78-209950f26a95

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous