Print Binary Search Tree in a tree like structure in Haskell - haskell

Question

I created a binary search tree and tried to print the binary search tree with this instance
data Tree a = Nil | Node (Tree a) a (Tree a)
instance Show a => Show (Tree a) where
show t = intercalate "\n" (map snd (draw t))
draw :: Show a => Tree a -> [(Int,String)]
draw Nil = [(1,"*")]
draw (Node Nil x Nil) = [(1,show x)]
draw (Node tl x tr) = zip (repeat 0) (map shiftl (draw tl)) ++ [(1,show x ++ "-+")] ++ zip (repeat 2) (map shiftr (draw tr)) where
shiftl (0,x) = spaces ++ " " ++ x
shiftl (1,x) = spaces ++ "+-" ++ x
shiftl (2,x) = spaces ++ "| " ++ x
shiftr (0,x) = spaces ++ "| " ++ x
shiftr (1,x) = spaces ++ "+-" ++ x
shiftr (2,x) = spaces ++ " " ++ x
spaces = replicate (length (show x)+1) ' '
createTree :: [a] -> BTree a
createTree [] = Nil
createTree xs = Node
(createTree front) x (createTree back) where
n = length xs
(front, x:back) = splitAt (n `div` 2) xs
Now I want to print it horizontally, which i am not able to do so. I want to print the binary search tree like this picture below. (Sorry for the low quality of the picture but you get the idea). How can i do it ?
Use the sample example [1..50]
UPDATE ANSWER :-
I found my answer myself. I created one function that shows like that. The code is in the comments.
If you have an other solution please share

Answer 1

Here's my solution. It's might not be perfect. It prints Nil nodes as a *.
The basic idea is to first get the visualizations of the left and right trees as two lists of strings. Then they are zipped using concatenation to produce a list of strings representing the two trees side-by-side.
instance Show a => Show (Tree a) where
show tree =
let (s, _) = show' tree
in intercalate "\n" s
where
show' :: Show a => Tree a -> ([String], Int)
show' Nil = (["*"], 0)
show' (Node ltree value rtree) = (ashow, acenter)
where
-- middle_padding_length = 1
-- middle_padding = replicate (2*middle_padding_length+1) ' '
middle_padding = " "
pwidth = length middle_padding
lshow, rshow :: [String]
lcenter, rcenter :: Int
(lshow, lcenter) = show' ltree
(rshow, rcenter) = show' rtree
lwidth, rwidth :: Int
lwidth = length (head lshow)
rwidth = length (head rshow)
awidth, acenter :: Int
awidth = lwidth + length middle_padding + rwidth
acenter = lwidth + pwidth `div` 2
-- Put subtrees side by side with some padding
sshow :: [String]
sshow =
zipWith (\s1 s2 -> s1 ++ middle_padding ++ s2)
(extend_depth lwidth lshow)
(extend_depth rwidth rshow)
where
extend_depth twidth tshow =
let
sdepth = max (length lshow) (length rshow)
in
tshow ++ replicate (sdepth - length tshow) (replicate twidth ' ')
vshow :: String
vshow =
let
text = show value
textWidth = length text
whitespaceWidth = awidth - textWidth
leftPadding = acenter - textWidth `div` 2
rightPadding = whitespaceWidth - leftPadding
in
replicate leftPadding ' ' ++ text ++ replicate rightPadding ' '
row :: [Char] -> String
row [lc, mc, rc, hc, sc] =
replicate lcenter sc ++ [lc] ++ replicate (acenter-lcenter-1) hc ++
[mc] ++
replicate (lwidth+pwidth+rcenter-acenter-1) hc ++ [rc] ++ replicate (awidth-lwidth-pwidth-rcenter-1) sc
row _ = error "incorrect number of characters"
two_pipes, splitter, one_pipe :: String
two_pipes = row "| | "
splitter = row "/^\\- "
one_pipe = row " | "
ashow :: [String]
ashow =
vshow :
one_pipe :
splitter :
two_pipes :
sshow
Output for createTree [0..10]:

Answer 2

I found my answer myself. I created one function that shows like that. Here is the code
import Data.List (intercalate)
data BTree a = Nil | Node (BTree a) a (BTree a) deriving Eq
-- Instances of BST
instance Show a => Show (BTree a) where
show t = "\n" ++ intercalate "\n" (map (map snd) (fst $ draw5 t)) ++ "\n"
-- End of instances
data Tag = L | M | R deriving (Eq,Show)
type Entry = (Tag, Char)
type Line = [Entry]
--the tag thing is for my own understanding that do no work here.
createTree :: [a] -> BTree a
createTree [] = Nil
createTree xs = Node
(createTree front) x (createTree back) where
n = length xs
(front, x:back) = splitAt (n `div` 2) xs
-- my own draw
draw5 :: Show a => BTree a -> ([Line],(Int,Int,Int))
draw5 Nil = ([zip [M] "*"],(0,1,0) )
draw5 (Node Nil x Nil) =
let (sx,n,m) = (show x, length sx, n `div` 2) in
([zip (replicate m L ++ [M] ++ replicate (n-m-1) R) sx], (m,1,n-m-1))
draw5 (Node tl x tr) = (l1:l2:l3:l4:mainline,(a,b,c)) where
(mainline ,(a,b,c)) = drawing xs ys
(xs,(xsa,xsb,xsc)) = draw5 tl
(ys,(ysa,ysb,ysc)) = draw5 tr
drawing xs ys = (join xs ys, (xsa+xsb+xsc+1, 1, ysa+ysb+ysc+1) )
join (as:ass) (bs:bss) = go as bs : join ass bss
join xss [] = map (++ ([(L,' '),(M, ' '),(R,' ')] ++ replicate (ysa+ysb+ysc) (R,' ') )) xss
join [] yss = map ((replicate (xsa+xsb+xsc) (L,' ') ++ [(L,' '),(M, ' '),(R,' ')]) ++ ) yss
go xss yss = xss ++ [(L,' '),(M, ' '),(R,' ')] ++ yss
([cs],(m,n,o)) = draw5 (Node Nil x Nil)
l1 = replicate (a-m) (L,' ') ++ cs ++ replicate (c-o) (R,' ')
l2 = replicate a (L,' ') ++ [(M, '|')] ++ replicate c (R,' ')
l3 = replicate xsa (L,' ') ++ [(L,'+')] ++ replicate (xsc+1) (L,'-') ++ [(M,'+')] ++ replicate (ysa+1) (R,'-') ++ [(R,'+')] ++ replicate ysc (R,' ')
l4 = replicate xsa (L,' ') ++ [(L,'|')] ++ replicate (xsc+ysa+3) (M,' ') ++ [(R,'|')] ++ replicate ysc (R,' ')