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