1 Trees

-- # Software Tools for Discrete Mathematics
module Stdm05Trees where

import Test.QuickCheck

-- # Chapter 5.  Trees

data Tree a = Leaf | Node a (Tree a) (Tree a)
  deriving (Show, Eq)

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

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

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

-- |
-- >>> height t2
-- 3
height :: Tree a -> Int
height Leaf = 0
height (Node x t1 t2) = 1 + max (height t1) (height t2)

-- |
-- >>> reflect t2
-- Node 5 (Node 8 (Node 12 Leaf Leaf) (Node 6 Leaf Leaf)) (Node 3 Leaf Leaf)
reflect :: Tree a -> Tree a
reflect Leaf = Leaf
reflect (Node a t1 t2) = Node a (reflect t2) (reflect t1)

-- |
-- >>> mapTree (5 *) t2
-- Node 25 (Node 15 Leaf Leaf) (Node 40 (Node 30 Leaf Leaf) (Node 60 Leaf Leaf))
mapTree :: (a -> b) -> Tree a -> Tree b
mapTree f Leaf = Leaf
mapTree f (Node a t1 t2) = Node (f a) (mapTree f t1) (mapTree f t2)

-- | This is like a dictionary of (fst, snd)
-- >>> t3
-- Node (5,10) (Node (3,6) (Node (1,1) Leaf Leaf) (Node (4,8) Leaf Leaf)) (Node (7,14) (Node (6,12) Leaf Leaf) (Node (8,16) Leaf Leaf))
t3 :: Tree (Int, Int)
t3 =
  Node
    (5, 10)
    ( Node
        (3, 6)
        (Node (1, 1) Leaf Leaf)
        (Node (4, 8) Leaf Leaf)
    )
    ( Node
        (7, 14)
        (Node (6, 12) Leaf Leaf)
        (Node (8, 16) Leaf Leaf)
    )

-- |
-- >>> balanced t2
-- False

-- |
-- >>> balanced t3
-- True
balanced :: Tree a -> Bool
balanced Leaf = True
balanced (Node x t1 t2) = balanced t1 && balanced t2 && (height t1 == height t2)

-- |
-- >>> inorder t2
-- [3,5,6,8,12]
inorder :: Tree a -> [a]
inorder Leaf = []
inorder (Node x t1 t2) = inorder t1 ++ [x] ++ inorder t2

-- |
-- >>> preorder t2
-- [5,3,8,6,12]
preorder :: Tree a -> [a]
preorder Leaf = []
preorder (Node x t1 t2) = [x] ++ preorder t1 ++ preorder t2

-- |
-- >>> postorder t2
-- [3,6,12,8,5]
postorder :: Tree a -> [a]
postorder Leaf = []
postorder (Node x t1 t2) = postorder t1 ++ postorder t2 ++ [x]

-- | This prints nicely; show it!
-- >>> putStrLn (inorderBackwards t2 "")
-- "\n\n    \n            Leaf\n        12\n            Leaf\n    8\n    \n            Leaf\n        6\n            Leaf\n5\n\n        Leaf\n    3\n        Leaf"
inorderBackwards :: (Show a) => Tree a -> String -> String
inorderBackwards Leaf indent = "    " ++ "Leaf"
inorderBackwards (Node x t1 t2) indent =
  ( "\n"
      ++ indent
      ++ inorderBackwards t2 (indent ++ "    ")
      ++ "\n"
      ++ indent
      ++ show x
      ++ "\n"
      ++ indent
      ++ inorderBackwards t1 (indent ++ "    ")
  )

-- Expression trees

data Exp
  = Const Int
  | Add Exp Exp
  | Mult Exp Exp
  deriving (Show, Eq)

-- |
-- >>> t4
-- Mult (Const 2) (Add (Const 5) (Const 3))
t4 :: Exp
t4 = Mult (Const 2) (Add (Const 5) (Const 3))

-- | (*) 2 ((+) 5 3)
-- >>> eval t4
-- 16
eval :: Exp -> Int
eval (Const n) = n
eval (Add e1 e2) = eval e1 + eval e2
eval (Mult e1 e2) = eval e1 * eval e2

-- Binary Search Trees are ordered left to right, and must remain ordered!
-- They are more efficient than search through lists, like this:

-- | This searches through a list of (fst, snd) for fst, and returns snd.
-- >>> linSearch 11 (zip [1..] ['a'..'z'])
-- Just 'k'
linSearch :: (Eq a) => a -> [(a, b)] -> Maybe b
linSearch k [] = Nothing
linSearch k ((x, y) : xs) =
  if k == x
    then Just y
    else linSearch k xs

-- Tree t3 tree is ordered. See:
-- putStrLn (inorderBackwards t3 "")

-- | This searches through a tree of (fst, snd) for fst, and returns snd.
-- >>> bstSearch 7 t3
-- Just 14
bstSearch :: (Ord a) => a -> Tree (a, b) -> Maybe b
bstSearch key Leaf = Nothing
bstSearch key (Node (x, y) t1 t2) =
  if key == x
    then Just y
    else
      if key < x
        then bstSearch key t1
        else bstSearch key t2

-- | This function preserves the ordering of the BST!
-- >>> insertTree (2,5) t3
-- Node (5,10) (Node (3,6) (Node (1,1) Leaf (Node (2,5) Leaf Leaf)) (Node (4,8) Leaf Leaf)) (Node (7,14) (Node (6,12) Leaf Leaf) (Node (8,16) Leaf Leaf))
insertTree :: (Ord a) => (a, b) -> Tree (a, b) -> Tree (a, b)
insertTree (key, d) Leaf = Node (key, d) Leaf Leaf
insertTree (key, d) (Node (x, y) t1 t2) =
  if key == x
    then Node (key, d) t1 t2
    else
      if key < x
        then Node (x, y) (insertTree (key, d) t1) t2
        else Node (x, y) t1 (insertTree (key, d) t2)

-- Tree t3 tree is still ordered. Show this in ghci in class:
-- putStrLn (inorderBackwards (insertTree (2,5) t3) "")

-- Induction on trees

-- Theorem 29. Let t :: BinTree a.
-- Then reflect (reflect t) = t.
-- Proof. The proposition P (t) that we need to prove says reflect (reflect t) = t.
-- The theorem is proved by induction over t.

-- | The base case
-- >>> reflectBase Leaf
-- True
reflectBase :: (Eq a) => Tree a -> Bool
reflectBase t = (reflect . reflect) t == t

-- For the inductive case, let t1, t2 :: BinTree a be trees, and assume P (t1) and P (t2).
-- These are the inductive hypotheses.
-- The aim is to prove that the proposition holds for a larger tree P (Node x t1 t2).

-- | Inductive case + 1
-- >>> quickCheck reflectInductive
-- +++ OK, passed 100 tests.
reflectInductive :: (Eq a) => a -> Bool
reflectInductive val =
  let t = Node val Leaf Leaf
   in (reflect . reflect) t == t

-- Theorem 30. Let t :: BinTree a be an arbitrary binary tree of finite size.
-- Then inorder (reflect t) = reverse (inorder t).

-- | Base case
-- >>> reverseBase Leaf
-- True
reverseBase :: (Eq a) => Tree a -> Bool
reverseBase t = inorder (reflect t) == reverse (inorder t)

-- | Inductive case + 1
-- >>> quickCheck reverseInductive
-- +++ OK, passed 100 tests.
reverseInductive :: (Eq a) => a -> Bool
reverseInductive val =
  let t = Node val Leaf Leaf
   in inorder (reflect t) == reverse (inorder t)

-- Theorem 31. Let h = height t. If balanced t, then size t = 2h − 1.
-- Proof. The proposition we want to prove is: balanced t → size t = 2h − 1.
-- The proof is an induction over the tree structure.
-- For the base case, we need to prove that the theorem holds for a leaf.

-- | Base case
-- >>> sizeHeightBase Leaf
-- True
sizeHeightBase :: (Eq a) => Tree a -> Bool
sizeHeightBase t =
  if balanced t
    then nodeCount t == (2 ^ (height t)) - 1
    else error "Starting assumption not met"

-- | Inductive case + 1
-- >>> quickCheck sizeHeightInductive
-- +++ OK, passed 100 tests.
sizeHeightInductive :: (Eq a) => a -> Bool
sizeHeightInductive val =
  let t = Node val Leaf Leaf
   in if balanced t
        then nodeCount t == (2 ^ (height t)) - 1
        else error "Starting assumption not met"

-- Theorem 32. Let t :: BinTree a be any finite binary tree. Then length (inorder t) = size t.

-- | Base case
-- >>> flatLengthBase Leaf
-- True
flatLengthBase :: (Eq a) => Tree a -> Bool
flatLengthBase t = length (inorder t) == nodeCount t

-- | Inductive case + 1
-- >>> quickCheck flatLengthInductive
-- +++ OK, passed 100 tests.
flatLengthInductive :: (Eq a) => a -> Bool
flatLengthInductive val =
  let t = Node val Leaf Leaf
   in length (inorder t) == nodeCount t

module HL07IAR where

import Data.List
import HL04STAL (display)

-- Sum of first n odd numbers

-- |
-- >>> sumOddsManual 42
-- 1764
sumOddsManual :: Int -> Integer
sumOddsManual n = sum (take n [1, 3 ..])

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

-- |
-- >>> sumOdds 42
-- 1764
sumOdds :: Integer -> Integer
sumOdds n = n ^ 2

-- Sum of of first n evens

-- |
-- >>> sumEvensManual 42
-- 1806
sumEvensManual :: Int -> Integer
sumEvensManual n = sum (take n [2, 4 ..])

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

-- |
-- >>> sumEvens' 42
-- 1806
sumEvens :: Integer -> Integer
sumEvens n = n * (n + 1)

-- Just divide that by 2!
-- Sum of of first n ints

-- |
-- >>> sumIntsManual 42
-- 903
sumIntsManual :: Int -> Integer
sumIntsManual n = sum (take n [1, 2 ..])

-- |
-- >>> sumInts 42
-- 903
sumInts :: Integer -> Integer
sumInts n = div (n * (n + 1)) 2

-- Sum of of first n squares

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

-- |
-- >>> sumSquares 42
-- 25585
sumSquares :: Integer -> Integer
sumSquares n = div (n * (n + 1) * (2 * n + 1)) 6

-- Sum of of first n cubes

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

-- |
-- >>> sumCubes 42
-- 815409
sumCubes :: Integer -> Integer
sumCubes n = div (n * (n + 1)) 2 ^ 2

-- Another implementation of Peano arithmitic

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

-- | 1 + 2
-- >>> plus (S Z) (S (S Z))
-- S (S (S Z))
plus m Z = m
plus m (S n) = S (plus m n)

-- | 2 * 2
-- >>> mult (S (S Z)) (S (S Z))
-- S (S (S (S Z)))
mult m Z = Z
mult m (S n) = plus (mult m n) m

-- | 2^3
-- >>> expn (S (S Z)) (S (S (S Z)))
-- S (S (S (S (S (S (S (S Z)))))))
expn m Z = S Z
expn m (S n) = mult (expn m n) m

-- | 2 <= 3
-- >>> leq (S (S Z)) (S (S (S Z)))
-- True
leq Z _ = True
leq (S _) Z = False
leq (S m) (S n) = leq m n

-- | 2 >= 3
-- >>> geq (S (S Z)) (S (S (S Z)))
-- False
geq m n = leq n m

-- | 2 > 3
-- >>> geq (S (S Z)) (S (S (S Z)))
-- False
gt m n = not (leq m n)

-- | 2 < 3
-- >>> leq (S (S Z)) (S (S (S Z)))
-- True
lt m n = gt n m

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

-- | 7.15
-- >>> qrm (S (S (S Z))) (S (S Z))
-- (S Z,S Z)
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 (S (S (S Z))) (S (S Z))
-- S Z
quotient :: Natural -> Natural -> Natural
quotient m n = fst (qrm m n)

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

-- This enables a generalized re-write of the above functions:
foldn :: (a -> a) -> a -> Natural -> a
foldn h c Z = c
foldn h c (S n) = h (foldn h c n)

-- | 1 + 2
-- >>> plus' (S Z) (S (S Z))
-- S (S (S Z))
plus' :: Natural -> Natural -> Natural
plus' = foldn (\n -> S n)

-- | 2 * 2
-- >>> mult' (S (S Z)) (S (S Z))
-- S (S (S (S Z)))
mult' :: Natural -> Natural -> Natural
mult' m = foldn (plus' m) Z

-- | 2^3
-- >>> expn' (S (S Z)) (S (S (S Z)))
-- S (S (S (S (S (S (S (S Z)))))))
expn' :: Natural -> Natural -> Natural
expn' m = foldn (mult' m) (S Z)

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

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

-- |
-- >>> exclaim (S (S Z))
-- "!!"
exclaim :: Natural -> String
exclaim = foldn ('!' :) []

-- Selects bitlists without consecutive zeros.
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)

-- | 7.20 Write a function that generates: https://en.wikipedia.org/wiki/Catalan_number
-- >>> catalan 6
-- 132
catalan :: Integer -> Integer
catalan 0 = 1
catalan n = sum [catalan i * catalan ((n - 1) - i) | i <- [0 .. (n - 1)]]

-- Trees

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

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

-- |
-- >>> count (makeBinTree 2)
-- 7
count :: BinTree -> Integer
count L = 1
count (N t1 t2) = 1 + count t1 + count t2

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

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

-- 7.25 Write a Haskell definition of ternary trees, plus procedures for generating balanced ternary trees and counting their node numbers.
data TernTree = L' | N' TernTree TernTree TernTree
  deriving (Show)

-- |
-- >>> makeTernTree 2
-- N' (N' L' L' L') (N' L' L' L') (N' L' L' L')
makeTernTree :: Integer -> TernTree
makeTernTree 0 = L'
makeTernTree n = N' (makeTernTree (n - 1)) (makeTernTree (n - 1)) (makeTernTree (n - 1))

-- |
-- >>> count3 (makeTernTree 2)
-- 13
count3 :: TernTree -> Integer
count3 L' = 1
count3 (N' t1 t2 t3) = 1 + count3 t1 + count3 t2 + count3 t3

-- | A binary tree container Int data
-- >>> Nd 5 (Nd 2 Lf Lf) (Nd 3 Lf Lf)
-- Nd 5 (Nd 2 Lf Lf) (Nd 3 Lf Lf)
data Tree = Lf | Nd Int Tree Tree
  deriving (Show)

-- | 7.28 Write a function that inserts a number n in an ordered tree in such a way that the tree remains ordered.
-- >>> insertTree 4 (Nd 5 (Nd 2 Lf Lf) (Nd 3 Lf Lf))
-- Nd 5 (Nd 2 Lf (Nd 4 Lf Lf)) (Nd 3 Lf Lf)
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 [1..5]
-- Nd 5 (Nd 4 (Nd 3 (Nd 2 (Nd 1 Lf Lf) Lf) Lf) Lf) Lf
list2tree :: [Int] -> Tree
list2tree [] = Lf
list2tree (n : ns) = insertTree n (list2tree ns)

-- |
-- >>> tree2list (list2tree [1..5])
-- [1,2,3,4,5]
tree2list :: Tree -> [Int]
tree2list Lf = []
tree2list (Nd n left right) = tree2list left ++ [n] ++ tree2list right

-- | 7.30 Write a function that checks whether a given integer i occurs in an ordered tree.
-- >>> inTree 7 (Nd 5 (Nd 2 Lf Lf) (Nd 7 Lf Lf))
-- True
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 Merges two trees, produces ordered tree.
-- >>> mergeTrees (Nd 5 (Nd 2 Lf Lf) (Nd 7 Lf Lf)) (Nd 6 (Nd 1 Lf Lf) (Nd 8 Lf Lf))
-- Nd 6 (Nd 1 Lf (Nd 5 (Nd 2 Lf Lf) Lf)) (Nd 8 (Nd 7 Lf Lf) Lf)
mergeTrees :: Tree -> Tree -> Tree
mergeTrees t1 t2 = foldr insertTree t2 (tree2list t1)

-- | 7.32 Finds depth of a given element
-- >>> findDepth 7 (Nd 5 (Nd 2 Lf Lf) (Nd 7 Lf Lf))
-- 1
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

-- | A binary tree container for any data, a
-- >>> T 5 (T 2 Nil Nil) (T 3 Nil Nil)
-- T 5 (T 2 Nil Nil) (T 3 Nil Nil)
data Tr a = Nil | T a (Tr a) (Tr a)
  deriving (Eq, Show)

-- | 7.33 Like map, but for trees
-- >>> mapT (1 +) (T 5 (T 2 Nil Nil) (T 3 Nil Nil))
-- T 6 (T 3 Nil Nil) (T 4 Nil Nil)
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 Like fold, but for trees
-- >>> foldT (\x y z -> x + y + z) 0 (T 5 (T 2 Nil Nil) (T 3 Nil Nil))
-- 10
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 traversals using fold

-- |
-- >>> preorderT (T 5 (T 2 Nil Nil) (T 3 Nil Nil))
-- [5,2,3]
preorderT :: Tr a -> [a]
preorderT = foldT preLists []
  where
    preLists x ys zs = (x : ys) ++ zs

-- |
-- >>> inorderT (T 5 (T 2 Nil Nil) (T 3 Nil Nil))
-- [2,5,3]
inorderT :: Tr a -> [a]
inorderT = foldT inLists []
  where
    inLists x ys zs = ys ++ [x] ++ zs

-- |
-- >>> postorderT (T 5 (T 2 Nil Nil) (T 3 Nil Nil))
-- [2,3,5]
postorderT :: Tr a -> [a]
postorderT = foldT postLists []
  where
    postLists x ys zs = ys ++ zs ++ [x]

-- 7.36 Checks if tree is ordered

-- |
-- >>> orderedT (T 5 (T 2 Nil Nil) (T 3 Nil Nil))
-- False

-- |
-- >>> orderedT (T 5 (T 2 Nil Nil) (T 8 Nil Nil))
-- True
orderedT :: (Ord a) => Tr a -> Bool
orderedT tree = ordered (inorderT tree)
  where
    ordered xs = sort (nub xs) == xs

-- A dictionary example:
type Dict = Tr (String, String)

-- | 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

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.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 questions about Tower of Hanoi

#!/usr/bin/runghc

type Symbol = Char

type Weight = Float

data Node
  = Leaf Symbol Weight
  | Interior Node Node [Symbol] Weight
  deriving (Show)

getSymbols :: Node -> [Symbol]
getSymbols (Leaf s _) = [s]
getSymbols (Interior _ _ syms _) = syms

getWeight :: Node -> Weight
getWeight (Leaf _ w) = w
getWeight (Interior _ _ _ w) = w

orderedInsert :: Node -> [Node] -> [Node]
orderedInsert n [] = [n]
orderedInsert n all@(first : rest)
  | getWeight n <= getWeight first = n : all
  | otherwise = first : orderedInsert n rest

makeTree :: [Node] -> Node
makeTree [n] = n
makeTree (first : second : rest) =
  let n =
        Interior
          first
          second
          (getSymbols first ++ getSymbols second)
          (getWeight first + getWeight second)
   in makeTree (orderedInsert n rest)

-- These are derived from a large standard corpus of text.
commonTree =
  makeTree
    [ Leaf ' ' 30.2,
      Leaf 'e' 12.702,
      Leaf 't' 9.056,
      Leaf 'a' 8.167,
      Leaf 'o' 7.507,
      Leaf 'i' 6.966,
      Leaf 'n' 6.749,
      Leaf 's' 6.327,
      Leaf 'h' 6.094,
      Leaf 'r' 5.987,
      Leaf 'd' 4.253,
      Leaf 'l' 4.025,
      Leaf 'c' 2.782,
      Leaf 'u' 2.758,
      Leaf 'm' 2.406,
      Leaf 'w' 2.360,
      Leaf 'f' 2.228,
      Leaf 'g' 2.015,
      Leaf 'y' 1.974,
      Leaf 'p' 1.929,
      Leaf 'b' 1.492,
      Leaf 'v' 0.978,
      Leaf 'k' 0.772,
      Leaf 'j' 0.153,
      Leaf 'x' 0.150,
      Leaf 'q' 0.095,
      Leaf 'z' 0.071
    ]

encodeRec :: Node -> [Symbol] -> [Bool]
encodeRec _ [] = []
encodeRec (Leaf s w) (sym : symbols) = encodeRec commonTree symbols
encodeRec (Interior l r _ _) (sym : symbols)
  | elem sym (getSymbols l) = False : encodeRec l (sym : symbols)
  | otherwise = True : encodeRec r (sym : symbols)

encode = encodeRec commonTree

decodeRec :: Node -> [Bool] -> [Symbol]
decodeRec (Leaf s w) bits = s : decodeRec commonTree bits
decodeRec (Interior l _ _ _) (False : bits) = decodeRec l bits
decodeRec (Interior _ r _ _) (True : bits) = decodeRec r bits
decodeRec _ [] = []

decode = decodeRec commonTree

main :: IO ()
main = do
  putStrLn ("This is a generalized tree:\n" ++ show commonTree)

  let message = "this is a small message"
  putStrLn ("\nMessage before encoding was:\n" ++ message)
  putStrLn ("\nLength of message before encoding, times 8 was:\n" ++ show (8 * length message))

  let encoded = encode message
  putStrLn ("\nEncoded message was:\n" ++ show encoded)
  putStrLn ("\nLength of encoded message was:\n" ++ show (length encoded))

  let decoded = decode encoded
  putStrLn ("\nThe decoded message was:\n" ++ decoded)