{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}

{- |
Description: Graceful tree labeling
Copyright: Copyright (C) 2023 Yoo Chung
License: GPL-3.0-or-later
Maintainer: dev@chungyc.org

Some solutions to "Problems.P92" of Ninety-Nine Haskell "Problems".
-}
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

{- | Gracefully label a tree graph.

This implementation builds up a partial graceful labeling, adding one vertex at a time.
It gives up and tries another if a partial labeling cannot be extended.
-}
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
                    }

-- | A partial graceful labeling of a tree graph and associate state for building it up.
data Partial = Partial
  { Partial -> G
graph                   :: G               -- ^ Tree to label gracefully
  , Partial -> Map Int Int
labeling                :: Map Vertex Int  -- ^ Partial labeling of vertexes
  , Partial -> [Int]
remainingVertexes       :: [Vertex]        -- ^ Vertexes remaining to be labeled
  , Partial -> Set Int
remainingVertexLabels   :: Set Int         -- ^ Set of labels yet to be used with vertexes
  , Partial -> Set Int
definiteEdgeDifferences :: Set Int         -- ^ Set of differences already determined for edges
  }

-- | Trying vertexes with higher degrees first might constrain labeling more,
-- i.e, prune the search space more.
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

-- | Label one more vertex.
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 }

-- | Try labeling a particular vertex with the given label candidates.
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  -- choose label to try arbitrarily
        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
               }

-- | Gather the absolute differences between vertexes in the edge connected to the given vertex.
-- The given vertex would not have been labeled, so this cannot be double-counted.
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

{- | Gracefully label a tree graph.

This implementation tries all permutations of vertex labels
and checks if any are a graceful labeling.
-}
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)]