Skip to content

Refactor DFS implementation and enhance SetM type for performance #2

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Closed
decioferreira wants to merge 1 commit into from
Closed

Refactor DFS implementation and enhance SetM type for performance #2

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
96 changes: 63 additions & 33 deletions src/Data/Graph.elm
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -489,32 +489,38 @@ reasons.
dfs : Graph -> List Vertex -> List (Tree Vertex)
dfs g vs0 =
let
go : List Vertex -> SetM s (List (Tree Vertex))
go : List Vertex -> SetM (List (Tree Vertex))
go vrtcs =
loop goHelp ( vrtcs, identity )

goHelp : ( List Vertex, SetM (List (Tree Vertex)) -> SetM (List (Tree Vertex)) ) -> SetM (Step ( List Vertex, SetM (List (Tree Vertex)) -> SetM (List (Tree Vertex)) ) (List (Tree Vertex)))
goHelp ( vrtcs, cont ) =
case vrtcs of
[] ->
pure []
fmap Done <| cont <| pure []

v :: vs ->
contains v
|> bind
(\visited ->
if visited then
go vs
pure (Loop ( vs, cont ))

else
include v
|> bind
(\_ ->
go (Maybe.withDefault [] (Internal.find v g))
|> bind
(\subForest ->
go vs
|> bind
(\bs ->
pure (Tree.tree v subForest :: bs)
)
pure
(Loop
( Maybe.withDefault [] (Internal.find v g)
, bind
(\subForest ->
go vs
|> fmap (\bs -> Tree.tree v subForest :: bs)
)
>> cont
)
)
)
)
in
Expand All @@ -531,42 +537,66 @@ type alias IntSet =
Set Int


type SetM s a
= SetM (IntSet -> ( a, IntSet ))
type alias SetM a =
IntSet -> ( a, IntSet )


bind : (a -> SetM s b) -> SetM s a -> SetM s b
bind f (SetM v) =
SetM
(\s ->
let
( x, s_ ) =
v s
in
case f x of
SetM v_ ->
v_ s_
)
fmap : (a -> b) -> SetM a -> SetM b
fmap fn ma s0 =
let
( a, s1 ) =
ma s0
in
( fn a, s1 )


bind : (a -> SetM b) -> SetM a -> SetM b
bind f ma =
\s0 ->
let
( x, s1 ) =
ma s0
in
f x s1


pure : a -> SetM s a
pure : a -> SetM a
pure x =
SetM (\s -> ( x, s ))
\s -> ( x, s )


run : Bounds -> SetM s a -> a
run _ (SetM act) =
run : Bounds -> SetM a -> a
run _ act =
Tuple.first (act Set.empty)


contains : Vertex -> SetM s Bool
contains : Vertex -> SetM Bool
contains v =
SetM (\m -> ( Set.member v m, m ))
\m -> ( Set.member v m, m )


include : Vertex -> SetM s ()
include : Vertex -> SetM ()
include v =
SetM (\m -> ( (), Set.insert v m ))
\m -> ( (), Set.insert v m )



-- LOOP


type Step state a
= Loop state
| Done a


loop : (state -> SetM (Step state a)) -> state -> SetM a
loop callback loopState state =
case callback loopState state of
( Loop newLoopState, newState ) ->
loop callback newLoopState newState

( Done a, newState ) ->
( a, newState )



Expand Down
6 changes: 6 additions & 0 deletions tests/Data/GraphTests.elm
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -135,4 +135,10 @@ suite =
[ Tree.tree 0 [ Tree.tree 1 [ Tree.tree 2 [] ] ]
, Tree.tree 3 []
]
, Test.test "dfs (RangeError: Maximum call stack size exceeded)" <|
\_ ->
List.repeat 2000 ()
|> List.indexedMap (\i _ -> i)
|> G.dfs (G.buildG ( 0, 0 ) [])
|> always Expect.pass
]
Loading