{-# LANGUAGE ScopedTypeVariables #-}

-- | The function in this module finds a cycle in a given directed graph, if
-- one exists.
module Graphs.FindCycle (
   findCycle,
      -- :: Ord a => [a] -> (a -> [a]) -> Maybe [a]
      -- List of all nodes, and a successor function.
   ) where

import qualified Data.Set as Set

data DFSOut a =
      NoCycle (Set.Set a) -- set of nodes *not* visited
   |  Cycle [a]
   |  PartialCycle [a] a

-- | Find a cycle in a graph.  We are given a list of nodes to start
-- from, and a successor function.
findCycle :: Ord a => [a] -> (a -> [a]) -> Maybe [a]
findCycle :: [a] -> (a -> [a]) -> Maybe [a]
findCycle ([a]
nodes :: [a]) (a -> [a]
sFn :: a -> [a]) =
   let
      findCycle1 :: [a] -> Set.Set a -> Maybe [a]
      findCycle1 :: [a] -> Set a -> Maybe [a]
findCycle1 [a]
nodes0 Set a
visited0 =
         case [a]
nodes0 of
            a
a : [a]
nodes1 ->
               case Set a -> Set a -> a -> DFSOut a
findCycle2 Set a
forall a. Set a
Set.empty Set a
visited0 a
a of
                  NoCycle Set a
visited1 -> [a] -> Set a -> Maybe [a]
findCycle1 [a]
nodes1 Set a
visited1
                  Cycle [a]
cycle -> [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a]
cycle
                  DFSOut a
_ -> [Char] -> Maybe [a]
forall a. HasCallStack => [Char] -> a
error [Char]
"findCycle - unexpected PartialCycle"
            [] -> Maybe [a]
forall a. Maybe a
Nothing


      findCycle2 :: Set.Set a -> Set.Set a -> a -> DFSOut a
      findCycle2 :: Set a -> Set a -> a -> DFSOut a
findCycle2 Set a
aboveThis0 Set a
visited0 a
this =
         if a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member a
this Set a
visited0
            then
               Set a -> DFSOut a
forall a. Set a -> DFSOut a
NoCycle Set a
visited0
            else
               if a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member a
this Set a
aboveThis0
                  then
                     [a] -> a -> DFSOut a
forall a. [a] -> a -> DFSOut a
PartialCycle [] a
this
                  else
                     let
                        succs :: [a]
succs = a -> [a]
sFn a
this
                        aboveThis1 :: Set a
aboveThis1 = a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
this Set a
aboveThis0

                        doSuccs :: [a] -> Set.Set a -> DFSOut a
                        doSuccs :: [a] -> Set a -> DFSOut a
doSuccs [] Set a
visited
                           = Set a -> DFSOut a
forall a. Set a -> DFSOut a
NoCycle (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
this Set a
visited)
                        doSuccs (a
succ:[a]
succs) Set a
visited0 =
                           case Set a -> Set a -> a -> DFSOut a
findCycle2 Set a
aboveThis1 Set a
visited0 a
succ of
                              NoCycle Set a
visited1 -> [a] -> Set a -> DFSOut a
doSuccs [a]
succs Set a
visited1
                              PartialCycle [a]
arc a
node ->
                                 if a
node a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
this
                                    then
                                       [a] -> DFSOut a
forall a. [a] -> DFSOut a
Cycle (a
this a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
arc)
                                    else
                                       [a] -> a -> DFSOut a
forall a. [a] -> a -> DFSOut a
PartialCycle (a
this a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
arc) a
node
                              DFSOut a
cycle -> DFSOut a
cycle
                     in
                        [a] -> Set a -> DFSOut a
doSuccs [a]
succs Set a
visited0
   in
      [a] -> Set a -> Maybe [a]
findCycle1 [a]
nodes Set a
forall a. Set a
Set.empty