{- |
Description: Construct spanning trees
Copyright: Copyright (C) 2023 Yoo Chung
License: GPL-3.0-or-later
Maintainer: dev@chungyc.org

Some solutions to "Problems.P83" of Ninety-Nine Haskell "Problems".
-}
module Solutions.P83 (spanningTrees, isTree, isConnected) where

import qualified Data.Map.Lazy   as Map
import           Data.Maybe      (fromJust)
import           Data.Set        (Set)
import qualified Data.Set        as Set
import           Problems.Graphs

-- | Construct all spanning trees of a given graph.
spanningTrees :: G -> [G]
spanningTrees :: G -> [G]
spanningTrees g :: G
g@(G Map Vertex (Set Vertex)
m)
  | Map Vertex (Set Vertex) -> Bool
forall k a. Map k a -> Bool
Map.null Map Vertex (Set Vertex)
m = []
  | Bool
otherwise = G -> Set Vertex -> (Set Vertex, Set Edge) -> [G]
expandFront G
g (Vertex -> Set Vertex
forall a. a -> Set a
Set.singleton Vertex
v) (Vertex -> Set Vertex
forall a. a -> Set a
Set.singleton Vertex
v, Set Edge
forall a. Set a
Set.empty)
  where (Vertex
v, Set Vertex
_) = Map Vertex (Set Vertex) -> (Vertex, Set Vertex)
forall k a. Map k a -> (k, a)
Map.findMin Map Vertex (Set Vertex)
m

-- | Write a function which returns whether a graph is a tree using 'spanningTrees'.
isTree :: G -> Bool
isTree :: G -> Bool
isTree G
g
  | Set Vertex -> Bool
forall a. Set a -> Bool
Set.null (G -> Set Vertex
forall g. Graph g => g -> Set Vertex
vertexes G
g) = Bool
True
  | Bool
otherwise             = [G] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length (G -> [G]
spanningTrees G
g) Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== Vertex
1

-- | Write a function which returns whether a graph is connected using 'spanningTrees'.
isConnected :: G -> Bool
isConnected :: G -> Bool
isConnected G
g
  | Set Vertex -> Bool
forall a. Set a -> Bool
Set.null (G -> Set Vertex
forall g. Graph g => g -> Set Vertex
vertexes G
g) = Bool
True
  | Bool
otherwise             = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [G] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([G] -> Bool) -> [G] -> Bool
forall a b. (a -> b) -> a -> b
$ G -> [G]
spanningTrees G
g

expandFront :: G -> Set Vertex -> (Set Vertex, Set Edge) -> [G]
expandFront :: G -> Set Vertex -> (Set Vertex, Set Edge) -> [G]
expandFront g :: G
g@(G Map Vertex (Set Vertex)
m) Set Vertex
front (Set Vertex
vs, Set Edge
es)
  | Set Vertex -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Vertex
front = [Maybe G -> G
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe G -> G) -> Maybe G -> G
forall a b. (a -> b) -> a -> b
$ (Set Vertex, Set Edge) -> Maybe G
forall g. Graph g => (Set Vertex, Set Edge) -> Maybe g
toGraph (Set Vertex
vs, Set Edge
es) | Set Vertex -> Vertex
forall a. Set a -> Vertex
Set.size Set Vertex
vs Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== Map Vertex (Set Vertex) -> Vertex
forall k a. Map k a -> Vertex
Map.size Map Vertex (Set Vertex)
m ]
  | Bool
otherwise = (Set (Vertex, Vertex) -> [G]) -> [Set (Vertex, Vertex)] -> [G]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Set (Vertex, Vertex) -> [G]
expandTendrils ([Set (Vertex, Vertex)] -> [G]) -> [Set (Vertex, Vertex)] -> [G]
forall a b. (a -> b) -> a -> b
$ (Set (Vertex, Vertex) -> Bool)
-> [Set (Vertex, Vertex)] -> [Set (Vertex, Vertex)]
forall a. (a -> Bool) -> [a] -> [a]
filter Set (Vertex, Vertex) -> Bool
disjoint ([Set (Vertex, Vertex)] -> [Set (Vertex, Vertex)])
-> [Set (Vertex, Vertex)] -> [Set (Vertex, Vertex)]
forall a b. (a -> b) -> a -> b
$ Set (Set (Vertex, Vertex)) -> [Set (Vertex, Vertex)]
forall a. Set a -> [a]
Set.toList (Set (Set (Vertex, Vertex)) -> [Set (Vertex, Vertex)])
-> Set (Set (Vertex, Vertex)) -> [Set (Vertex, Vertex)]
forall a b. (a -> b) -> a -> b
$ Set (Vertex, Vertex) -> Set (Set (Vertex, Vertex))
forall a. Set a -> Set (Set a)
Set.powerSet Set (Vertex, Vertex)
tendrilsSet
  where tendrilsSet :: Set (Vertex, Vertex)
tendrilsSet = ((Vertex, Vertex) -> Bool)
-> Set (Vertex, Vertex) -> Set (Vertex, Vertex)
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Vertex, Vertex) -> Bool
notPassed (Set (Vertex, Vertex) -> Set (Vertex, Vertex))
-> Set (Vertex, Vertex) -> Set (Vertex, Vertex)
forall a b. (a -> b) -> a -> b
$ ((Vertex, Vertex) -> Bool)
-> Set (Vertex, Vertex) -> Set (Vertex, Vertex)
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Vertex -> Bool
notVisited (Vertex -> Bool)
-> ((Vertex, Vertex) -> Vertex) -> (Vertex, Vertex) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vertex, Vertex) -> Vertex
forall a b. (a, b) -> b
snd) Set (Vertex, Vertex)
border
        notVisited :: Vertex -> Bool
notVisited Vertex
v = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Vertex -> Set Vertex -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Vertex
v Set Vertex
vs
        notPassed :: (Vertex, Vertex) -> Bool
notPassed (Vertex, Vertex)
e = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Edge -> Set Edge -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ((Vertex, Vertex) -> Edge
Edge (Vertex, Vertex)
e) Set Edge
es
        border :: Set (Vertex, Vertex)
border = Set (Set (Vertex, Vertex)) -> Set (Vertex, Vertex)
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (Set (Set (Vertex, Vertex)) -> Set (Vertex, Vertex))
-> Set (Set (Vertex, Vertex)) -> Set (Vertex, Vertex)
forall a b. (a -> b) -> a -> b
$ (Vertex -> Set (Vertex, Vertex))
-> Set Vertex -> Set (Set (Vertex, Vertex))
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\Vertex
v -> (Vertex -> (Vertex, Vertex)) -> Set Vertex -> Set (Vertex, Vertex)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Vertex
v,) (Set Vertex -> Set (Vertex, Vertex))
-> Set Vertex -> Set (Vertex, Vertex)
forall a b. (a -> b) -> a -> b
$ Vertex -> G -> Set Vertex
forall g. Graph g => Vertex -> g -> Set Vertex
neighbors Vertex
v G
g) Set Vertex
front
        expandTendrils :: Set (Vertex, Vertex) -> [G]
expandTendrils Set (Vertex, Vertex)
tendrils = G -> Set Vertex -> (Set Vertex, Set Edge) -> [G]
expandFront G
g (((Vertex, Vertex) -> Vertex) -> Set (Vertex, Vertex) -> Set Vertex
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Vertex, Vertex) -> Vertex
forall a b. (a, b) -> b
snd Set (Vertex, Vertex)
tendrils) (Set (Vertex, Vertex) -> (Set Vertex, Set Edge)
incorporateTendrils Set (Vertex, Vertex)
tendrils)
        incorporateTendrils :: Set (Vertex, Vertex) -> (Set Vertex, Set Edge)
incorporateTendrils Set (Vertex, Vertex)
tendrils = (Set Vertex -> Set Vertex -> Set Vertex
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Vertex
vs (Set Vertex -> Set Vertex) -> Set Vertex -> Set Vertex
forall a b. (a -> b) -> a -> b
$ ((Vertex, Vertex) -> Vertex) -> Set (Vertex, Vertex) -> Set Vertex
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Vertex, Vertex) -> Vertex
forall a b. (a, b) -> b
snd Set (Vertex, Vertex)
tendrils, Set Edge -> Set Edge -> Set Edge
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Edge
es (Set Edge -> Set Edge) -> Set Edge -> Set Edge
forall a b. (a -> b) -> a -> b
$ ((Vertex, Vertex) -> Edge) -> Set (Vertex, Vertex) -> Set Edge
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Vertex, Vertex) -> Edge
Edge Set (Vertex, Vertex)
tendrils)

disjoint :: Set (Vertex, Vertex) -> Bool
disjoint :: Set (Vertex, Vertex) -> Bool
disjoint Set (Vertex, Vertex)
s = (Bool, Set Vertex) -> Bool
forall a b. (a, b) -> a
fst ((Bool, Set Vertex) -> Bool) -> (Bool, Set Vertex) -> Bool
forall a b. (a -> b) -> a -> b
$ ((Bool, Set Vertex) -> (Vertex, Vertex) -> (Bool, Set Vertex))
-> (Bool, Set Vertex) -> Set (Vertex, Vertex) -> (Bool, Set Vertex)
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl (Bool, Set Vertex) -> (Vertex, Vertex) -> (Bool, Set Vertex)
forall {a} {a}. Ord a => (Bool, Set a) -> (a, a) -> (Bool, Set a)
accumulate (Bool
True, Set Vertex
forall a. Set a
Set.empty) Set (Vertex, Vertex)
s
  where accumulate :: (Bool, Set a) -> (a, a) -> (Bool, Set a)
accumulate (Bool
r, Set a
vs) (a
_, a
v) = (Bool
r Bool -> Bool -> Bool
&& Bool -> Bool
not (a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member a
v Set a
vs), a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
v Set a
vs)