import Control.Applicative
import Control.Monad
import Data.Array
import Data.Char
import Data.Function
import Data.List
import Data.Ord (comparing)
import Data.Maybe
import Data.Ratio
import Data.Tuple
import System.Environment
import System.Exit
import System.Random
-- Problem 1
-- (*) Find the last element of a list.
myLast' :: [a] -> a
myLast' = last
myLast'' = head . reverse
myLast''' = foldr
-- Problem 2
-- (*) Find the last but one element of a list.
mySecondLast :: [a] -> a
mySecondLast = last . init
mySecondLast' = head . tail. reverse
mySecondLast'' x = reverse x !! 1
mySecondLast''' x =
if ((length x) < 2) then head x
else (x !! ((length x) - 2))
-- Problem 3
-- (*) Find the K'th element of a list. The first element in the list is number 1.
elemAt :: Int -> [a] -> a
elemAt k xs =
if k <= 0 || k > length xs then error "Index out of bounds."
else xs !! (k - 1)
-- Problem 4
-- (*) Find the number of elements of a list.
numElems :: [a] -> Int
numElems = length
numElems' [] = 0
numElems' (x:xs) = 1 + numElems xs
numElems'' = foldl (\acc x -> acc + 1) 0
numElems''' = foldr (\x acc -> acc + 1) 0
numElems'''' = sum . map (\_ -> 1)
-- Problem 5
-- (*) Reverse a list.
myReverse :: [a] -> [a]
myReverse = reverse
myReverse' [] = []
myReverse' (xs) = (myReverse' $ tail xs) ++ [(head xs)]
myReverse'' = foldl (flip (:)) []
myReverse''' = foldr (\x acc -> acc ++ [x]) []
myReverse'''' [] = []
myReverse'''' (x:xs) = myReverse'''' xs ++ [x]
-- Problem 6
-- (*) Find out whether a list is a palindrome.
-- A palindrome can be read forward or backward; e.g. (x a m a x).
isPalindrome :: (Eq a) => [a] -> Bool
isPalindrome x = x == (reverse x)
isPalindrome' :: (Eq a) => [a] -> Bool
isPalindrome' = (==) <*> reverse
-- Problem 7
-- (**) Flatten a nested list structure.
-- Transform a list, possibly holding lists as elements into a `flat' list,
-- by replacing each list with its elements (recursively).
data NestedList a = Elem a | List [NestedList a] deriving (Show)
flatten :: NestedList a -> [a]
flatten (Elem x) = [x]
flatten (List []) = []
flatten (List (x:xs)) = (flatten x) ++ (flatten (List xs))
-- Problem 8
-- (**) Eliminate consecutive duplicates of list elements.
-- If a list contains repeated elements they should be replaced with a single copy of the element.
-- The order of the elements should not be changed.
compress :: (Eq a) => [a] -> [a]
compress [] = []
compress [x] = [x]
compress [x,y] = if x == y then [y] else [x,y]
compress (x:y:xs)
| x == y = compress (y:xs)
| otherwise = x : (compress (y:xs))
compress' :: (Eq a) => [a] -> [a]
compress' = foldr (\x acc -> if ((acc /= []) && (x == head acc)) then acc else x:acc) []
compress'' :: (Eq a) => [a] -> [a]
compress'' xs = foldr (\x acc -> (head x) : acc) [] (groupBy (\x y -> x == y) xs)
-- Problem 9
-- (**) Pack consecutive duplicates of list elements into sublists.
-- If a list contains repeated elements they should be placed in separate sublists.
pack :: (Eq a) => [a] -> [[a]]
pack = group
pack' :: (Eq a) => [a] -> [[a]]
pack' = groupBy (==)
pack'' :: (Eq a) => [a] -> [[a]]
pack'' [] = [[]]
pack'' [x] = [[x]]
pack'' y@(x:xs) = let
d = dropWhile (==x) y
t = takeWhile (==x) y
in if d == [] then [t] else [t] ++ (pack'' d)
-- Problem 10
-- (*) Run-length encoding of a list.
-- Use the result of problem P09 to implement the so-called run-length encoding data compression method.
-- Consecutive duplicates of elements are encoded as lists (N E) where N
-- is the number of duplicates of the element E.
encode :: (Eq a) => [a] -> [(Int, a)]
encode = map (\x -> (length x, head x)) . group
-- Problem 11
-- (*) Modified run-length encoding.
-- Modify the result of problem 10 in such a way that if an element has no duplicates
-- it is simply copied into the result list. Only elements with duplicates are transferred as (N E) lists.
data Many a = Single a | Multiple Int a deriving(Show)
encodeModified :: (Eq a) => [a] -> [Many a]
encodeModified = map (\x -> if 1 == length x then Single (head x) else (Multiple (length x) (head x))) . group
-- Problem 12
-- (**) Decode a run-length encoded list.
-- Given a run-length code list generated as specified in problem 11. Construct its uncompressed version.
decodeModified :: [Many a] -> [a]
decodeModified = concat . map rp
where
rp (Single x) = [x]
rp (Multiple n x) = replicate n x
-- Problem 13
-- (**) Run-length encoding of a list (direct solution).
-- Implement the so-called run-length encoding data compression method directly.
-- I.e. don't explicitly create the sublists containing the duplicates, as in problem 9,
-- but only count them. As in problem P11,
-- simplify the result list by replacing the singleton lists (1 X) by X.
encodeDirect :: (Eq a) => [a] -> [Many a]
encodeDirect = foldr curs []
where
curs x [] = [Single x]
curs x [Single a] = if x == a then [Multiple 2 a] else Single x:[Single a]
curs x [Multiple n a] = if x == a then [Multiple (n+1) a] else Single x : [Multiple n a]
curs x (y@(Single a:xs)) = if x == a then Multiple 2 a : xs else Single x:y
curs x (y@(Multiple n a:xs)) = if x == a then Multiple (n+1) a : xs else Single x:y
-- Problem 14
-- (*) Duplicate the elements of a list.
dupli :: [a] -> [a]
dupli [] = []
dupli (x:xs) = x:x:(dupli xs)
-- Problem 15
-- (**) Replicate the elements of a list a given number of times.
repli :: [a] -> Int -> [a]
repli [] _ = []
repli (x:xs) n = (replicate n x) ++ (repli xs n)
-- Problem 16
-- (**) Drop every N'th element from a list.
dropN :: [a] -> Int -> [a]
dropN [] _ = []
dropN y 0 = y
dropN y n
| n > length y || n <= 0 = y
| otherwise = (take (n - 1) y) ++ (dropN (drop n y) n)
-- Problem 17
-- (*) Split a list into two parts; the length of the first part is given.
splitFrom :: [a] -> Int -> ([a], [a])
splitFrom [] _ = ([], [])
splitFrom x n
| n <= 0 || n > length x = ([], x)
| otherwise = (take n x, drop n x)
splitFrom' :: [a] -> Int -> ([a], [a])
splitFrom' y n = foldr (\x acc -> if ((fst x) < n) then ((snd x):(fst acc), (snd acc)) else ((fst acc), (snd x):(snd acc))) ([],[]) (zip [1,2..] y)
splitFrom'' :: [a] -> Int -> ([a], [a])
splitFrom'' y 0 = ([], y)
splitFrom'' y n = ((tak n y), (dro n y))
where
tak 0 x = x
tak n x = tak (n - 1) (init x)
dro 0 x = x
dro n x = dro (n - 1) (tail x)
-- Problem 18
-- (**) Extract a slice from a list.
-- Given two indices, i and k, the slice is the list containing the elements
-- between the i'th and k'th element of the original list (both limits included).
-- Start counting the elements with 1.
getSlice :: [a] -> Int -> Int -> [a]
getSlice x i k = map snd $ filter (\x -> (fst x) >= i && (fst x) <= k) (zip [1,2..] x)
-- Problem 19
-- (**) Rotate a list N places to the left.
-- Hint: Use the predefined functions length and (++).
rotate :: [a] -> Int -> [a]
rotate [] _ = []
rotate x 0 = x
rotate x n
| n < 0 = (drop ((length x) + n) x) ++ (take ((length x) + n) x)
| otherwise = (drop n x) ++ (take n x)
rotate' :: [a] -> Int -> [a]
rotate' [] _ = []
rotate' x 0 = x
rotate' y@(x:xs) n
| n > 0 = rotate' (xs ++ [x]) (n - 1)
| otherwise = reverse $ rotate' (reverse y) (-n)
-- Problem 20
-- (*) Remove the K'th element from a list.
removeAt :: Int -> [a] -> (a, [a])
removeAt _ [] = (undefined, [])
removeAt n x = ((head $ drop n x), ((take (n) x) ++ (drop (n+1) x)))
removeAt' :: Int -> [a] -> (a, [a])
removeAt' 0 (x:xs) = (x, xs)
removeAt' n y@(x:xs)
| n >= (length y) = (undefined, y)
| n < 0 = (undefined, y)
| otherwise = removeAt (n - 1) ((head xs):x:(tail xs))
-- Problem 21
-- Insert an element at a given position into a list
insertAt :: a -> [a] -> Int -> [a]
insertAt e xs n = (fst b) ++ [e] ++ (snd b)
where b = splitAt (n-1) xs
-- Problem 22
-- Create a list containing all integers within a given range.
range :: Int -> Int -> [Int]
range a b = [a..b]
range' a b
| a == b = [b]
| a < b = a : range' (a + 1) b
| otherwise = a : range' (a - 1) b
-- Problem 23
-- Extract a given number of randomly selected elements from a list.
rnd_select :: [a] -> Int -> [a]
rnd_select xs n = help (take n $ randomRs (0, (length xs) - 1) (mkStdGen n)) xs
where
help [] _ = []
help (n:ns) xs = (xs !! n) : help ns xs
-- Problem 24
-- Lotto: Draw N different random numbers from the set 1..M.
lotto :: Int -> Int -> IO [Int]
lotto a b
| a <= 0 || b <= 0 || a > b = return []
| otherwise = uniq a b []
uniq :: Int -> Int -> [Int] -> IO [Int]
uniq 0 _ xs = return xs
uniq a b xs = do
x <- randomRIO (1, b)
if elem x xs
then uniq a b xs
else uniq (a - 1) b (x:xs)
-- Problem 25
-- Generate a random permutation of the elements of a list.
rnd_permu :: [a] -> IO [a]
rnd_permu xs = do
ii <- uniq' (length xs) []
return [xs !! x | x <- ii]
uniq' :: Int -> [Int] -> IO [Int]
uniq' a xs
| length xs == a = return xs
| otherwise = do
x <- randomRIO (0, a - 1)
if elem x xs
then uniq' a xs
else uniq' a (x:xs)
-- Problem 26
-- (**) Generate the combinations of K distinct objects chosen from the N elements of a list
combinations :: Int -> [a] -> [[a]]
combinations 0 _ = [[]]
combinations n xs = do
y:ys' <- tails xs
ys <- combinations (n - 1) ys'
return (y:ys)
combinations' :: Int -> [a] -> [[a]]
combinations' 0 _ = [[]]
combinations' n xs = [y:ys | y:xs' <- tails xs, ys <- combinations' (n - 1) xs']
wendys = ["lettuce","tomato","onion","ketchup","mayonnaise","cheese","pickles","mustard"]
wendys_ways = concat $ map (\x -> combinations x wendys) [0..(length wendys)]
-- Problem 27
-- Group the elements of a set into disjoint subsets.
-- a) In how many ways can a group of 9 people work in 3 disjoint subgroups of 2, 3 and 4 persons?
-- Write a function that generates all the possibilities and returns them in a list.
filta :: (Eq a) => [a] -> [a] -> [a]
filta xs = filter (not . flip elem xs)
group3 :: (Eq a) => [a] -> [([a],[a],[a])]
group3 xs = do
ys <- combinations 2 xs
zs <- combinations 3 (filta ys xs)
as <- combinations 4 (filta (ys++zs) xs)
return (ys, zs, as)
-- b) Generalize the above predicate in a way that we can specify a list of group sizes
-- and the predicate will return a list of groups.
group_any :: (Eq a) => [Int] -> [a] -> [[[a]]]
group_any [] _ = return []
group_any (n:ns) xs = do
ys <- combinations n xs
zs <- group_any ns (filter (not . flip elem ys) xs)
return (ys:zs)
-- Problem 28
-- Sorting a list of lists according to length of sublists
-- a) We suppose that a list contains elements that are lists themselves.
-- The objective is to sort the elements of this list according to their length.
-- E.g. short lists first, longer lists later, or vice versa.
len_sort :: [[a]] -> [[a]]
len_sort = sortBy (\a b -> compare (length a) (length b))
-- b) Again, we suppose that a list contains elements that are lists themselves.
-- But this time the objective is to sort the elements of this list according to their length frequency;
-- i.e., in the default, where sorting is done ascendingly, lists with rare lengths are placed first,
-- others with a more frequent length come later.
len_freq_sort :: [[a]] -> [[a]]
len_freq_sort xs = sortBy (\a b -> compare (fre a) (fre b)) xs
where fre x = length $ filter (==(length x)) $ map length xs
-- Problem 31
-- (**) Determine whether a given integer number is prime.
isPrime :: (Integral n) => n -> Bool
isPrime n
| n <= 0 = False
| n <= 2 = True
| otherwise = not $ foldl (\acc x -> acc || (mod n x) == 0) False [2..(round (sqrt (fromIntegral n)))]
-- Problem 32
-- Determine the greatest common divisor of two positive integer numbers. Use Euclid's algorithm.
gcdenom :: Int -> Int -> Int
gcdenom x y
| x < 0 || y < 0 = 0
| y == 0 = x
| otherwise = gcdenom y (mod x y)
-- Problem 33
-- (*) Determine whether two positive integer numbers are coprime.
-- Two numbers are coprime if their greatest common divisor equals 1.
coprime :: Int -> Int -> Bool
coprime x y = (gcdenom x y) == 1
-- Problem 34
-- (**) Calculate Euler's totient function phi(m).
-- Euler's so-called totient function phi(m) is defined as the number
-- of positive integers r (1 <= r < m) that are coprime to m.
phi :: Int -> Int
phi m
| m <= 0 = 0
| otherwise = foldl (\acc x -> if (coprime m x) then acc + 1 else acc) 0 [1..m]
-- Problem 35
-- (**) Determine the prime factors of a given positive integer.
-- Construct a flat list containing the prime factors in ascending order.
primeFactors :: (Integral n) => n -> [n]
primeFactors n
| n <= 0 = []
| otherwise = filter (\x -> (mod n (fromIntegral x)) == 0 && isPrime x) [1..(round $ sqrt (fromIntegral n))]
-- Problem 36
-- (**) Determine the prime factors of a given positive integer.
-- Construct a list containing the prime factors and their multiplicity.
primeMult :: (Integral n) => n -> [(n, n)]
primeMult n = map (\x -> (x, (highPower x 1 n))) (primeFactors n)
highPower :: (Integral z) => z -> z -> z -> z
highPower x y z
| x == 1 = 1
| (mod z (x^y)) == 0 = highPower x (y+1) z
| otherwise = (y - 1)
-- Problem 37
-- (**) Calculate Euler's totient function phi(m) (improved).
-- See problem 34 for the definition of Euler's totient function.
-- If the list of the prime factors of a number m is known in the form of problem 36
-- then the function phi(m) can be efficiently calculated as follows: Let ((p1 m1) (p2 m2) (p3 m3) ...)
-- be the list of prime factors (and their multiplicities) of a given number m.
-- Then phi(m) can be calculated with the following formula:
-- phi(m) = (p1 - 1) * p1 ** (m1 - 1) *
-- (p2 - 1) * p2 ** (m2 - 1) *
-- (p3 - 1) * p3 ** (m3 - 1) * ...
-- Note that a ** b stands for the b'th power of a.
phi' :: Int -> Int
phi' m
| m <= 0 = 0
| otherwise = foldl (\acc (a, b) -> (((one (a - 1)) * (a ^ (b - 1))) * acc)) 1 (primeMult m)
where
one x = if (x < 1) then 1 else x
-- Using a list comprehension per solution example.
phi'' :: Int -> Int
phi'' m = product [(a - 1) * (a ^ (b - 1)) | (a, b) <- primeMult m]
-- Problem 38
-- (*) Compare the two methods of calculating Euler's totient function.
-- Use the solutions of problems 34 and 37 to compare the algorithms.
-- Take the number of reductions as a measure for efficiency.
-- Try to calculate phi(10090) as an example.
-- (no solution required)
-- The newer solutions have many less reductions, and run faster,
-- but strangely aren't coming up with the same answer, which is disconcerting..
-- Problem 39
-- (*) A list of prime numbers.
-- Given a range of integers by its lower and upper limit,
-- construct a list of all prime numbers in that range.
-- Example in Haskell:
-- P29> primesR 10 20
-- [11,13,17,19]
primes :: Int -> Int -> [Int]
primes x y
-- | x < y = []
-- | x < 1 || y < 1 = []
| otherwise = [a | a <- [x..y], isPrime a]
-- Problem 40
-- (**) Goldbach's conjecture.
-- Goldbach's conjecture says that every positive even number greater than 2
-- is the sum of two prime numbers. Example: 28 = 5 + 23.
-- It is one of the most famous facts in number theory that has not been proved to be correct
-- in the general case. It has been numerically confirmed up to very large numbers
-- (much larger than we can go with our Prolog system).
-- Write a predicate to find the two prime numbers that sum up to a given even integer.
-- Example:
-- * (goldbach 28)
-- 5 23)
-- Example in Haskell:
-- *goldbach 28
-- (5, 23)
goldbach :: Int -> (Int, Int)
goldbach n
| n <= 2 = (1,1)
| otherwise = head [(a, b) | a <- prims, b <- prims, (a + b == n)]
where
prims = primes 2 n
-- Problem 41
-- (**) Given a range of integers by its lower and upper limit,
-- print a list of all even numbers and their Goldbach composition.
-- In most cases, if an even number is written as the sum of two prime numbers,
-- one of them is very small. Very rarely, the primes are both bigger than say 50.
-- Try to find out how many such cases there are in the range 2..3000.
-- Example:
-- * (goldbach-list 9 20)
-- 10 = 3 + 7
-- 12 = 5 + 7
-- 14 = 3 + 11
-- 16 = 3 + 13
-- 18 = 5 + 13
-- 20 = 3 + 17
-- * (goldbach-list 1 2000 50)
-- 992 = 73 + 919
-- 1382 = 61 + 1321
-- 1856 = 67 + 1789
-- 1928 = 61 + 1867
-- Example in Haskell:
-- *Exercises> goldbachList 9 20
-- [(3,7),(5,7),(3,11),(3,13),(5,13),(3,17)]
-- *Exercises> goldbachList' 4 2000 50
-- [(73,919),(61,1321),(67,1789),(61,1867)]
goldList :: Int -> Int -> Int -> [(Int, Int)]
goldList x y max = filter (\(n, m) -> n < max && m < max) $ map goldbach $ evens x y
where
evens a b = if even a then [a, a+2..b] else [a+1, a+3..b]
-- 2 Problem 46
-- (**) Define predicates and/2, or/2, nand/2, nor/2, xor/2, impl/2 and equ/2
-- (for logical equivalence) which succeed or fail according to the result of their respective operations;
-- e.g. and(A,B) will succeed, if and only if both A and B succeed.
-- logical expression in two variables can then be written as in the following example:
-- and(or(A,B),nand(A,B)).
-- Now, write a predicate table/3 which prints the truth table
-- of a given logical expression in two variables.
and', or', nand', nor', xor', impl', equ' :: Bool -> Bool -> Bool
and' x y = x && y
or' x y = x || y
nand' x y = not (x && y)
nor' x y = not (x || y)
xor' x y = if x && y then False else (x || y)
impl' x y = (not x) || y
equ' x y = x == y
table :: (Bool -> Bool -> Bool) -> IO()
table fn = mapM_ (putStrLn . show) [(x, y, fn x y) | x <- [True, False], y <- [True, False]]
-- Problem 47
-- (*) Truth tables for logical expressions (2).
-- Continue problem P46 by defining and/2, or/2, etc as being operators.
-- This allows to write the logical expression in the more natural way, as in the example:
-- A and (A or not B). Define operator precedence as usual; i.e. as in Java.
-- ?
-- Problem 48
-- (**) Truth tables for logical expressions (3).
-- Generalize problem P47 in such a way that the logical expression may
-- contain any number of logical variables. Define table/2 in a way
-- that table(List,Expr) prints the truth table for the expression Expr,
-- which contains the logical variables enumerated in List.
tablen :: Int -> ([Bool] -> Bool) -> IO()
tablen n fn = mapM_ (putStrLn . show) mp
where
mp = map (\x -> x ++ [fn x]) set
set = mlen n [[]]
mlen :: Int -> [[Bool]] -> [[Bool]]
mlen 0 y = y
mlen _ [] = []
mlen a (x:xs) = (mlen (a - 1) ([ (x ++ [True]), (x ++ [False]) ])) ++ (mlen (a) xs)
-- Problem 49
-- (**) Gray codes.
-- An n-bit Gray code is a sequence of n-bit strings constructed according to certain rules.
gray :: Int -> [String]
gray 0 = [""]
gray x = gray' x [""]
gray' :: Int -> [String] -> [String]
gray' 0 y = y
gray' _ [] = []
gray' a (x:xs) = (gray' (a - 1) ([ (x ++ "0"), (x ++ "1") ])) ++ (gray' (a) xs)
-- Problem 50
-- (***) Huffman codes.
-- We suppose a set of symbols with their frequencies, given as a list of fr(S,F) terms.
-- Example: [fr(a,45),fr(b,13),fr(c,12),fr(d,16),fr(e,9),fr(f,5)].
-- Our objective is to construct a list hc(S,C) terms,
-- where C is the Huffman code word for the symbol S.
-- In our example, the result could be
-- Hs = [hc(a,'0'), hc(b,'101'), hc(c,'100'), hc(d,'111'), hc(e,'1101'), hc(f,'1100')] [hc(a,'01'),...etc.].
-- The task shall be performed by the predicate huffman/2 defined as follows:
-- huffsample :: [(Char, Int)]
data HuffmanTree a = Empty | Node a (HuffmanTree a) (HuffmanTree a) deriving (Show, Eq, Read)
-- huffman encode based on Frequency (Int)
huffman' :: [(Char, Int)] -> [(Char, String)]
huffman' = hunwrap . hcode "" . htree
-- sample data
hsample :: [(Char, Int)]
hsample = [('a',45), ('b',13), ('c',12), ('d',16), ('e',9), ('f',5)]
-- wrap an array into an array of trees
hwrap :: [a] -> [HuffmanTree a]
hwrap = map (\x -> Node x Empty Empty)
hunwrap :: HuffmanTree a -> [a]
hunwrap (Node p Empty Empty) = [p]
hunwrap (Node p l r) = (hunwrap l) ++ (hunwrap r)
-- remove the int value from a tree
sortHelp :: HuffmanTree (Char, Int) -> Int
sortHelp Empty = 0
sortHelp (Node p l r) = snd p
-- create the tree
htree :: [(Char, Int)] -> HuffmanTree (Char, Int)
htree xs = head $ htree' (hwrap xs)
-- create the tree first as a recursive array
htree' :: [HuffmanTree (Char, Int)] -> [HuffmanTree (Char, Int)]
htree' xs@(x:y:zs) = htree' ((Node add m n):os)
where
(m:n:os) = sortBy (compare `on` sortHelp) xs
add = ('z', (sortHelp m) + (sortHelp n))
htree' xs = xs
-- code the tree
hcode :: String -> HuffmanTree (Char, Int) -> HuffmanTree (Char, String)
hcode s Empty = Empty
hcode s (Node p l r) = Node (fst p, s) (hcode (s ++ "0") l) (hcode (s ++ "1") r)
-- Problem 55
-- (**) Construct completely balanced binary trees
-- In a completely balanced binary tree, the following property holds for every node:
-- The number of nodes in its left subtree and the number of nodes in its right subtree are almost equal,
-- which means their difference is not greater than one.
-- Write a function cbal-tree to construct completely balanced binary trees for a given number of nodes.
-- The predicate should generate all solutions via backtracking.
-- Put the letter 'x' as information into all nodes of the tree.
data Tree a = End | Branch a (Tree a) (Tree a) deriving (Eq, Show)
leaf a = Branch a End End
cbalTree :: Int -> [Tree Char]
cbalTree 0 = [End]
cbalTree 1 = [leaf 'x']
cbalTree 2 = [Branch 'x' (leaf 'x') End, Branch 'x' End (leaf 'x')]
cbalTree x
| x < 0 = [End]
| otherwise = [Branch 'x' a b | a <- (cbalTree (x - 1)), b <- (cbalTree (x - 1))]
-- convenient tree printer
treePrint :: (Show a) => Int -> Tree a -> IO()
treePrint x End = do
putStrLn ((replicate (x*4) ' ') ++ "End")
treePrint x (Branch a b c) = do
putStrLn ((replicate (x*4) ' ') ++ (show a))
treePrint (x + 1) b
treePrint (x + 1) c
printTree :: (Show a) => Tree a -> IO()
printTree a = treePrint 1 a
-- Problem 56
-- (**) Symmetric binary trees
-- Let us call a binary tree symmetric if you can draw a vertical line
-- through the root node and then the right subtree is the mirror image of the left subtree.
-- Write a predicate symmetric/1 to check whether a given binary tree is symmetric.
-- Hint: Write a predicate mirror/2 first to check whether one tree is the mirror image of another.
-- We are only interested in the structure, not in the contents of the nodes.
mirror' :: Tree a -> Tree a -> Bool
mirror' End End = True
mirror' (Branch n a b) (Branch m x y) = mirror' a y && mirror' b x
mirror' _ _ = False
symmetric' :: (Eq a) => Tree a -> Bool
symmetric' End = True
symmetric' (Branch _ l r) = mirror' l r
-- Problem 57
-- (**) Binary search trees (dictionaries)
-- Use the predicate add/3, developed in chapter 4 of the course,
-- to write a predicate to construct a binary search tree from a list of integer numbers.
bstree :: [Int] -> Tree Int
bstree [] = End
bstree (x:y:zs)
| x > y = Branch x (bstree (y:zs)) End
| otherwise = Branch x End (bstree (y:zs))
bstree [x] = leaf x
-- Problem 58
-- (**) Generate-and-test paradigm
-- Apply the generate-and-test paradigm to construct all symmetric,
-- completely balanced binary trees with a given number of nodes.
symBalTree :: Int -> [Tree Char]
symBalTree = filter symmetric' . cbalTree
-- Problem 59
-- (**) Construct height-balanced binary trees
-- In a height-balanced binary tree, the following property holds for every node:
-- The height of its left subtree and the height of its right subtree are almost equal,
-- which means their difference is not greater than one.
hbalTree :: a -> Int -> [Tree a]
hbalTree _ 0 = [End]
hbalTree a 1 = [leaf a]
hbalTree z n = [Branch z a b | (x, y) <- [(n - 1, n - 2), (n - 2, n - 1), (n - 1, n - 1)], a <- (hbalTree z x), b <- (hbalTree z y)]
-- Problem 60
-- (**) Construct height-balanced binary trees with a given number of nodes
-- Consider a height-balanced binary tree of height H. What is the maximum number of nodes it can contain?
-- Clearly, MaxN = 2**H - 1. However, what is the minimum number MinN?
-- This question is more difficult. Try to find a recursive statement and turn it into a function
-- minNodes that returns the minimum number of nodes in a height-balanced binary tree of height H.
-- On the other hand, we might ask:
-- what is the maximum height H a height-balanced binary tree with N nodes can have?
-- Write a function maxHeight that computes this.
-- Now, we can attack the main problem:
-- construct all the height-balanced binary trees with a given number of nodes.
-- Find out how many height-balanced trees exist for = 15.
-- This algorithm took a while to figure out!!
minNodes :: Int -> Int
minNodes 0 = 0
minNodes 1 = 1
minNodes n = 1+ (minNodes (n - 1)) + (minNodes (n - 2))
maxNodes :: Int -> Int
maxNodes x = 2^x - 1
minHeight :: Int -> Int
minHeight n = ceiling $ logBase 2 $ fromIntegral (n + 1)
maxHeight :: Int -> Int
maxHeight n = length $ takeWhile (flip (<=) n) [minNodes x | x <- [1..]]
hbalNodes :: a -> Int -> [Tree a]
hbalNodes z n = filter (\x -> (nodes x) == n) (concatMap (hbalTree z) [(minHeight n)..(maxHeight n)])
nodes :: Tree a -> Int
nodes End = 0
nodes (Branch a l r) = 1 + (nodes l) + (nodes r)
-- Problem 61
-- Count the leaves of a binary tree
-- A leaf is a node with no successors. Write a predicate count_leaves/2 to count them.
leaves :: Tree a -> Int
leaves End = 0
leaves (Branch a End End) = 1
leaves (Branch a l r) = (leaves l) + (leaves r)
-- Problem 61A
-- Collect the leaves of a binary tree in a list
-- A leaf is a node with no successors. Write a predicate leaves/2 to collect them in a list.
collect :: Tree a -> [a]
collect End = []
collect (Branch a l r) = a:((collect l) ++ (collect r))
-- Problem 62
-- Collect the internal nodes of a binary tree in a list
-- An internal node of a binary tree has either one or two non-empty successors.
-- Write a predicate internals/2 to collect them in a list.
internal :: Tree a -> [a]
internal End = []
internal (Branch a End End) = []
internal (Branch a l r) = a:((collect l) ++ (collect r))
-- Problem 62B
-- Collect the nodes at a given level in a list
-- A node of a binary tree is at level N if the path from the root to the node has length N-1.
-- The root node is at level 1. Write a predicate atlevel/3 to collect all nodes at a given level in a list.
getLevel :: Int -> Int -> Tree a -> [a]
getLevel _ _ End = []
getLevel n m (Branch a l r)
| m > n = []
| (n - m) == 1 = [a]
| otherwise = (getLevel n (m + 1) l) ++ (getLevel n (m + 1) r)
-- Problem 63
-- Construct a complete binary tree
-- A complete binary tree with height H is defined as follows:
-- The levels 1,2,3,...,H-1 contain the maximum number of nodes (i.e 2**(i-1) at the level i)
-- In level H, which may contain less than the maximum possible number of nodes,
-- all the nodes are "left-adjusted".
-- This means that in a levelorder tree traversal all internal nodes come first,
-- the leaves come second, and empty successors (the nil's which are not really nodes!) come last.
-- Particularly, complete binary trees are used as data structures (or addressing schemes) for heaps.
-- We can assign an address number to each node in a complete binary tree
-- by enumerating the nodes in level-order, starting at the root with number 1.
-- For every node X with address A the following property holds:
-- The address of X's left and right successors are 2*A and 2*A+1, respectively, if they exist.
-- This fact can be used to elegantly construct a complete binary tree structure.
-- Write a predicate complete_binary_tree/2.
-- This took absolutely forever!!
-- ...and yes, the solution was ultimately simpler than I thought it would be once I pared it down.
ctree :: a -> Int -> Tree a
ctree a 0 = End
ctree a n
| n < 0 = End
| otherwise = Branch a (ctree a left) (ctree a right)
where
available = n - 1
maxside = last $ takeWhile (flip (<=) n) (fib 0 0)
minside = div (maxside - 1) 2
remaining = (available - maxside)
left = available - right
right = if remaining < minside then minside else remaining
-- An array of maximum nodes by tree height : [1,3,7,15,...]
fib :: Int -> Int -> [Int]
fib x n = ((n + 2^x):fib (x + 1) (n + 2^x))
isctree :: (Eq a) => Tree a -> Bool
isctree End = True
isctree y@(Branch a l r) = y == (ctree a (nodes y))
-- The given solution
-- So much simpler!! AHHH!!!
completeBinaryTree :: Int -> Tree Char
completeBinaryTree n = generate_tree 1
where generate_tree x
| x > n = End
| otherwise = Branch 'x' (generate_tree (2*x))
(generate_tree (2*x+1))
-- Problem 64
-- Given a binary tree as the usual Prolog term t(X,L,R) (or nil).
-- As a preparation for drawing the tree,
-- a layout algorithm is required to determine the position of each node in a rectangular grid.
-- Several layout methods are conceivable, one of them is shown in the illustration below:
-- p64.gif
-- In this layout strategy, the position of a node v is obtained by the following two rules:
-- x(v) is equal to the position of the node v in the inorder sequence
-- y(v) is equal to the depth of the node v in the tree
-- Write a function to annotate each node of the tree with a position,
-- where (1,1) in the top left corner or the rectangle bounding the drawn tree.
-- Here is the example tree from the above illustration:
-- Example in Haskell:
-- > layout tree64
-- Branch ('n',(8,1)) (Branch ('k',(6,2)) (Branch ('c',(2,3)) ...
tree64 = Branch 'n'
(Branch 'k'
(Branch 'c'
(Branch 'a' End End)
(Branch 'h'
(Branch 'g'
(Branch 'e' End End)
End
)
End
)
)
(Branch 'm' End End)
)
(Branch 'u'
(Branch 'p'
End
(Branch 's'
(Branch 'q' End End)
End
)
)
End
)
layout :: Tree Char -> Tree (Char, (Int, Int))
layout End = End
layout a = layout' a 1 (sort $ collect a)
layout' :: Tree Char -> Int -> String -> Tree (Char, (Int, Int))
layout' End _ _ = End
layout' (Branch a l r) n s = Branch (a, (pos, n)) (layout' l (n + 1) s) (layout' r (n + 1) s)
where
idx Nothing = 0
idx (Just x) = x
pos = 1 + (idx $ elemIndex a s)
-- Problem 65
-- An alternative layout method is depicted in the illustration below:
-- p65.gif
-- Find out the rules and write the corresponding function.
-- Hint: On a given level, the horizontal distance between neighboring nodes is constant.
-- Use the same conventions as in problem P64 and test your function in an appropriate way.
-- Here is the example tree from the above illustration:
-- Example in Haskell:
-- > layout tree65
-- Branch ('n',(15,1)) (Branch ('k',(7,2)) (Branch ('c',(3,3)) ...
tree65 = Branch 'n'
(Branch 'k'
(Branch 'c'
(Branch 'a' End End)
(Branch 'e'
(Branch 'd' End End)
(Branch 'g' End End)
)
)
(Branch 'm' End End)
)
(Branch 'u'
(Branch 'p'
End
(Branch 'q' End End)
)
End
)
type Pos = (Int, Int)
lwide :: Tree Char -> Tree (Char, Pos)
lwide a = lwide' a height x 1
where
height = hleft a
x = sum [2^n | n <- [0..(height - 1)]]
lwide' :: Tree Char -> Int -> Int -> Int -> Tree (Char, Pos)
lwide' End _ _ _ = End
lwide' (Branch a l r) height x y = (Branch (a, (x, y)) left right)
where
left = lwide' l h (x - (2^h)) y'
right = lwide' r h (x + (2^h)) y'
h = height - 1
y' = y + 1
hleft :: Tree a -> Int
hleft End = 0
hleft (Branch a l r) = 1 + (hleft l)
-- Problem 66
-- Yet another layout strategy is shown in the illustration below:
-- p66.gif
-- The method yields a very compact layout while maintaining a certain symmetry in every node.
-- Find out the rules and write the corresponding Prolog predicate.
-- Hint: Consider the horizontal distance between a node and its successor nodes.
-- How tight can you pack together two subtrees to construct the combined binary tree?
-- Use the same conventions as in problem P64 and P65 and test your predicate in an appropriate way.
-- Note: This is a difficult problem. Don't give up too early!
-- Which layout do you like most?
-- Example in Haskell:
-- > layout tree65
-- Branch ('n',(5,1)) (Branch ('k',(3,2)) (Branch ('c',(2,3)) ...
tree66 = Branch 'n'
(Branch 'k'
(Branch 'c'
(Branch 'a' End End)
(Branch 'e'
(Branch 'd' End End)
(Branch 'g'
End
(Branch 'h' End End)
)
)
)
(Branch 'm' End End)
)
(Branch 'u'
(Branch 'p'
End
(Branch 'q'
(Branch 'v'
(Branch 's' End End)
End)
End)
)
End
)
compactTree :: Tree Char -> Tree (Char, Pos)
compactTree a = compact' a offset 1
where
offset = maxLeft + maxRight
maxLeft = maximum (allTurns rightTurns a)
maxRight = maximum (allTurns leftTurns a)
compact' :: Tree Char -> Int -> Int -> Tree (Char, Pos)
compact' End _ _ = End
compact' (Branch a l r) x y = (Branch (a, (x, y)) left right)
where
left = compact' l (x - turns) y'
right = compact' r (x + turns) y'
y' = y + 1
turns = 1 + (min maxLeft maxRight)
maxLeft = maximum (allTurns rightTurns l)
maxRight = maximum (allTurns leftTurns r)
leftTurns :: Tree a -> Int
leftTurns End = 0
leftTurns (Branch a l End) = 0
leftTurns (Branch a l _) = 1 + leftTurns l
rightTurns :: Tree a -> Int
rightTurns End = 0
rightTurns (Branch a _ End) = 0
rightTurns (Branch a _ r) = 1 + rightTurns r
-- help find max turns
-- left / right fn -> tree -> array of turn counts
allTurns :: (Tree a -> Int) -> Tree a -> [Int]
allTurns _ End = [0]
allTurns fn y@(Branch a l r) = ((fn y) : (allTurns fn l)) ++ (allTurns fn r)
-- Problem 67A
-- A string representation of binary trees
-- Somebody represents binary trees as strings of the following type:
-- a(b(d,e),c(,f(g,)))
-- a) Write a Prolog predicate which generates this string representation,
-- if the tree is given as usual (as nil or t(X,L,R) term). Then write a predicate which does this inverse;
-- i.e. given the string representation, construct the tree in the usual form.
-- Finally, combine the two predicates in a single predicate tree_string/2 which can be used in both directions.
teststr = "a(b(d,e), c)"
treeStr :: Tree Char -> String
treeStr End = ""
treeStr (Branch a End End) = [a]
treeStr (Branch a l r) = [a] ++ "(" ++ (treeStr l) ++ "," ++ (treeStr r) ++ ")"
strTree :: String -> Tree Char
strTree "" = End
strTree (s:paren:str) = Branch s (strTree left) (strTree right)
where
(left, right) = splitParen (init str) 0
chop = init str -- get rid of )
strTree s = leaf (head s)--End -- error "unable to process format"
-- Split paren enclosed tree representations into a left, right side.
splitParen :: String -> Int -> (String, String)
splitParen "" x = ("", "")
splitParen (',':str) 0 = ("", str)
splitParen (s:str) x = (s:left, right)
where
(left, right) = splitParen str x'
x' = if s == '(' then x + 1 else if s == ')' then x - 1 else x
-- Problem 68
-- Preorder and inorder sequences of binary trees.
-- We consider binary trees with nodes that are identified by single lower-case letters,
-- as in the example of problem P67.
-- a) Write predicates preorder/2 and inorder/2 that construct the preorder and inorder sequence
-- of a given binary tree, respectively. The results should be atoms,
-- e.g. 'abdecfg'for the preorder sequence of the example in problem P67.
treeToPreorder :: Tree Char -> String
treeToPreorder End = ""
treeToPreorder (Branch a l r) = a:(treeToPreorder l) ++ (treeToPreorder r)
treeToInorder :: Tree Char -> String
treeToInorder End = ""
treeToInorder (Branch a End End) = [a]
treeToInorder (Branch a l r) = (treeToInorder l) ++ [a] ++ (treeToInorder r)
inorder' = sort . treeToPreorder
-- b) Can you use preorder/2 from problem part a) in the reverse direction;
-- i.e. given a preorder sequence, construct a corresponding tree? If not, make the necessary arrangements.
fromPreorder :: String -> Tree Char
fromPreorder "" = End
fromPreorder (s:str) = Branch s (fromPreorder left) (fromPreorder right)
where
(left, right) = span (<= s) str
-- c) If both the preorder sequence and the inorder sequence of the nodes of a binary tree are given,
-- then the tree is determined unambiguously. Write a predicate pre_in_tree/3 that does the job.
preInTree :: String -> String -> Tree Char
preInTree (p:pre) ino = Branch p (preInTree preLeft inoLeft) (preInTree preRight (tail inoRight))
where
(inoLeft, inoRight) = break (== p) ino
(preLeft, preRight) = break (> p) pre
preInTree _ _ = End
-- Problem 69
-- Dotstring representation of binary trees.
-- We consider again binary trees with nodes that are identified by single lower-case letters,
-- as in the example of problem P67.
-- Such a tree can be represented by the preorder sequence of its nodes in which dots (.)
-- are inserted where an empty subtree (nil) is encountered during the tree traversal.
-- For example, the tree shown in problem P67 is represented as 'abd..e..c.fg...'.
-- First, try to establish a syntax (BNF or syntax diagrams)
-- and then write a predicate tree_dotstring/2 which does the conversion in both directions.
-- Use difference lists.
tree67 = "a(b(d,e),c(,f(g,)))"
treeToDot :: Tree Char -> String
treeToDot End = "."
treeToDot (Branch a l r) = a:(treeToDot l) ++ (treeToDot r)
dotToTree :: String -> Tree Char
dotToTree "." = End
dotToTree (s:str) = Branch s (dotToTree left) (dotToTree right)
where
(left, right) = dotSplit str 1
dotSplit :: String -> Int -> (String, String)
dotSplit s 0 = ("", s)
dotSplit (s:str) x = (s:left, right)
where
(left, right) = dotSplit str x'
x' = if s == '.' then x - 1 else x + 1
-- Their solution.
-- I was trying almost this exact same thing originally but am still having trouble wrapping my head around this idiom.
ds2tree [] = (End,"")
ds2tree ('.':xs) = (End,xs)
ds2tree (x:xs) = (Branch x left right, rest2)
where (left,rest) = ds2tree xs
(right,rest2) = ds2tree rest
-- Here is me practicing the idiom with dot''.
dot'' :: String -> (String, Tree Char)
dot'' "" = ("", End)
dot'' ('.':str) = (str, End)
dot'' (s:str) = (rem', Branch s left right)
where
(rem, left) = dot'' str
(rem', right) = dot'' rem
-- BINARY TREES COMPLETE!!
-- Problem 70C
-- (*) Count the nodes of a multiway tree.
-- Sample Mulitway trees.
tree1 = MNode 'a' []
tree2 = MNode 'a' [MNode 'b' []]
tree3 = MNode 'a' [MNode 'b' [MNode 'c' []]]
tree4 = MNode 'b' [MNode 'd' [], MNode 'e' []]
tree5 = MNode 'a' [
MNode 'f' [MNode 'g' []],
MNode 'c' [],
MNode 'b' [MNode 'd' [], MNode 'e' []]
]
data MTree a = MNode a [MTree a] deriving (Show, Read, Eq)
mNodes :: MTree a -> Int
mNodes (MNode a []) = 1
mNodes (MNode a xs) = 1 + (sum (map mNodes xs))
-- Problem 70
-- (**) Tree construction from a node string.
-- We suppose that the nodes of a multiway tree contain single characters.
-- In the depth-first order sequence of its nodes, a special character ^ has been inserted whenever,
-- during the tree traversal, the move is a backtrack to the previous level.
-- By this rule, the tree below (tree5) is represented as: afg^^c^bd^e^^^
-- p70.gif
-- Define the syntax of the string and write a predicate tree(String,Tree)
-- to construct the Tree when the String is given. Make your predicate work in both directions.
-- Example in Haskell:
-- Tree> stringToTree "afg^^c^bd^e^^^"
-- Node 'a' [Node 'f' [Node 'g' []],Node 'c' [],Node 'b' [Node 'd' [],Node 'e' []]]
-- Tree> treeToString (Node 'a' [Node 'f' [Node 'g' []],Node 'c' [],Node 'b' [Node 'd' [],Node 'e' []]])
-- "afg^^c^bd^e^^^"
tree70 = "afg^^c^bd^e^^^"
-- A cheap, but easy and effective way.
-- Convert the string into a Haskell readable string and let it do the work.
strMTree :: String -> MTree Char
strMTree s = read $ smtree' s
smtree' :: String -> String
smtree' "" = ""
smtree' ('^':str) = close ++ (smtree' str)
where close = if str /= [] && (head str) /= '^' then "]," else "]"
smtree' (s:str) = "MNode '" ++ [s] ++ "' [" ++ (smtree' str)
-- I want to try another way with the string chomping algorithm.
strMTree' :: String -> MTree Char
strMTree' = head . snd . smtree''
smtree'' :: String -> (String, [MTree Char])
smtree'' "" = ("", [])
smtree'' ('^':str) = (str, [])
smtree'' (s:str) = (rem'', (MNode s next):next')
where
(rem, next) = smtree'' str
(rem'', next') = smtree'' rem
-- Tree to String.
mTreeStr :: MTree Char -> String
mTreeStr (MNode a []) = a : "^"
mTreeStr (MNode a xs) = (a : (concatMap mTreeStr xs) ) ++ "^"
-- Problem 71
-- (*) Determine the internal path length of a tree.
-- We define the internal path length of a multiway tree as the total sum
-- of the path lengths from the root to all nodes of the tree.
-- By this definition, tree5 has an internal path length of 9.
ipLen :: Int -> MTree Char -> Int
ipLen x (MNode a []) = x
ipLen x (MNode a xs) = sum $ [x] ++ (map (ipLen (x + 1)) xs)
-- Problem 72
-- (*) Construct the bottom-up order sequence of the tree nodes.
-- Write a predicate bottom_up(Tree,Seq) which constructs the bottom-up sequence of the nodes of the multiway tree Tree.
-- Example in Haskell:
-- Tree> bottom_up tree5
-- "gfcdeba"
bottomUp :: MTree Char -> String
bottomUp (MNode a []) = [a]
bottomUp (MNode a xs) = (concatMap bottomUp xs) ++ [a]
-- Problem 73
-- (**) Lisp-like tree representation.
-- There is a particular notation for multiway trees in Lisp.
-- Lisp is a prominent functional programming language,
-- which is used primarily for artificial intelligence problems.
-- As such it is one of the main competitors of Prolog.
-- In Lisp almost everything is a list, just as in Prolog everything is a term.
-- The following pictures show how multiway tree structures are represented in Lisp.
-- p73.png
-- Note that in the "lispy" notation a node with successors (children)
-- in the tree is always the first element in a list, followed by its children.
-- The "lispy" representation of a multiway tree is a sequence of atoms and parentheses '(' and ')',
-- which we shall collectively call "tokens".
-- We can represent this sequence of tokens as a Prolog list;
-- e.g. the lispy expression (a (b c)) could be represented as the Prolog list ['(', a, '(', b, c, ')', ')'].
-- Write a predicate tree_ltl(T,LTL) which constructs the "lispy token list" LTL
-- if the tree is given as term T in the usual Prolog notation.
-- (The Prolog example given is incorrect.)
-- Example in Haskell:
-- Tree> display lisp tree1
-- "a"
-- Tree> display lisp tree2
-- "(a b)"
-- Tree> display lisp tree3
-- "(a (b c))"
-- Tree> display lisp tree4
-- "(b d e)"
-- Tree> display lisp tree5
-- "(a (f g) c (b d e))"
ltl :: MTree Char -> String
ltl = let
ltl' (MNode a []) = " " ++ [a]
ltl' (MNode a xs) = " (" ++ [a] ++ (concatMap ltl' xs) ++ ")"
in tail . ltl'
ltlTree :: String -> MTree Char
ltlTree = let
ltlTree' "" = []
ltlTree' ('(':b:cs) = [MNode b (concatMap ltlTree' (sparen' cs 0))]
ltlTree' a = [MNode (head a) []]
in head . ltlTree'
-- Split paren enclosed tree representations into a left, right side.
sparen' :: String -> Int -> [String]
sparen' "" x = ["", ""]
sparen' (' ':str) 0 = "":(sparen' str 0)
sparen' (s:str) x = (s:left):(right)
where
next = sparen' str x'
left = head next
right = tail next
x' = if s == '(' then x + 1 else if s == ')' then x - 1 else x
-- Problem 81
-- (**) Path from one node to another one
-- Write a function that, given two nodes a and b in a graph, returns all the acyclic paths from a to b.
-- Example:
-- <example in lisp>
-- Example in Haskell:
-- paths 1 4 [(1,2),(2,3),(1,3),(3,4),(4,2),(5,6)]
-- [[1,2,3,4],[1,3,4]]
-- paths 2 6 [(1,2),(2,3),(1,3),(3,4),(4,2),(5,6)]
-- []
type Graph = [(Int, Int)]
graph1 = [(1,2),(2,3),(1,3),(2,4),(3,4),(4,2),(5,6)] :: Graph
allPaths :: Int -> Int -> Graph -> [[Int]]
allPaths _ _ [] = []
allPaths start stop graph = filter (\x -> last x == stop) $ mtreePaths stop $ gTree start graph
gTree :: Int -> Graph -> MTree Int
gTree start graph = MNode start (help start graph)
where
help _ [] = []
help a y@(z:zs) = foldl (\acc x -> if fst x == a then (gTree (snd x) zs):acc else acc) [] y
mtreePaths :: Int -> MTree Int -> [[Int]]
mtreePaths stop (MNode a xs)
| stop == a || xs == [] = [[a]]
| otherwise = map (\x -> a:(head (mtreePaths stop x))) xs
-- Inspired by an example which was a list comprehension, I would like to do this myself...
-- Wow, this solution is so much more elegant.
allPaths' :: Int -> Int -> Graph -> [[Int]]
allPaths' a b [] = [[a]]
allPaths' start end graph
| start == end = [[start]]
| otherwise = [ [start] ++ path | first <- graph, fst first == start, path <- (allPaths' (snd first) end (tail graph)) ]
-- Problem 82
-- (*) Cycle from a given node
-- Write a predicate cycle(G,A,P) to find a closed path (cycle) P starting at a given node A in the graph G.
-- The predicate should return all cycles via backtracking.
nodeCycle :: Int -> Graph -> [[Int]]
nodeCycle a y@(x:xs) = if filt == [] then [] else next
where
next = map (a:) $ concat $ map (\q -> allPaths' (snd q) a y) filt
filt = filter (\x -> fst x == a) y
-- Problem 90
-- (**) Eight queens problem
-- This is a classical problem in computer science.
-- The objective is to place eight queens on a chessboard so that no two queens are attacking each other;
-- i.e., no two queens are in the same row, the same column, or on the same diagonal.
-- Hint: Represent the positions of the queens as a list of numbers 1..N.
-- Example: [4,2,7,3,6,8,5,1] means that the queen in the first column is in row 4,
-- the queen in the second column is in row 2, etc. Use the generate-and-test paradigm.
eightQueens :: [Int]
eightQueens = nums
where
nums = [x | x <- [1..8]]
-- Queen keeps board diagonally safe at this position?
safe :: Int -> Int -> [Int] -> Bool
safe _ _ [] = True
safe n m (x:xs) = if ((n + 1) == x) || ((m - 1) == x) then False else (safe (n + 1) (m - 1) xs)
-- Full array is safe
safeAll :: [Int] -> Bool
safeAll [] = True
safeAll (x:xs) = (safe x x xs) && (safeAll xs)
where
-- Brainstorming how to make an array of all possible unique orderings [1..8]
close :: [[Int]]
close = do
x <- (rems [] [1..4])
y <- (rems [x] [1..4])
z <- (rems [x,y] [1..4])
w <- (rems [x,y,z] [1..4])
return ([x] ++ [y] ++ [z] ++ [w])
-- Got it!
-- Size of list (8) -> [] -> All array orderings of ints
allOrders :: Int -> [Int] -> [[Int]]
allOrders m xs
| (length xs) == (m - 1) = return (rems xs [1..m])
| otherwise = do
x <- (rems xs [1..m])
y <- (allOrders m (x:xs))
return ([x] ++ y)
-- used -> full set -> remaining allowed
rems :: [Int] -> [Int] -> [Int]
rems [] ys = ys
rems (x:xs) ys = rems xs (filter (/= x) ys)
queens :: Int -> [[Int]]
queens n = map reverse $ queens' n
where queens' 0 = [[]]
queens' k = [q:qs | qs <- queens' (k-1), q <- [1..n], isSafe q qs]
isSafe try qs = not (try `elem` qs || sameDiag try qs)
sameDiag try qs = any (\(colDist,q) -> abs (try - q) == colDist) $ zip [1..] qs
-- Problem 91
-- (**) Knight's tour
-- Another famous problem is this one:
-- How can a knight jump on an NxN chessboard in such a way that it visits every square exactly once?
-- A set of solutions is given on the The_Knights_Tour page.
-- Hints: Represent the squares by pairs of their coordinates of the form X/Y,
-- where both X and Y are integers between 1 and N. (Note that '/' is just a convenient functor, not division!)
-- Define the relation jump(N,X/Y,U/V) to express the fact that a knight can jump from X/Y to U/V on a NxN chessboard.
-- And finally, represent the solution of our problem as a list of N*N knight positions (the knight's tour).
-- There are two variants of this problem:
-- find a tour ending at a particular square
-- find a circular tour, ending a knight's jump from the start (clearly it doesn't matter where you start, so choose (1,1))
-- I took a break from this for almost a year then came back to finish the 99!
-- Array of possible next positions
nextPos :: Pos -> [Pos]
nextPos (x, y) = filter on_board possible
where
possible = [ (a x b, c y d) | a <- ops, b <- nums, c <- ops, d <- nums, b /=d ]
ops = [(+), (-)]
nums = [1, 2]
on_board (j, k) = (ok j) && (ok k)
ok n = n > 0 && n <= 8
-- Array of number of next positions one step out
nextMoves :: Pos -> [(Int, Pos)]
nextMoves p = do
moves <- nextPos p
return (length $ nextPos moves, moves)
-- Take the next moves and return those with the fewest subsequent positions availabel (Warnsdorff's rule)
fewestMoves :: Pos -> [Pos] -> [Pos]
fewestMoves p ps
| fewest == [] = []
| otherwise = map snd $ head fewest
where
paths = nextMoves p
unused = filter (not . flip elem ps . snd) paths
sorted = sortBy (on compare fst) unused
fewest = groupBy (\a b -> fst a == fst b) sorted
-- All possible knight's tours
allTours :: [Pos] -> [[Pos]]
allTours a@(p:ps)
| length a >= 64 = [a]
| otherwise = do
next <- fewestMoves p ps
z <- allTours (next:a)
return z
-- Final - The Knight's Tour
knightsTour :: Pos -> [Pos]
knightsTour p = head $ allTours [p]
-- Double check the array is unique
unique :: [Pos] -> Bool
unique [] = True
unique (x:xs)
| elem x xs = False
| otherwise = unique xs
-- Problem 92
-- Anyway the puzzle goes like this: Given a tree with N nodes (and hence N-1 edges).
-- Find a way to enumerate the nodes from 1 to N and, accordingly, the edges from 1 to N-1 in such a way,
-- that for each edge K the difference of its node numbers equals to K.
-- The conjecture is that this is always possible.
-- For small trees the problem is easy to solve by hand.
-- However, for larger trees, and 14 is already very large,
-- it is extremely difficult to find a solution. And remember,
-- we don't know for sure whether there is always a solution!
-- Write a predicate that calculates a numbering scheme for a given tree.
-- What is the solution for the larger tree pictured below?
-- data VKTree a = VKNode (a, a) [VKTree a] deriving (Show, Read, Eq)
-- Smaller demo sample
tree92_sample = MNode 'f' [
MNode 'e' [
MNode 'b' [
MNode 'c' [],
MNode 'a' [
MNode 'd' [],
MNode 'g' []
]
]
]
]
-- Problem to solve
tree92 = MNode 'p' [
MNode 'n' [
MNode 'q' [
MNode 'm' [],
MNode 'e' [
MNode 'c' [
MNode 'f' [],
MNode 'd' [
MNode 'k' []
],
MNode 'a' [
MNode 'g' [],
MNode 'i' [],
MNode 'h' [],
MNode 'b' []
]
]
]
]
]
]
-- Walk an array of integers onto the Char Tree
treePair :: MTree Char -> [Int] -> Int -> MTree (Int, Int)
treePair (MNode _ _) [] _ = MNode (0, 0) []
treePair (MNode _ _) [x] y = MNode (x, (abs(y - x))) []
treePair (MNode _ ms) (x:xs) y = MNode (x, (abs(y - x))) rest
where
rest = (map (\(h, k) -> treePair h k x) subset)
subset = zip ms (tails xs)
-- Are all the node differences equal to the edge values?
isGraceful :: MTree Pos -> Bool
isGraceful m = grace' m (0, 0)
where
grace' (MNode (a, b) []) (c, d) = (abs (a - c)) == b
grace' (MNode (a, b) ms) (c, d) = foldl (\acc x -> acc && (grace' x (a, b))) True ms
-- Are all the node distances unique?
distUnique :: MTree Pos -> Bool
distUnique m = (length $ dists m) == (length $ nub $ dists m)
where
dists (MNode (a, b) []) = [b]
dists (MNode (a, b) ms) = b:(concat $ map dists ms)
-- Generate all permutations of an array.
-- Turns out haskell already has this function (permutations)
allSets :: [Int] -> [[Int]]
allSets [] = [[]]
allSets z@(a:as) = do
x <- z
y <- (allSets (filter ((/=) x) z))
return (x:y)
-- Repeat random array generation n times
rnds :: [Int] -> Int -> IO [[Int]]
rnds xs 0 = return [xs]
rnds xs n = do
one <- rnd_permu xs
rest <- (rnds xs (n - 1))
return (one:rest)
-- Brute force using sequential array possibilities (allSets)
vonKoch :: MTree Char -> MTree (Int, Int)
vonKoch y@(MNode _ ms)
| graces == [] = MNode (0, 0) []
| otherwise = head $ graces
where
graces = filter (\k -> (distUnique k) && (isGraceful k)) trees
set = [1..(mNodes y)]
all = allSets set
trees = do
node <- all
return (treePair y node 0)
-- Brute force using randomly generated arrays (rnds)
vonRand :: MTree Char -> Int -> IO [MTree Pos]
vonRand m x = do
trees <- (rnds [1..(mNodes m)] x)
let
paired = (map (\g -> treePair m g 0) trees)
graced = (filter isGraceful paired)
disted = (filter distUnique graced)
return disted
-- Online solution
vonKoch' edges = do
let n = length edges + 1
ns <- permutations [1..n]
let nodeArray = listArray (1,n) ns
let dists = sort $ map (\(x,y) -> abs (nodeArray !x - nodeArray !y)) edges
guard $ and $ zipWith (/=) dists (tail dists)
return ns
-- 93
-- (***) An arithmetic puzzle
-- Given a list of integer numbers, find a correct way of inserting arithmetic signs (operators)
-- such that the result is a correct equation. Example: With the list of numbers [2,3,5,7,11]
-- we can form the equations 2-3+5+7 = 11 or 2 = (3*5+7)/11 (and ten others!).
-- Division should be interpreted as operating on rationals, and division by zero should be avoided.
-- Some abbreviations
type Expr = (String, Double)
type StrFn = String -> String -> String -> String
type NumFn = Double -> Double -> Double
cash = show . truncate
-- Puzzle solution
puzzle :: [Double] -> [String]
puzzle eqs = do
(l, r) <- zips
left <- expressions l
right <- expressions r
let
str = (fst left) ++ "=" ++ (fst right)
diff = (snd left) - (snd right)
guard (diff == 0)
return str
where
zips = zip (inits eqs) (tails eqs)
-- All expression pairings of a list of numbers
expressions :: [Double] -> [Expr]
expressions [] = []
expressions [x] = [(cash x, x)]
-- All right associative plus all left associative
expressions y@(x:xs) = set_right ++ set_left
where
-- Operations
ops = [((/), "/"), ((+), "+"), ((-), "-"), ((*), "*")]
-- All right associative pairings, upon all (wrapped) and unwrapped x over the operations, recursively
set_right = right_assoc <$> [wrap, unwrap] <*> [x] <*> ops <*> (expressions xs)
-- Same for left
set_left = left_assoc <$> [wrap, unwrap] <*> (expressions (init y)) <*> ops <*> [(last y)]
-- Append strings and perform arithmetic
right_assoc fn a b x@(c, d) = (fn (cash a) (snd b) c, (fst b) a d)
-- For left
left_assoc fn x@(a, d) b c = (fn a (snd b) (cash c), (fst b) d c)
-- Wrap an expression in parens
wrap :: StrFn
wrap a b c = "(" ++ (unwrap a b c) ++ ")"
-- Simple appending
unwrap :: StrFn
unwrap a b c = a ++ b ++ c
-- Problem 94
-- (***) Generate K-regular simple graphs with N nodes
-- In a K-regular graph all nodes have a degree of K;
-- i.e. the number of edges incident in each node is K.
-- How many (non-isomorphic!) 3-regular graphs with 6 nodes are there?
echo xs = mapM_ (putStrLn . show) xs
-- Sum the edges that a node has in a graph
edges :: Int -> [Pos] -> Int
edges n [] = 0
edges n [(a, b)] = if n == a || n == b then 1 else 0
edges n (x:xs) = (edges n [x]) + (edges n xs)
-- All possible pairings of a set of nodes
allPairs :: [Int] -> [Pos]
allPairs [] = []
allPairs (x:xs) = [ (x, n) | n <- xs ] ++ (allPairs xs)
-- Solution
kregular :: Int -> Int -> [[Pos]]
-- All non-isomorphic graphs with equal length edges
kregular k n = nonIso nodes $ filter edges_equal lens
where
nodes = [1..n]
pairs = allPairs nodes
len = length pairs
-- Check that all edges are equal in a graph
edges_equal ns = foldl (\acc y -> acc && (k == (edges y ns))) True nodes
-- All graphs of all viable lengths for k and nodes
lens = do
x <- [k..len]
s <- combinations x pairs
return s
-- Filter a list of graphs to only non-isomorphic
nonIso :: [Int] -> [[Pos]] -> [[Pos]]
nonIso _ [] = []
nonIso nodes (g:gs) = g:(nonIso nodes rest)
where
rest = filter (\x -> not $ areIso nodes g x) gs
-- Check whether two graphs are isomorphic
-- Checks all possible bijections (allSets nodes)
areIso :: [Int] -> [Pos] -> [Pos] -> Bool
areIso nodes xs ys = foldl (\acc x -> acc || (isoBi (zip nodes x) xs ys)) False (allSets nodes)
-- Check isomorphism of two graphs for one possible bijection
-- ks is a bijection mapping
-- For xs, check if the projected coordinates (or their swap), exists in ys
isoBi :: [Pos] -> [Pos] -> [Pos] -> Bool
isoBi ks xs ys = foldl (\acc x -> acc && ((elem (getPair x ks) ys) || (elem (swap $ getPair x ks) ys))) True xs
-- Get a projected value
getKey :: Int -> [Pos] -> Int
getKey _ [] = 0
getKey k (x:xs)
| k == (fst x) = snd x
| otherwise = getKey k xs
-- Get a projected pair
getPair :: Pos -> [Pos] -> Pos
getPair (a, b) xs = (getKey a xs, getKey b xs)
-- Problem 95
-- (**) English number words
-- On financial documents, like cheques, numbers must sometimes be written in full words.
-- Example: 175 must be written as one-seven-five.
-- Write a predicate full-words/1 to print (non-negative) integer numbers in full words.
fullWords :: Int -> String
fullWords x = intercalate "-" $ map eng s
where
s = show x
eng '0' = "zero"
eng '1' = "one"
eng '2' = "two"
eng '3' = "three"
eng '4' = "four"
eng '5' = "five"
eng '6' = "six"
eng '7' = "seven"
eng '8' = "eight"
eng '9' = "nine"
-- Problem 96
-- (**) Syntax checker
-- In a certain programming language (Ada) identifiers are defined by the syntax diagram below.
-- p96.gif
-- Transform the syntax diagram into a system of syntax diagrams which do not contain loops;
-- i.e. which are purely recursive. Using these modified diagrams,
-- write a predicate identifier/1 that can check whether or not a given string is a legal identifier.
identifier :: Bool -> String -> Bool
identifier b [] = b
identifier _ [x] = isAlpha x || isDigit x
identifier b (x:xs)
| b && x == '-' = identifier False xs
| otherwise = identifier True [x] && identifier True xs
-- Problem 97
-- (**) Sudoku
sudoku_sample = "\
\53..7....\
\6..195...\
\.98....6.\
\8...6...3\
\4..8.3..1\
\7...2...6\
\.6....28.\
\...419..5\
\....8..79"
simple_sudoku = "\
\...36..28\
\8...2.34.\
\5.....6..\
\...48.5..\
\2.8...1.6\
\..5.13...\
\..6.....7\
\.82.3...4\
\19..52..."
five_star = "\
\16..9...5\
\...8.2..6\
\....3....\
\.5.....4.\
\7.4...1.8\
\.2.....3.\
\....8....\
\9..6.5...\
\3...1..89"
-- Value, coordinate
type Sud = (Int, Pos)
-- Make a coordinate grid.
makeGrid :: Int -> [Pos]
makeGrid n = [ (x, y) | x <- [1..n], y <- [1..n] ]
-- Make a sudoku structure from a puzzle string.
makeSudoku :: String -> [Sud]
makeSudoku s = zipWith (\x y -> (if isDigit x then read [x] else 0, y)) s (makeGrid 9)
showSudoku :: [Sud] -> IO()
showSudoku xs = mapM_ putStrLn $ blocks $ foldr (\x acc -> (intToDigit $ fst x):acc) "" xs
where
blocks [] = []
blocks xs = (take 9 xs):(blocks $ drop 9 xs)
-- Show possible values for a point on the grid.
showPossible :: Sud -> [Sud] -> [Int]
showPossible s xs
| getV s /= 0 = []
| otherwise = filter (not . flip elem isnt) [1..9]
where
isnt = (getRow (getY s) xs) ++ (getCol (getX s) xs) ++ (getBox (getZ s) xs)
-- Replace all positions that only have one possibility with their value.
addOne :: [Sud] -> [[Sud]]
addOne xs = return $ zipWith (\x y -> if length y == 1 then repV x (head y) else x) xs possible
where
possible = map (\x -> showPossible x xs) xs
-- Change a value at a coordinate in the grid.
changeVal :: [Sud] -> Int -> Pos -> [Sud]
changeVal xs x y = map (\(a, b) -> if b == y then (x, b) else (a, b)) xs
-- Pull all variations of the grid for squares with 2 possibilities.
guessTwo :: [Sud] -> [[Sud]]
guessTwo xs = do
x@(a, b) <- xs
let
possible = showPossible x xs
guard (length possible == 2)
p <- possible
return (changeVal xs p b)
-- Determine if guesses are needed
needGuess :: [Sud] -> Bool
needGuess xs = if xs == (head $ addOne xs) then True else False
sudoku :: String -> [Sud]
sudoku s = head $ filter (\x -> not $ elem 0 (map fst x)) (attempt (makeSudoku s) 20)
-- Recursively attempt to solve
attempt :: [Sud] -> Int -> [[Sud]]
attempt ss 0 = return ss
attempt ss n
-- Puzzle is complete
| not $ elem 0 (map fst ss) = return ss
-- Make guesses
| needGuess ss = do
b <- guessTwo ss
rest <- attempt b (n - 1)
return rest
-- Recursively fill all positions of one possibility
| otherwise = do
s <- addOne ss
rest <- attempt s (n - 1)
return rest
-- | otherwise = return ss
-- Navigating
-- Replace Value
repV (a, b) c = (c, b)
-- Get Value
getV = fst
-- Get Box coordinate (1..3, 1..3)
getZ (a, (b, c)) = (1 + (div (b - 1) 3), 1 + (div (c - 1) 3))
-- Get X
getX = fst . snd
-- Get Y
getY = snd . snd
-- getRow :: Int -> [Sud] -> [Int]
getRow y xs = foldr (\s acc -> if (getY s) == y && (getV s) > 0 then (getV s):acc else acc) [] xs
-- getCol :: Int -> [Sud] -> [Int]
getCol x xs = foldr (\s acc -> if (getX s) == x && (getV s) > 0 then (getV s):acc else acc) [] xs
-- getBox :: Pos -> [Sud] -> [Int]
getBox (x, y) xs = foldr (\s acc -> if (fst (getZ s)) == x && (snd (getZ s)) == y && (getV s) > 0 then (getV s):acc else acc) [] xs
-- Problem 98
-- (***) Nonograms
-- Around 1994, a certain kind of puzzle was very popular in England.
-- The "Sunday Telegraph" newspaper wrote: "Nonograms are puzzles from Japan
-- and are currently published each week only in The Sunday Telegraph.
-- Simply use your logic and skill to complete the grid and reveal a picture or diagram."
-- As a Prolog programmer, you are in a better situation: you can have your computer do the work!
-- Just write a little program ;-).
-- The puzzle goes like this: Essentially, each row and column of a rectangular bitmap
-- is annotated with the respective lengths of its distinct strings of occupied cells.
-- The person who solves the puzzle must complete the bitmap given only these lengths.
type Grid = [[Int]]
nonoY, nonoX :: Grid
nonoY = [[3],[2,1],[3,2],[2,2],[6],[1,5],[6],[1],[2]]
nonoX = [[1,2],[3,1],[1,5],[7,1],[5],[3],[4],[3]]
-- Final
nonogram :: Grid -> Grid -> Grid
nonogram xs ys = head $ filter (solved xs ys) all
where
all = allGrids (crossCheck xs ys)
-- Check if the grid solves the clues
solved :: Grid -> Grid -> Grid -> Bool
solved xs ys zs = (rowToClue zs) == ys && (rowToClue $ transpose zs) == xs
-- Create all possible grids from sets of row possibilities
allGrids :: [Grid] -> [Grid]
allGrids [] = return []
allGrids (x:xs) = do
y <- x
rest <- allGrids xs
return (y:rest)
-- Cross examine all remaining row possibilities with the column possibilities to fill
-- in as many remaining squares as possible
-- crossCheck :: Grid -> Grid -> Grid
crossCheck xs ys = map (\(a,b) -> filter (\c -> a == (addTwo c a)) b) pairs
where
zs = determineXY (blankGrid xs ys) xs ys
rows = rowsPossible zs xs ys
cols = rowsPossible (transpose zs) ys xs
flat = transpose $ map (\x -> foldl (\acc y -> addTwo acc y) (replicate (length ys) 0) x) cols
pairs = zip flat rows
-- Keep transposing the grid and running determineOne until all clues are marked in
determineXY :: Grid -> Grid -> Grid -> Grid
determineXY zs xs ys = if again == marked then marked else determineXY again xs ys
where
xlen = length xs
ylen = length ys
marked = determineOne zs ys xlen
flipped = determineOne (transpose marked) xs ylen
again = determineOne (transpose flipped) ys xlen
-- Determine any cells that can be marked without guessing
determineOne :: Grid -> Grid -> Int -> Grid
determineOne [] _ _ = []
determineOne (x:xs) (y:ys) n = done
where
-- If changing the grid did nothing then stop, otherwise try again with the added 1's
done = if (x:xs) == marked then marked else determineOne marked (y:ys) n
marked = (row):(determineOne xs ys n)
(a,b) = padTwo y
-- Common columns
common = commonCols $ twoVariations a b n
-- Possibilities for a row
possible = filter (\g -> g == (addTwo x g)) (twoVariations a b n)
-- If only one possibility use that, otherwise fill with the commonCols result
row = if (length possible) == 1 then head possible else addTwo x common
-- Take a grid and return all possible final rows for each intermediate rows from the clues
-- rowsPossible :: Grid -> Grid -> Grid -> Grid
rowsPossible zs xs ys = do
(x, y) <- zip zs ys
let (a, b) = padTwo y
return (filter (\g -> g == (addTwo x g)) (twoVariations a b (length xs)))
-- Determine which columns of 1's an array of rows have in common
commonCols :: Grid -> [Int]
commonCols = (map minimum) . transpose
-- Array to tuple
padTwo :: [Int] -> Pos
padTwo (x:y:[]) = (x, y)
padTwo [x] = (x, 0)
padTwo _ = (0, 0)
-- Grid of zeroes to match dimensions of the clue arrays
blankGrid :: Grid -> Grid -> Grid
blankGrid xs ys = [1..(length ys)] >> return (replicate (length xs) 0)
-- Move 1's interspersed in zeroes to the right
-- ex) [1,0,0] -> [[1,0,0],[0,1,0],[0,0,1]]
shiftZeroes :: [Int] -> Grid
shiftZeroes xs = move xs (length xs)
where
move _ 0 = []
move xs n
| last xs == 1 = [xs]
| otherwise = xs:(move (init (0:xs)) (n - 1))
-- Create all sequences of 1's, lengths a and b, separated by 0's
-- with at least one 0 in between, in an array length c
twoVariations :: Int -> Int -> Int -> Grid
twoVariations 0 b c = shiftZeroes ((replicate b 1) ++ (replicate (c - b) 0))
twoVariations a 0 c = shiftZeroes ((replicate a 1) ++ (replicate (c - a) 0))
twoVariations a b c = concat $ map shiftZeroes $ all
where
all = do
x <- shiftZeroes two
return (one ++ x)
one = (replicate a 1) ++ [0]
two = (replicate b 1) ++ (replicate (c - a - b - 1) 0)
-- Sum binary arrays into one
addTwo :: [Int] -> [Int] -> [Int]
addTwo xs ys = map (\(a,b) -> max a b) $ zip xs ys
-- Deconstruct a row to a clue, ex) [1,0,1,1,0] -> [1,2]
rowToClue :: Grid -> Grid
rowToClue xs = map (\x -> map length $ filter ((==) 1 . head) x) $ map group xs
-- 99