Using Diagrams library in haskell (draw binary trees)

Question

I am trying to use the Haskell Diagrams library for drawing binary trees.

This is my tree type:

data Tree a = Empty
            | Node { label :: a, left,right :: Tree a }

leaf :: a -> Tree a
leaf a = Node a Empty Empty

This is a random tree:

t0 = Node 1 (Node 2 (leaf 3) (leaf 4))   (Node 5 (leaf 6) (leaf 7))

For drawing a circle with a char in the middle I am using this simple function (works fine):

diagNode :: String -> Diag

Here is my code to draw the binary tree:

diagTree :: Show s => Tree s -> Diag
diagTree Empty = diagNode "Empty"

diagTree (Node x Empty Empty) = connectOutside "X" "L" $
                                connectOutside "X" "R" $
          nx
          ===
      (nl ||| nr) # center
  where
    nx = named "X" ( diagNode (show x) )  
    nl = named "L" (diagNode "Empty" )
    nr = named "R" (diagNode "Empty" )  

diagTree (Node x left right) = connectOutside "X" "L" $
                               connectOutside "X" "R" $
          nx
          ===
      (nl ||| nr) # center
  where
    nx = named "X" ( diagNode (show x) ) 
    nl = named "L" (diagTree left )
    nr = named "R" (diagTree right )

You can see my code works only for the last "leafs", but it doesn't connect the upper nodes with the nodes below. I think the problem is, that I am calling diagTree recursively.

How can I fix this problem??

Answer 1

I think the problem is you're naming giving the inner nodes the same names so connectOutside connects the first names it finds (which happen to be the last nodes in your tree). You can solve this by giving each node a unique name depending on its position:

diagTree :: Show s => Tree s -> Diagram Rasterific
diagTree = go [] where
  go nm Empty        = diagNode  "Empty" # named nm
  go nm (Node x l r) = 
    connectOutside nm nmL .
    connectOutside nm nmR $
          nx
          ===
      (nl ||| nr) # centerX
    where
      (nmL, nmR) = ('L':nm, 'R':nm)
      nx = diagNode (show x) # named nm 
      nl = go nmL l # named nmL
      nr = go nmR r # named nmR

with

data Tree a = Empty
            | Node { label :: a, left,right :: Tree a }
  deriving Show

leaf :: a -> Tree a
leaf a = Node a Empty Empty

diagNode :: String -> Diagram Rasterific
diagNode txt = text txt # fontSizeL 0.4 <> circle 1 & pad 2

I get