module Tree
where
data Tree = Empty Int
| Pair Int Tree Tree
index :: Tree -> Int
index (Empty n) = n
index (Pair n _ _) = n
data Result = HasLeft
| HasRight
| HasBoth Int
| HasNeither
join :: Int -> Result -> Result -> Result
join _ (HasBoth k) _ = HasBoth k
join _ _ (HasBoth k) = HasBoth k
join _ HasNeither r = r
join _ r HasNeither = r
join k HasLeft HasRight = HasBoth k
join k HasRight HasLeft = HasBoth k
lca :: [Tree] -> Int -> Int -> Maybe Int
lca roots m n = answer (map ancestor roots)
where extend :: Tree -> Result -> Result
extend t = if index t == m then addLeft
else if index t == n then addRight
else id
where addLeft HasRight = HasBoth (index t)
addLeft HasNeither = HasLeft
addRight HasLeft = HasBoth (index t)
addRight HasNeither = HasRight
ancestor t@(Empty _) = extend t HasNeither
ancestor t@(Pair n left right) =
extend t (join n (ancestor left) (ancestor right))
answer :: [Result] -> Maybe Int
answer (HasBoth n : _) = Just n
answer (HasLeft : _) = Nothing
answer (HasRight : _) = Nothing
answer (HasNeither : results) = answer results
answer [] = Nothing
tree0, tree1 :: Tree
{-
0 1
/ \ / \
2 3 4 5
/ \ / \
6 7 8 9
/ \
10 11
-}
tree0 = Pair 0 two three
where two = Pair 2 six seven
three = Empty 3
six = Empty 6
seven = Pair 7 ten eleven
ten = Empty 10
eleven = Empty 11
tree1 = Pair 1 four five
where four = Empty 4
five = Pair 5 eight nine
eight = Empty 8
nine = Empty 9
forest :: [Tree]
forest = [tree0, tree1]
test = lca forest