1 Trees

-- # Software Tools for Discrete Mathematics

module Stdm05Trees where

-- # Chapter 5.  Trees

data Tree a
  = Tip
  | Node a (Tree a) (Tree a)
  deriving (Show)

-- |
-- >>>
t1 :: Tree Int
t1 = Node 6 Tip Tip

-- |
-- >>>
t2 :: Tree Int
t2 =
  Node
    5
    (Node 3 Tip Tip)
    (Node 8 (Node 6 Tip Tip) (Node 12 Tip Tip))

-- |
-- >>>
nodeCount :: Tree a -> Int
nodeCount Tip = 0
nodeCount (Node x t1 t2) = 1 + nodeCount t1 + nodeCount t2

-- |
-- >>>
reflect :: Tree a -> Tree a
reflect Tip = Tip
reflect (Node a t1 t2) = Node a (reflect t2) (reflect t1)

-- |
-- >>>
mapTree :: (a -> b) -> Tree a -> Tree b
mapTree f Tip = Tip
mapTree f (Node a t1 t2) =
  Node (f a) (mapTree f t1) (mapTree f t2)

-- |
-- >>>
tree :: Tree (Int, Int)
tree =
  Node
    (5, 10)
    ( Node
        (3, 6)
        (Node (1, 1) Tip Tip)
        (Node (4, 8) Tip Tip)
    )
    ( Node
        (7, 14)
        (Node (6, 12) Tip Tip)
        (Node (8, 16) Tip Tip)
    )

-- |
-- >>>
find :: Int -> Tree (Int, a) -> Maybe a
find n Tip = Nothing
find n (Node (m, d) t1 t2) =
  if n == m
    then Just d
    else
      if n < m
        then find n t1
        else find n t2

module HL07IAR where

import Data.List
import HL04STAL (display)

sumOdds' :: Integer -> Integer
sumOdds' n = sum [2 * k - 1 | k <- [1 .. n]]

sumOdds :: Integer -> Integer
sumOdds n = n ^ 2

sumEvens' :: Integer -> Integer
sumEvens' n = sum [2 * k | k <- [1 .. n]]

sumEvens :: Integer -> Integer
sumEvens n = n * (n + 1)

sumInts :: Integer -> Integer
sumInts n = (n * (n + 1)) `div` 2

sumSquares' :: Integer -> Integer
sumSquares' n = sum [k ^ 2 | k <- [1 .. n]]

sumSquares :: Integer -> Integer
sumSquares n = (n * (n + 1) * (2 * n + 1)) `div` 6

sumCubes' :: Integer -> Integer
sumCubes' n = sum [k ^ 3 | k <- [1 .. n]]

sumCubes :: Integer -> Integer
sumCubes n = (n * (n + 1) `div` 2) ^ 2

-- Z is Zero
-- S is Successor
data Natural = Z | S Natural
  deriving (Eq, Show)

plus m Z = m
plus m (S n) = S (plus m n)

m `mult` Z = Z
m `mult` (S n) = (m `mult` n) `plus` m

expn m Z = (S Z)
expn m (S n) = (expn m n) `mult` m

leq Z _ = True
leq (S _) Z = False
leq (S m) (S n) = leq m n

geq m n = leq n m

gt m n = not (leq m n)

lt m n = gt n m

foldn :: (a -> a) -> a -> Natural -> a
foldn h c Z = c
foldn h c (S n) = h (foldn h c n)

exclaim :: Natural -> String
exclaim = foldn ('!' :) []

bittest :: [Int] -> Bool
bittest [] = True
bittest [0] = True
bittest (1 : xs) = bittest xs
bittest (0 : 1 : xs) = bittest xs
bittest _ = False

fib 0 = 0
fib 1 = 1
fib n = fib (n - 1) + fib (n - 2)

fib' n = fib2 0 1 n
  where
    fib2 a b 0 = a
    fib2 a b n = fib2 b (a + b) (n - 1)

data BinTree = L | N BinTree BinTree deriving (Show)

makeBinTree :: Integer -> BinTree
makeBinTree 0 = L
makeBinTree n = N (makeBinTree (n - 1)) (makeBinTree (n - 1))

count :: BinTree -> Integer
count L = 1
count (N t1 t2) = 1 + count t1 + count t2

depth :: BinTree -> Integer
depth L = 0
depth (N t1 t2) = (max (depth t1) (depth t2)) + 1

balanced :: BinTree -> Bool
balanced L = True
balanced (N t1 t2) =
  (balanced t1)
    && (balanced t2)
    && depth t1 == depth t2

data Tree = Lf | Nd Int Tree Tree deriving (Show)

data Tr a = Nil | T a (Tr a) (Tr a) deriving (Eq, Show)

type Dict = Tr (String, String)

split :: [a] -> ([a], a, [a])
split xs = (ys1, y, ys2)
  where
    ys1 = take n xs
    (y : ys2) = drop n xs
    n = length xs `div` 2

data LeafTree a
  = Leaf a
  | Node (LeafTree a) (LeafTree a)
  deriving (Show)

ltree :: LeafTree String
ltree =
  Node
    (Leaf "I")
    ( Node
        (Leaf "love")
        (Leaf "you")
    )

data Rose a = Bud a | Br [Rose a] deriving (Eq, Show)

rose = Br [Bud 1, Br [Bud 2, Bud 3, Br [Bud 4, Bud 5, Bud 6]]]

len [] = 0
len (x : xs) = 1 + len xs

cat :: [a] -> [a] -> [a]
cat [] ys = ys
cat (x : xs) ys = x : (cat xs ys)

add :: [Natural] -> Natural
add = foldr plus Z

mlt :: [Natural] -> Natural
mlt = foldr mult (S Z)

ln :: [a] -> Natural
ln = foldr (\_ n -> S n) Z

rev :: [a] -> [a]
rev = foldl (\xs x -> x : xs) []

rev' :: [a] -> [a]
rev' = foldr (\x xs -> xs ++ [x]) []

data Peg = A | B | C

type Tower = ([Int], [Int], [Int])

move :: Peg -> Peg -> Tower -> Tower
move A B (x : xs, ys, zs) = (xs, x : ys, zs)
move B A (xs, y : ys, zs) = (y : xs, ys, zs)
move A C (x : xs, ys, zs) = (xs, ys, x : zs)
move C A (xs, ys, z : zs) = (z : xs, ys, zs)
move B C (xs, y : ys, zs) = (xs, ys, y : zs)
move C B (xs, ys, z : zs) = (xs, z : ys, zs)

transfer :: Peg -> Peg -> Peg -> Int -> Tower -> [Tower]
transfer _ _ _ 0 tower = [tower]
transfer p q r n tower =
  transfer p r q (n - 1) tower
    ++ transfer r q p (n - 1) (move p q tower')
  where
    tower' = last (transfer p r q (n - 1) tower)

hanoi :: Int -> [Tower]
hanoi n = transfer A C B n ([1 .. n], [], [])

check :: Int -> Tower -> Bool
check 0 t = t == ([], [], [])
check n (xs, ys, zs)
  | xs /= [] && last xs == n = check (n - 1) (init xs, zs, ys)
  | zs /= [] && last zs == n = check (n - 1) (ys, xs, init zs)
  | otherwise = False

maxT :: Tower -> Int
maxT (xs, ys, zs) = foldr max 0 (xs ++ ys ++ zs)

checkT :: Tower -> Bool
checkT t = check (maxT t) t

parity :: Tower -> (Int, Int, Int)
parity (xs, ys, zs) = par (xs ++ [n + 1], ys ++ [n], zs ++ [n + 1])
  where
    n = maxT (xs, ys, zs)
    par (x : xs, y : ys, z : zs) = (mod x 2, mod y 2, mod z 2)

target :: Tower -> Peg
target t@(xs, ys, zs)
  | parity t == (0, 1, 1) = A
  | parity t == (1, 0, 1) = B
  | parity t == (1, 1, 0) = C

move1 :: Tower -> Tower
move1 t@(1 : _, ys, zs) = move A (target t) t
move1 t@(xs, 1 : _, zs) = move B (target t) t
move1 t@(xs, ys, 1 : _) = move C (target t) t

move2 :: Tower -> Tower
move2 t@(1 : xs, [], zs) = move C B t
move2 t@(1 : xs, ys, []) = move B C t
move2 t@(1 : xs, ys, zs) = if ys < zs then move B C t else move C B t
move2 t@([], 1 : ys, zs) = move C A t
move2 t@(xs, 1 : ys, []) = move A C t
move2 t@(xs, 1 : ys, zs) = if xs < zs then move A C t else move C A t
move2 t@([], ys, 1 : zs) = move B A t
move2 t@(xs, [], 1 : zs) = move A B t
move2 t@(xs, ys, 1 : zs) = if xs < ys then move A B t else move B A t

done :: Tower -> Bool
done ([], [], _) = True
done (xs, ys, zs) = False

transfer1, transfer2 :: Tower -> [Tower]
transfer1 t = t : transfer2 (move1 t)
transfer2 t = if done t then [t] else t : transfer1 (move2 t)

hanoi' :: Int -> [Tower]
hanoi' n = transfer1 ([1 .. n], [], [])

zazen :: [Tower]
zazen = hanoi' 64

hanoiCount :: Int -> Integer -> Tower
hanoiCount n k
  | k < 0 = error "argument negative"
  | k > 2 ^ n - 1 = error "argument not in range"
  | k == 0 = ([1 .. n], [], [])
  | k == 2 ^ n - 1 = ([], [], [1 .. n])
  | k < 2 ^ (n - 1) = (xs ++ [n], zs, ys)
  | k >= 2 ^ (n - 1) = (ys', xs', zs' ++ [n])
  where
    (xs, ys, zs) = hanoiCount (n - 1) k
    (xs', ys', zs') = hanoiCount (n - 1) (k - 2 ^ (n - 1))

toTower :: Integer -> Tower
toTower n = hanoiCount k m
  where
    n' = fromInteger (n + 1)
    k = truncate (logBase 2 n')
    m = truncate (n' - 2 ^ k)

data Form = P Int | Conj Form Form | Disj Form Form | Neg Form

instance Show Form where
  show (P i) = 'P' : show i
  show (Conj f1 f2) = "(" ++ show f1 ++ " & " ++ show f2 ++ ")"
  show (Disj f1 f2) = "(" ++ show f1 ++ " v " ++ show f2 ++ ")"
  show (Neg f) = "~" ++ show f

subforms :: Form -> [Form]
subforms (P n) = [(P n)]
subforms (Conj f1 f2) = (Conj f1 f2) : (subforms f1 ++ subforms f2)
subforms (Disj f1 f2) = (Disj f1 f2) : (subforms f1 ++ subforms f2)
subforms (Neg f) = (Neg f) : (subforms f)

ccount :: Form -> Int
ccount (P n) = 0
ccount (Conj f1 f2) = 1 + (ccount f1) + (ccount f2)
ccount (Disj f1 f2) = 1 + (ccount f1) + (ccount f2)
ccount (Neg f) = 1 + (ccount f)

acount :: Form -> Int
acount (P n) = 1
acount (Conj f1 f2) = (acount f1) + (acount f2)
acount (Disj f1 f2) = (acount f1) + (acount f2)
acount (Neg f) = acount f

module Sol7 where

import Data.List
import HL07IAR

-- | 7.14
-- >>>
subtr :: Natural -> Natural -> Natural
subtr Z _ = Z
subtr m Z = m
subtr (S m) (S n) = subtr m n

-- | 7.15
-- >>>
qrm :: Natural -> Natural -> (Natural, Natural)
qrm m n
  | gt n m = (Z, m)
  | otherwise = (S (fst qr), snd qr)
  where
    qr = qrm (subtr m n) n

quotient :: Natural -> Natural -> Natural
quotient m n = fst (qrm m n)

remainder :: Natural -> Natural -> Natural
remainder m n = snd (qrm m n)

-- | 7.16
-- >>>
pre :: Natural -> Natural
pre Z = Z
pre (S n) = n

subtr2 :: Natural -> Natural -> Natural
subtr2 = foldn pre

-- Did Haskell uset to allow this math on the left of = ?

-- | 7.20
-- >>>
--
-- catalan :: Integer -> Integer
-- catalan 0 = 1
-- catalan (n + 1) = sum [(catalan i) * (catalan (n - i)) | i <- [0 .. n]]

-- | 7.25
-- >>>
--
-- data TernTree = L' | N' TernTree TernTree TernTree deriving (Show)
--
-- makeTernTree :: Integer -> TernTree
-- makeTernTree 0 = L'
-- makeTernTree (n + 1) = N' (makeTernTree n) (makeTernTree n) (makeTernTree n)
--
-- count3 :: TernTree -> Integer
-- count3 L' = 1
-- count3 (N' t1 t2 t3) = 1 + count3 t1 + count3 t2 + count3 t3

-- | 7.28
-- >>>
insertTree :: Int -> Tree -> Tree
insertTree n Lf = (Nd n Lf Lf)
insertTree n t@(Nd m left right)
  | m < n = Nd m left (insertTree n right)
  | m > n = Nd m (insertTree n left) right
  | otherwise = t

-- | 7.29
-- >>>
list2tree :: [Int] -> Tree
list2tree [] = Lf
list2tree (n : ns) = insertTree n (list2tree ns)

tree2list :: Tree -> [Int]
tree2list Lf = []
tree2list (Nd n left right) = tree2list left ++ [n] ++ tree2list right

-- | 7.30
-- >>>
inTree :: Int -> Tree -> Bool
inTree n Lf = False
inTree n (Nd m left right)
  | n == m = True
  | n < m = inTree n left
  | n > m = inTree n right

-- | 7.31
-- >>>
mergeTrees :: Tree -> Tree -> Tree
mergeTrees t1 t2 = foldr insertTree t2 (tree2list t1)

-- | 7.32
findDepth :: Int -> Tree -> Int
findDepth _ Lf = -1
findDepth n (Nd m left right)
  | n == m = 0
  | n < m = if d1 == -1 then -1 else d1 + 1
  | n > m = if d2 == -1 then -1 else d2 + 1
  where
    d1 = findDepth n left
    d2 = findDepth n right

-- | 7.33
mapT :: (a -> b) -> Tr a -> Tr b
mapT f Nil = Nil
mapT f (T x left right) = T (f x) (mapT f left) (mapT f right)

-- | 7.34
foldT :: (a -> b -> b -> b) -> b -> (Tr a) -> b
foldT h c Nil = c
foldT h c (T x left right) = h x (foldT h c left) (foldT h c right)

-- | 7.35
preorderT, inorderT, postorderT :: Tr a -> [a]
preorderT = foldT preLists []
  where
    preLists x ys zs = (x : ys) ++ zs
inorderT = foldT inLists []
  where
    inLists x ys zs = ys ++ [x] ++ zs
postorderT = foldT postLists []
  where
    postLists x ys zs = ys ++ zs ++ [x]

-- | 7.36
orderedT :: (Ord a) => Tr a -> Bool
orderedT tree = ordered (inorderT tree)
  where
    ordered xs = (sort (nub xs) == xs)

-- | 7.37
lookupD :: String -> Dict -> [String]
lookupD _ Nil = []
lookupD x (T (v, w) left right)
  | x == v = [w]
  | x < v = lookupD x left
  | otherwise = lookupD x right

-- | 7.38
buildTree :: [a] -> Tr a
buildTree [] = Nil
buildTree xs = T m (buildTree left) (buildTree right)
  where
    (left, m, right) = split xs

-- | 7.39
mapLT :: (a -> b) -> LeafTree a -> LeafTree b
mapLT f (Leaf x) = Leaf (f x)
mapLT f (Node left right) = Node (mapLT f left) (mapLT f right)

-- | 7.40
reflect :: LeafTree a -> LeafTree a
reflect (Leaf x) = Leaf x
reflect (Node left right) = Node (reflect right) (reflect left)

-- | 7.42
mapR :: (a -> b) -> Rose a -> Rose b
mapR f (Bud x) = Bud (f x)
mapR f (Br roses) = Br (map (mapR f) roses)

-- | 7.46
genUnion :: (Eq a) => [[a]] -> [a]
genUnion = foldr union []

genIntersect :: (Eq a) => [[a]] -> [a]
genIntersect = foldr1 intersect

-- | 7.47
insrt :: (Ord a) => a -> [a] -> [a]
insrt x [] = [x]
insrt x (y : ys) = if x <= y then (x : y : ys) else y : (insrt x ys)

srt :: (Ord a) => [a] -> [a]
srt = foldr insrt []

-- | 7.51
ln' :: [a] -> Natural
ln' = foldl (\n _ -> S n) Z

-- Skipped those about Tower of Hanoi