Haskell API for manipulating Tree/Forest

Question

I'm experimenting how a Relation (a cartesian product's subset) can be implemented in Haskell using different data classes.

Forest and Tree allow to keeps together in a single data structure different relations each one of different n-arity.

This set of functions require only the Eq constraint and a simple Normal Form. (The two show functions require the additional Show constraint.)

The examples allow to quick test the functions.

module RelationT
    (isTreeInNormalForm
    ,isForestInNormalForm
    ,toTreeNormalForm
    ,toForestNormalForm
    ,equTrees
    ,equForests
    ,unionOfTwoTrees
    ,unionOfTwoForests
    ,unionOfForests
    ,addTreeToTree
    ,addForestToTree
    ,addForestToForest
    ,addTreeToForest
    ,appendTreeToTree
    ,appendForestToTree
    ,appendForestToForest
    ,growthTree
    ,growthForest
    ,fmapLeafsOfTree
    ,fmapLeafsOfForest
    ,showF
    ,showT) where

import Data.Tree
import Data.List

-- -------------------- CAVEAT --------------------

-- Forests and subforests must be in NORMAL FORM.
-- (Node values of th same level must all be different.)

-- ============================== NORMAL FORM ==============================

-- Each tree and forest must result True.

isTreeInNormalForm :: Eq a => Tree a -> Bool
isTreeInNormalForm (Node _ subforest) = isForestInNormalForm subforest

isForestInNormalForm :: Eq a => Forest a -> Bool
isForestInNormalForm [] = True
isForestInNormalForm [Node _ subfrst] = isForestInNormalForm subfrst
isForestInNormalForm (Node x _ : ndxs) =
    let (oks,others) = partition  (\(Node w _) -> w == x) ndxs
    in case oks of
      [] -> isForestInNormalForm others
      _   -> False

-- "Fusion" of the nodes in the same level that have the same value 

toTreeNormalForm :: Eq a => Tree a -> Tree a 
toTreeNormalForm (Node x subforest) = Node x $ toForestNormalForm subforest

toForestNormalForm :: Eq a => Forest a -> Forest a
toForestNormalForm [] = []
toForestNormalForm [Node x subfrst] = [Node x (toForestNormalForm subfrst)]
toForestNormalForm (Node x subfrst : ndxs) = 
    let (oks,others) = partition  (\(Node w _) -> w == x) ndxs
    in if null oks
       then Node x (toForestNormalForm subfrst) : toForestNormalForm others
       else Node x (unionOfForests $ map (\(Node _ subf) -> subf) oks) : toForestNormalForm others

-- ============================== EQUIVALENCE ==============================

-- Forests and subforests are CONSIDERED equivalent if differs only by the order of nodes in the same level.

equTrees :: Eq a => Tree a -> Tree a -> Bool
equTrees (Node x subfrstX) (Node y subfrstY)
  | x == y = equForests subfrstX subfrstY
  | otherwise = False

equForests :: Eq a => Forest a -> Forest a -> Bool 
equForests [] [] = True
equForests [] _ = False
equForests _ [] = False
equForests (Node x subfrstX : ndxs) ndys =
    let (oks,others) = partition  (\(Node w _) -> w == x) ndys
    in case oks of
      []  -> False
      [Node _ subfrstZ] -> equForests subfrstX subfrstZ && equForests ndxs others
      _   -> error "NOT in Normal Form"

-- ============================== COMBINE ==============================

unionOfTwoTrees :: Eq a => Tree a -> Tree a -> [Tree a]
unionOfTwoTrees nd (Node _ []) = [nd]
unionOfTwoTrees (Node _ []) nd = [nd]
unionOfTwoTrees ndx@(Node x subforestX) ndy@(Node y subforesty)
  | x == y = [Node x (unionOfTwoForests subforestX subforesty)]
  | otherwise = [ndx, ndy]

unionOfTwoForests :: Eq a => [Tree a] -> [Tree a] -> [Tree a]
unionOfTwoForests [] frst = frst
unionOfTwoForests frst [] = frst
unionOfTwoForests  (ndy@(Node y subfrstY) : ndys) ndxs = 
    let (oks,others) = partition  (\(Node w _) -> w == y) ndxs
    in case oks of
      []  -> ndy : unionOfTwoForests ndys others
      [Node z subfrstZ] -> Node z (unionOfTwoForests subfrstY subfrstZ) :  unionOfTwoForests ndys others
      _   -> error "NOT in Normal Form"

unionOfForests :: (Foldable t, Eq a) => t [Tree a] -> [Tree a]      
unionOfForests frsts = foldr unionOfTwoForests [] frsts

-- -------------------- Addition --------------------

-- Addition is non-commutative.
-- The first tree is "added" to the second only if the "root" values are the same.
-- The following functions behaves similarly.

addTreeToTree :: Eq a => Tree a -> Tree a -> Tree a
addTreeToTree (Node _ []) nd = nd
addTreeToTree (Node y subfrstY) ndx@(Node x [])
  | y == x = Node x subfrstY
  | otherwise = ndx
addTreeToTree (Node y subfrstY) ndx@(Node x subfrstX)
  | y == x = Node x $ addForestToForest subfrstY subfrstX
  | otherwise = ndx

addTreeToForest :: Eq a => Tree a -> [Tree a] -> [Tree a]
addTreeToForest (Node _ []) frst = frst
addTreeToForest _ [] = []
addTreeToForest ndy@(Node y _) frst =
    let (oks,others) = partition  (\(Node w _) -> w == y) frst
    in case oks of
      []  -> frst
      [ndz] -> addTreeToTree ndz ndy : others
      _   -> error "The forest is NOT in Normal Form"

addForestToTree :: Eq a => [Tree a] -> Tree a -> Tree a
addForestToTree [] nd = nd
addForestToTree ndys nd@(Node x subforestX) = 
    case filter (\(Node w _) -> w == x) ndys of
      [] -> nd
      [Node _ subfrstZ] -> Node x $ appendForestToForest subfrstZ subforestX
      _   -> error "The forest is NOT in Normal Form"

addForestToForest :: Eq a => [Tree a] -> [Tree a] -> [Tree a]
addForestToForest [] frst = frst
addForestToForest _ [] = []  -- !!!
addForestToForest (Node y subfrstY : ndys) ndxs = 
    let (oks,others) = partition  (\(Node w _) -> w == y) ndxs
    in case oks of
      []  -> addForestToForest ndys ndxs
      [Node z subfrstZ] -> Node z (unionOfTwoForests subfrstY subfrstZ) :  addForestToForest ndys others
      _   -> error "The second forest is NOT in Normal Form"

-- -------------------- Append --------------------

-- Thees functions appends trees or forests to the leaves of the target forest.
-- For each target leaf the condition is that the value of the leaf have to be equal to the value of the "root" of what would be appended.

appendTreeToTree :: Eq a => Tree a -> Tree a -> Tree a
appendTreeToTree (Node _ []) nd = nd
appendTreeToTree (Node y subfrstY) ndx@(Node x [])
  | y == x = Node x subfrstY
  | otherwise = ndx
appendTreeToTree ndy (Node x subfrstX) = Node x $ map (\nd -> appendTreeToTree ndy nd) subfrstX

appendForestToTree :: Eq a => [Tree a] -> Tree a -> Tree a 
appendForestToTree [] nd = nd
appendForestToTree frst ndx@(Node x []) =
    case filter (\(Node y _) -> y == x) frst of
        []  -> ndx
        [Node _ subforest] -> Node x subforest
        _ -> error "The forest is NOT in Normal Form"     
appendForestToTree frst (Node x subforestX) = Node x $ appendForestToForest frst subforestX

appendForestToForest :: Eq a => [Tree a] -> [Tree a] -> [Tree a]      
appendForestToForest [] frst = frst
appendForestToForest frst [] = frst
appendForestToForest frstY  frstX = map (\ndx -> appendForestToTree frstY ndx) frstX

-- ============================== CONSTRUCTION ==============================

-- These functions can selectively add nodes to the leaves of the target.

growthTree :: (t -> Forest t) -> Tree t -> Tree t
growthTree f (Node x []) = Node x (f x)
growthTree f (Node x subfrst) = Node x $ growthForest f subfrst

growthForest :: (t -> Forest t) -> [Tree t] -> [Tree t]
growthForest f [] = []
growthForest f frst = map (growthTree f) frst

-- ============================== LEAF'S VALUE MODIFICATION ==============================

-- Thees functions nodify only the leaves of the target.

fmapLeafsOfTree :: (a -> a) -> Tree a -> Tree a
fmapLeafsOfTree f (Node x []) = Node (f x) []
fmapLeafsOfTree f (Node x subfrst) = Node x $ fmapLeafsOfForest f subfrst

fmapLeafsOfForest :: (a -> a) -> Forest a -> Forest a
fmapLeafsOfForest f [] =  []
fmapLeafsOfForest f frst = map (fmapLeafsOfTree f) frst

-- ============================== PRETTY PRINT ==============================

-- Functions that are useful for values other than strings.

showF :: Show a => [Tree a] -> IO ()
showF = putStr . drawForest . map (fmap show)

showT :: Show a => Tree a -> IO ()
showT = putStr . drawTree . fmap show

-- ============================== EXAMPLES ==============================

tr1 = Node "John" [Node "friends" [Node "John" [], Node "Sally"[]]
                   ,Node "cars" [Node "Laputa" [], Node "Pinto"[]]
                   ,Node "motorbikes" [Node "Thunderbird"[]]]

tr2 = Node "Mary" [Node "motorbikes" [Node"Varadero" []]
                  ,Node "past holidays" [Node "Rome" [],Node "Sydney" []]]

tr3 = Node "John" [Node "motorbikes" [Node"Vespa" []]
                  ,Node "past holidays" [Node "Rome" [],Node "Paris" []]]

tr4 = Node "John" [Node "friends" [Node "Mary" [], Node "Rick"[]]
                  ,Node "past holidays" [Node "Rome" [], Node "London" []]]

tr5 = Node "Frank" [Node "home" [Node "New York" []]]

tr6 = Node "Sally" [Node "phone numbers" [Node "345-25-33" [], Node "898-38-234" []]]

tr7 = Node "Rose"  [Node "phone numbers" [Node "525-33-425" []]]

tr8 = Node "Thunderbird" [Node "manufacturing company" [Node "Triumph Engineering"[]]]

tr9 = Node "Varadero" [Node "manufacturing company" [Node "Honda" []]]

fr1 = [tr1, tr2]

fr2 = [tr4, tr5]

fr3 = [tr6, tr7]

fr4 = [tr8,tr9]

-------------------------

ex1 = showF $ unionOfTwoForests fr1 fr2
ex2 = showF $ unionOfTwoForests fr1 fr2
ex3 = showF $ unionOfForests [fr1,fr2,fr3,fr4]

ex4 = showF $ addForestToForest fr2 fr1
ex5 = showF $ addForestToForest fr1 fr2

ex6 = showF $ appendForestToForest fr4 fr1
ex7 = showF $ appendForestToForest fr3 fr1

ex10 = showF $ appendForestToForest (unionOfForests [fr3,fr4]) (unionOfForests [fr1,fr2])
ex11 = showF $ appendForestToForest (unionOfForests [fr3,fr4]) (unionOfForests [fr1,fr2,fr3,fr4])

countryOf x = case x of
    "Rome"  -> [Node "country" [Node "Italy" []]]
    "Paris" -> [Node "country" [Node "France" []]]
    _       -> []

ex20 = showT $ growthTree countryOf tr3

Answer 1

It looks like you might need some more testing. The function isForestInNormalForm is wrong, since it thinks the following forest is in normal form:

badfr1 = [Node "x" [Node "y" [], Node "y" []], Node "z" []]

and the function toForestNormalForm is wrong since if you apply it to:

badfr2 = [Node "x" [Node "y" [], Node "y" []], Node "x" [], Node "z" []]

you get a normalized forest with no "y" nodes.

In general, a recursive function on a list structure that handles the singleton case specially:

foo [] = ...
foo [x] = ...
foo (x:xs) = ...

increases the change of making an error. In both of these broken functions, you are mishandling x in the (x:xs) case (forgetting to recurse in isForestInFormalForm, and forgetting it entirely in the else branch of your toForestNormalForm).

For isForestInNormalForm, you should be able to drop the singleton case entirely and move its check into the general recursive case:

isForestInNormalForm :: Eq a => Forest a -> Bool
isForestInNormalForm [] = True
isForestInNormalForm (Node x f : ndxs) =
    let (dups,others) = partition  (\(Node w _) -> w == x) ndxs
    in case dups of
      [] -> isForestInNormalForm f && isForestInNormalForm others
      _   -> False

However, partition isn't really necessary here. You just want to know if there are any duplicates. If there aren't then ndxs and others are equal anyway, so you don't need partition to create others. This gives an even clearer version:

isForestInNormalForm :: Eq a => Forest a -> Bool
isForestInNormalForm [] = True
isForestInNormalForm (Node x f : ndxs) =
  if any (\(Node w _) -> w == x) ndxs
  then False
  else isForestInNormalForm f && isForestInNormalForm ndxs

or simplified to:

isForestInNormalForm :: Eq a => Forest a -> Bool
isForestInNormalForm [] = True
isForestInNormalForm (Node x f : ndxs) =
  all (\(Node w _) -> w /= x) ndxs && isForestInNormalForm f && isForestInNormalForm ndxs

But I favor writing a version that more directly implements the definition: a forest is in normal form if there are no duplicates in its top-most labels and all of the subtrees is in normal form. (At least, I think that's the definition you intend.) You can do this by first checking for duplicates and then recursively making sure the subtrees are in normal form:

isForestInNormalForm' :: Eq a => Forest a -> Bool
isForestInNormalForm' ts
  = noDuplicates (map rootLabel ts) && all isTreeInNormalForm ts

You can write a noDuplicates that requires only Eq using nub:

noDuplicates :: Eq a => [a] -> Bool
noDuplicates xs = nub xs == xs