{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
module Solutions.P92 (gracefulTree, gracefulTree') where
import Control.Applicative ((<|>))
import Data.List (permutations, sort, sortOn)
import Data.Map.Lazy (Map, (!))
import qualified Data.Map.Lazy as Map
import Data.Maybe (fromJust)
import Data.Ord (Down (..))
import Data.Set (Set)
import qualified Data.Set as Set
import Problems.Graphs
import Problems.P81
gracefulTree :: G -> Maybe (Map Vertex Int)
gracefulTree :: G -> Maybe (Map Int Int)
gracefulTree G
g
| Set Int -> Bool
forall a. Set a -> Bool
Set.null (Set Int -> Bool) -> Set Int -> Bool
forall a b. (a -> b) -> a -> b
$ G -> Set Int
forall g. Graph g => g -> Set Int
vertexes G
g = Map Int Int -> Maybe (Map Int Int)
forall a. a -> Maybe a
Just Map Int Int
forall k a. Map k a
Map.empty
| G -> Bool
isTree G
g = Partial -> Maybe (Map Int Int)
expand Partial
p
| Bool
otherwise = Maybe (Map Int Int)
forall a. HasCallStack => a
undefined
where vs :: [Int]
vs = G -> [Int]
vertexesByDegree G
g
p :: Partial
p = Partial { graph :: G
graph = G
g
, labeling :: Map Int Int
labeling = Map Int Int
forall k a. Map k a
Map.empty
, remainingVertexes :: [Int]
remainingVertexes = [Int]
vs
, remainingVertexLabels :: Set Int
remainingVertexLabels = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [Int
1..([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
vs)]
, definiteEdgeDifferences :: Set Int
definiteEdgeDifferences = Set Int
forall a. Set a
Set.empty
}
data Partial = Partial
{ Partial -> G
graph :: G
, Partial -> Map Int Int
labeling :: Map Vertex Int
, Partial -> [Int]
remainingVertexes :: [Vertex]
, Partial -> Set Int
remainingVertexLabels :: Set Int
, Partial -> Set Int
definiteEdgeDifferences :: Set Int
}
vertexesByDegree :: G -> [Vertex]
vertexesByDegree :: G -> [Int]
vertexesByDegree G
g = (Int -> Down Int) -> [Int] -> [Int]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\Int
v -> Int -> Down Int
forall a. a -> Down a
Down (Int -> Down Int) -> Int -> Down Int
forall a b. (a -> b) -> a -> b
$ Set Int -> Int
forall a. Set a -> Int
Set.size (Set Int -> Int) -> Set Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> G -> Set Int
forall g. Graph g => Int -> g -> Set Int
neighbors Int
v G
g) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Set Int -> [Int]
forall a. Set a -> [a]
Set.toList (Set Int -> [Int]) -> Set Int -> [Int]
forall a b. (a -> b) -> a -> b
$ G -> Set Int
forall g. Graph g => g -> Set Int
vertexes G
g
expand :: Partial -> Maybe (Map Vertex Int)
expand :: Partial -> Maybe (Map Int Int)
expand Partial{ labeling :: Partial -> Map Int Int
labeling = Map Int Int
lbls, remainingVertexes :: Partial -> [Int]
remainingVertexes = [] } = Map Int Int -> Maybe (Map Int Int)
forall a. a -> Maybe a
Just Map Int Int
lbls
expand Partial
p = Partial -> Int -> Set Int -> Maybe (Map Int Int)
labelVertex Partial
p' Int
v Set Int
ls
where (Int
v:[Int]
vs) = Partial -> [Int]
remainingVertexes Partial
p
ls :: Set Int
ls = Partial -> Set Int
remainingVertexLabels Partial
p
p' :: Partial
p' = Partial
p { remainingVertexes = vs }
labelVertex :: Partial -> Vertex -> Set Int -> Maybe (Map Vertex Int)
labelVertex :: Partial -> Int -> Set Int -> Maybe (Map Int Int)
labelVertex Partial
p Int
v Set Int
ls | Set Int -> Bool
forall a. Set a -> Bool
Set.null Set Int
ls = Maybe (Map Int Int)
forall a. Maybe a
Nothing
| Bool
disjoint = Partial -> Maybe (Map Int Int)
expand Partial
p' Maybe (Map Int Int) -> Maybe (Map Int Int) -> Maybe (Map Int Int)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Map Int Int)
next
| Bool
otherwise = Maybe (Map Int Int)
next
where l :: Int
l = Set Int -> Int
forall a. Set a -> a
Set.findMin Set Int
ls
e :: Maybe (Set Int)
e = Partial -> Int -> Int -> Maybe (Set Int)
edgeDiffs Partial
p Int
v Int
l
es :: Set Int
es = Partial -> Set Int
definiteEdgeDifferences Partial
p
disjoint :: Bool
disjoint = Bool -> (Set Int -> Bool) -> Maybe (Set Int) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Set Int -> Set Int -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.disjoint Set Int
es) Maybe (Set Int)
e
next :: Maybe (Map Int Int)
next = Partial -> Int -> Set Int -> Maybe (Map Int Int)
labelVertex Partial
p Int
v (Set Int -> Maybe (Map Int Int)) -> Set Int -> Maybe (Map Int Int)
forall a b. (a -> b) -> a -> b
$ Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
Set.delete Int
l Set Int
ls
p' :: Partial
p' = Partial
p { labeling = Map.insert v l $ labeling p
, remainingVertexLabels = Set.delete l $ remainingVertexLabels p
, definiteEdgeDifferences = Set.union es $ fromJust e
}
edgeDiffs :: Partial -> Vertex -> Int -> Maybe (Set Int)
edgeDiffs :: Partial -> Int -> Int -> Maybe (Set Int)
edgeDiffs Partial
p Int
v Int
l | Bool
bijected = Set Int -> Maybe (Set Int)
forall a. a -> Maybe a
Just Set Int
diffs
| Bool
otherwise = Maybe (Set Int)
forall a. Maybe a
Nothing
where ls :: Map Int Int
ls = Partial -> Map Int Int
labeling Partial
p
vs :: Set Int
vs = (Int -> Bool) -> Set Int -> Set Int
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Int -> Map Int Int -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map Int Int
ls) (Set Int -> Set Int) -> Set Int -> Set Int
forall a b. (a -> b) -> a -> b
$ Int -> G -> Set Int
forall g. Graph g => Int -> g -> Set Int
neighbors Int
v (G -> Set Int) -> G -> Set Int
forall a b. (a -> b) -> a -> b
$ Partial -> G
graph Partial
p
diffs :: Set Int
diffs = (Int -> Int) -> Set Int -> Set Int
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\Int
v' -> Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Map Int Int
ls Map Int Int -> Int -> Int
forall k a. Ord k => Map k a -> k -> a
! Int
v') Set Int
vs
bijected :: Bool
bijected = Set Int -> Int
forall a. Set a -> Int
Set.size Set Int
diffs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Set Int -> Int
forall a. Set a -> Int
Set.size Set Int
vs
isTree :: G -> Bool
isTree :: G -> Bool
isTree G
g = ((Int, Int) -> Bool) -> [(Int, Int)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Int
v,Int
v') -> [[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Int -> Int -> G -> [[Int]]
paths Int
v Int
v' G
g) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) [ (Int
v,Int
v') | Int
v <- [Int]
vs, Int
v' <- [Int]
vs, Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
v' ]
where vs :: [Int]
vs = Set Int -> [Int]
forall a. Set a -> [a]
Set.toList (Set Int -> [Int]) -> Set Int -> [Int]
forall a b. (a -> b) -> a -> b
$ G -> Set Int
forall g. Graph g => g -> Set Int
vertexes G
g
gracefulTree' :: G -> Maybe (Map Vertex Int)
gracefulTree' :: G -> Maybe (Map Int Int)
gracefulTree' G
g
| (Map Int Int
v:[Map Int Int]
_) <- [Map Int Int]
labelings = Map Int Int -> Maybe (Map Int Int)
forall a. a -> Maybe a
Just Map Int Int
v
| Bool
otherwise = Maybe (Map Int Int)
forall a. Maybe a
Nothing
where vs :: [Int]
vs = Set Int -> [Int]
forall a. Set a -> [a]
Set.toList (Set Int -> [Int]) -> Set Int -> [Int]
forall a b. (a -> b) -> a -> b
$ G -> Set Int
forall g. Graph g => g -> Set Int
vertexes G
g
candidates :: [Map Int Int]
candidates = ([Int] -> Map Int Int) -> [[Int]] -> [Map Int Int]
forall a b. (a -> b) -> [a] -> [b]
map ([(Int, Int)] -> Map Int Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Int, Int)] -> Map Int Int)
-> ([Int] -> [(Int, Int)]) -> [Int] -> Map Int Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Int] -> [Int] -> [(Int, Int)]) -> [Int] -> [Int] -> [(Int, Int)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..]) ([[Int]] -> [Map Int Int]) -> [[Int]] -> [Map Int Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [[Int]]
forall a. [a] -> [[a]]
permutations [Int]
vs
labelings :: [Map Int Int]
labelings = (Map Int Int -> Bool) -> [Map Int Int] -> [Map Int Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (G -> Map Int Int -> Bool
isGracefulLabeling G
g) [Map Int Int]
candidates
isGracefulLabeling :: G -> Map Vertex Int -> Bool
isGracefulLabeling :: G -> Map Int Int -> Bool
isGracefulLabeling G
g Map Int Int
ls = [Int]
diffs [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== [Int]
lbls
where diff :: Edge -> Int
diff (Edge (Int
u,Int
v)) = Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ (Map Int Int
ls Map Int Int -> Int -> Int
forall k a. Ord k => Map k a -> k -> a
! Int
u) Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Map Int Int
ls Map Int Int -> Int -> Int
forall k a. Ord k => Map k a -> k -> a
! Int
v)
diffs :: [Int]
diffs = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Edge -> Int) -> [Edge] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Edge -> Int
diff ([Edge] -> [Int]) -> [Edge] -> [Int]
forall a b. (a -> b) -> a -> b
$ Set Edge -> [Edge]
forall a. Set a -> [a]
Set.toList (Set Edge -> [Edge]) -> Set Edge -> [Edge]
forall a b. (a -> b) -> a -> b
$ G -> Set Edge
forall g. Graph g => g -> Set Edge
edges G
g
lbls :: [Int]
lbls = [Int
1..(Set Int -> Int
forall a. Set a -> Int
Set.size (G -> Set Int
forall g. Graph g => g -> Set Int
vertexes G
g) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]