# CIS 194 - UPenn Haskell Course (2013) - Homework 4 - Tree Folding

I have been self studying the UPenn Haskell course, and I am unable to get feedback/grading on the assignments complete. This specific portion that I am having concerns with asks to write a function foldTree :: [a] -> Tree a that generates a balanced binary tree from the given list. I have not done this to check the other homework assignments, but some weird properties of my code made me want to come and check if it is correct. The weird property is the # of elements in my complete and FULLY balanced binary trees; they are the numbers in the Ulam sequence (A081026). This seemed completely counterintuitive to me, so I want to make sure I have correctly coded the generation and examination of these trees.

module Assignment4 where
data Tree a = Leaf
| Node Integer (Tree a) a (Tree a)
deriving (Show, Eq)

fun1 :: [Integer] -> Integer
fun1 [] = 1
fun1 (x:xs)
| even x = (x - 2) * fun1 xs
| otherwise = fun1 xs

fun1rewrite :: [Integer] -> Integer
fun1rewrite xs =foldr (\x y -> (x-2)*y) 1 (filter even xs)

fun2 :: Integer -> Integer
fun2 1 = 0
fun2 n
| even n = n + fun2 (n div 2)
| otherwise = fun2 (3 * n + 1)

fun2rewrite :: Integer -> Integer
fun2rewrite = sum . filter (even) . takeWhile (/= 1) . iterate hailstone
{- Iterates hailstone because fun2 is repeatedly applies
Takewhile because fun1 1 = 0, and 0 is identity for +
filters out the odd numbers because only evens are summed abd 3*odd + 1 is always even
sums because even n is n + rest of series
-}

hailstone :: Integer -> Integer
hailstone x
| even x = x div 2
| odd x = 3*x + 1

xor :: [Bool] -> Bool
xor xs = foldr (/=) False (filter (== True) xs)

map' :: (a -> b) -> [a] -> [b]
map' f xs= foldr (\x y -> f(x):y) [] xs

sieveSundaram :: Integer -> [Integer]
sieveSundaram x = map (\x -> 2 * x + 1) (filter (notElem arr) ltX)
where
arr = [i + j + 2 * i * j | i <- [1 .. x], j <- [1 .. x], i <= j, i + j + 2 * i * j <= x]
ltX = [1 .. x - 1]

isPrime :: Integer -> Bool
isPrime x = 0 notElem divArr
where
divArr = [x mod k | k <- [2 .. x - 1]]

foldTree :: [a] -> Tree a
foldTree (x:xs) = foldr binaryInsert (Node 0 Leaf x Leaf) xs

getHeight :: Tree a -> Integer
getHeight (Node a _ _ _) = a
getHeight Leaf = 0

sameHeight :: Tree a -> Tree a -> Bool
sameHeight x y = getHeight x == getHeight y

almostSameHeight :: Tree a -> Tree a -> Bool
almostSameHeight x y = abs (getHeight x - getHeight y) <= 1

degreesOfBalanced :: Tree a -> (Tree a -> Tree a -> Bool) -> Bool
degreesOfBalanced Leaf _ = True
degreesOfBalanced (Node _ lChild _ rChild) comparator = comparator lChild rChild && subtreeComparison
where
subtreeComparison = degreesOfBalanced lChild comparator && degreesOfBalanced rChild comparator

isBalanced :: Tree a -> Bool
isBalanced tree = degreesOfBalanced tree sameHeight

isAlmostBalanced :: Tree a -> Bool
isAlmostBalanced tree = degreesOfBalanced tree almostSameHeight

hasLeaf :: Tree a -> Bool
hasLeaf (Node a Leaf _ _) = True
hasLeaf (Node a _ _ Leaf) = True
hasLeaf _ = False

isLeaf :: Tree a -> Bool
isLeaf Leaf = True
isLeaf _ = False

replaceLeaf :: Tree a -> a -> Tree a
replaceLeaf (Node 0 Leaf nodeVal Leaf) val = Node 1 (Node 0 Leaf val Leaf) nodeVal Leaf
replaceLeaf node@(Node height lChild nodeVal rChild) val
| isLeaf lChild = Node height (Node 0 Leaf val Leaf) nodeVal rChild
| isLeaf rChild = Node height lChild nodeVal (Node 0 Leaf val Leaf)
| otherwise = node

binaryInsert :: a -> Tree a -> Tree a
binaryInsert value Leaf = Node 0 Leaf value Leaf
binaryInsert value node@(Node height lChild nodeVal rChild)
| hasLeaf node = replaceLeaf node value
| not (isBalanced lChild) = Node newHeightL insertedLeft nodeVal rChild
| not (isBalanced rChild) = Node newHeightR lChild nodeVal insertedRight
| isBalanced node = Node newHeightL insertedLeft nodeVal rChild
| otherwise =
if getHeight lChild < getHeight rChild
then Node newHeightL insertedLeft nodeVal rChild
else Node newHeightR lChild nodeVal insertedRight
where
insertedLeft = binaryInsert value lChild
insertedRight = binaryInsert value rChild
newHeightL = max (getHeight insertedLeft) (getHeight rChild) + 1
newHeightR = max (getHeight insertedRight) (getHeight lChild) + 1

testTree =
Node
3
(Node 2 (Node 0 Leaf 'F' Leaf) 'I' (Node 1 (Node 0 Leaf 'B' Leaf) 'C' Leaf))
'J'
(Node 2 (Node 1 (Node 0 Leaf 'A' Leaf) 'G' Leaf) 'H' (Node 1 (Node 0 Leaf 'D' Leaf) 'E' Leaf))

main :: IO()
main = print (filter (snd) (map (\x -> (x, isBalanced (foldTree [1 .. x]))) [1 .. 1000]))


I'd also love feedback on the style of it! The PDF of the assignment is here.

• Welcome to Code Review. Just to be sure: to your best knowledge, the code works? Also, you wrote about your concerns, but not what your code is supposed to do.
– Zeta
Feb 5 '18 at 6:10
• @Zeta Sorry about that! As far as I know, with the functions I've written, the trees are generated from the list provided, and they are balanced. I'll edit in what the purpose is. Feb 9 '18 at 2:56
• Agh, I'm sorry, I completely forgot about the post. You have several functions included that don't really fit the Tree aspect. You included them in revision 3. Was this on purpose or a mistake?
– Zeta
Mar 30 '18 at 20:51