Programming in Haskell という書籍で Haskell の勉強をしています（日本語版はこちら）．
練習問題がついているので自分なりに実装してみました．
答え合わせもかねているので，間違っている点や改善点があったら教えていただけるとうれしいです．
関数名があらかじめ Haskell で定義されているものと被る場合にはなるべく ' などの記号を付け足すようにしています
1. Introduction
Exercise 3
mul' :: Num a => [a] -> a
mul' [] = 1
mul' (x : xs) = x * mul' xs
Exercise 4
rqsort :: Ord a => [a] -> [a]
rqsort [] = []
rqsort (x : xs) = rqsort larger ++ [x] ++ rqsort smaller
where
smaller = [a | a <- xs, a < x]
larger = [b | b <- xs, b >= x]
2. First steps
Exercise 4
last' :: [a] -> a
last' xs = xs !! (length xs - 1)
last'' :: [a] -> a
last'' [x] = x
last'' (x : xs) = last'' xs
Exercise 5
init' :: [a] -> [a]
init' xs = take (length xs - 1) xs
init'' :: [a] -> [a]
init'' [x] = []
init'' (x : xs) = x : init'' xs
3. Types and classes
Exercise 2
bools :: [Bool]
bools = [True, False, True, False]
nums :: [[Int]]
nums = [[1, 2, 3], [4, 5], [6, 7, 8, 9]]
add :: Int -> Int -> Int -> Int
add x y z = x + y + z
copy :: a -> (a, a)
copy a = (a, a)
apply :: (a -> b) -> a -> b
apply f = f
4. Defining functions
Exercise 1
halve xs = splitAt n xs
where
n = length xs `div` 2
Exercise 2
third :: [a] -> a
third xs = head (tail (tail xs))
thirdB :: [a] -> a
thirdB xs = xs !! 2
thirdC :: [a] -> a
thirdC (_ : _ : x : _) = x
Exercise 3
safetail :: [a] -> [a]
safetail xs = if null xs then tail xs else xs
safetailB :: [a] -> [a]
safetailB xs
| null xs = tail xs
| otherwise = xs
safetailC :: [a] -> [a]
safetailC (_ : xs) = xs
safetailC [] = []
Exercise 4
(||) :: Bool -> Bool -> Bool
False || False = False
_ || _ = Tru
Exercise 5
(&&) :: Bool -> Bool -> Bool
(&&) x y =
if x
then y
else False
Exercise 6
(&&) :: Bool -> Bool -> Bool
(&&) x b =
if x
then b
else False
Exercise 7
mult :: Integer -> Integer -> Integer -> Integer
mult = \x -> (\y -> (\z -> x * y * z))
Exercise 8
luhnDouble x =
if x * 2 > 9
then x * 2 - 9
else x * 2
Exercise 9
luhn :: Int -> Int -> Int -> Int -> Bool
luhn w x y z = (luhnDouble w + x + luhnDouble y + z) `mod` 10 == 0
5. List comprehensions
Exercise 1
sum [x ^ 2 | x <- [1 .. 100]]
Exercise 2
grid :: Int -> Int -> [(Int, Int)]
grid x y = [(x', y') | x' <- [0 .. x], y' <- [0 .. y]]
Exercise 3
square :: Int -> [(Int, Int)]
square n = [(x, y) | (x, y) <- grid n n, x /= y]
Exercise 4
replicate' :: Int -> a -> [a]
replicate' n a = [a | _ <- [0 .. n - 1]]
Exercise 5
pyths :: Int -> [(Int, Int, Int)]
pyths n = [(x, y, z) | x <- [1 .. n], y <- [1 .. n], z <- [1 .. n], x ^ 2 + y ^ 2 == z ^ 2]
Exercise 6
factors :: Int -> [Int]
factors n = [x | x <- [1 .. n], n `mod` x == 0]
perfect :: Int -> [Int]
perfect n = [x | x <- [1 .. n], sum (init (factors x)) == x]
Exercise 7
concat [[(x, y) | x <- [1, 2]] | y <- [3, 4]]
Exercise 8
positions :: Eq a => a -> [a] -> [Int]
positions x xs = find x (zip xs [0 ..])
Exercise 9
scalarproduct :: [Int] -> [Int] -> Int
scalarproduct xs ys = sum [x * y | (x, y) <- zip xs ys]
Exercise 10
import Data.Char
positions :: Eq a => a -> [a] -> [Int]
positions x xs = [i | (x', i) <- zip xs [0 ..], x == x']
lowers :: [Char] -> Int
lowers xs = length [x | x <- xs, isAsciiLower x]
uppers :: [Char] -> Int
uppers xs = length [x | x <- xs, isAsciiUpper x]
count :: Eq a => a -> [a] -> Int
count x xs = length [x' | x' <- xs, x == x']
lower2int :: Char -> Int
lower2int c = ord c - ord 'a'
int2lower :: Int -> Char
int2lower n = chr (ord 'a' + n)
upper2int :: Char -> Int
upper2int c = ord c - ord 'A'
int2upper :: Int -> Char
int2upper n = chr (ord 'A' + n)
shift :: Int -> Char -> Char
shift n c
| isLower c = int2lower ((lower2int c + n) `mod` 26)
| isUpper c = int2upper ((upper2int c + n) `mod` 26)
| otherwise = c
encode :: Int -> [Char] -> [Char]
encode n xs = [shift n x | x <- xs]
table :: [Float]
table = [8.1, 1.5, 2.8, 4.2, 12.7, 2.2, 2.0, 6.1, 7.0, 0.2, 0.8, 4.0, 2.4, 6.7, 7.5, 1.9, 0.1, 6.0, 6.3, 9.0, 2.8, 1.0, 2.4, 0.2, 2.0, 0.1]
percent :: Int -> Int -> Float
percent n m = (fromIntegral n / fromIntegral m) * 100
freqs :: String -> [Float]
freqs xs = [percent (count x xs + count y xs) n | (x, y) <- zip ['a' .. 'z'] ['A' .. 'Z']] where n = lowers xs
chisqr :: [Float] -> [Float] -> Float
chisqr os es = sum [((o - e) ^ 2) / e | (o, e) <- zip os es]
rotate :: Int -> [a] -> [a]
rotate n xs = drop n xs ++ take n xs
crack :: String -> String
crack xs = encode (- factor) xs
where
factor = head (positions (minimum chitab) chitab)
chitab = [chisqr (rotate n table') table | n <- [0 .. 25]]
table' = freqs xs
main = do
print (crack "Kdvnhoo lv Ixq") --"Haskell is Fun"
print (crack "Vscd Mywzboroxcsyxc kbo Ecopev") -- "List Comprehensions are Useful"
6 Recursive functions
Exercise 1
fac :: Int -> Int
fac n
| n <= 0 = 1
| otherwise = n * fac (n - 1)
Exercise 2
sumdown' :: Int -> Int
sumdown' n
| n <= 0 = 0
| otherwise = n + sumdown' (n - 1)
Exercise 3
(^+) :: Int -> Int -> Int
x ^+ 0 = 1
x ^+ n = x * x ^+ (n - 1)
Exercise 4
euclid' :: Int -> Int -> Int
euclid' a 0 = a
euclid' a b = euclid' b (a `mod` b)
Exercise 6
and' :: [Bool] -> Bool
and' [True] = True
and' (False : _) = False
and' (True : xs) = and' xs
concat' :: [[a]] -> [a]
concat' = foldr (++) []
replicate' :: Int -> a -> [a]
replicate' 0 _ = []
replicate' n x = x : replicate' (n - 1) x
(!!+) :: [a] -> Int -> a
(x : xs) !!+ 0 = x
(x : xs) !!+ n = xs !!+ (n - 1)
elem' :: Eq a => a -> [a] -> Bool
elem' v [] = False
elem' v (x : xs)
| v == x = True
| otherwise = elem' v xs
Exercise 7
merge :: Ord a => [a] -> [a] -> [a]
merge xs [] = xs
merge [] ys = ys
merge (x : xs) (y : ys)
| x <= y = x : merge xs (y : ys)
| otherwise = y : merge (x : xs) ys
Exercise 8
halve :: [a] -> ([a], [a])
halve xs = splitAt n xs
where
n = length xs `div` 2
msort :: Ord a => [a] -> [a]
msort [] = []
msort [x] = [x]
msort xs = merge (msort xs') (msort ys')
where
(xs', ys') = halve xs
Exercise 9
sum' :: Num a => [a] -> a
sum' = foldr (+) 0
take' :: Int -> [a] -> a
take' 0 (x : _) = x
take' n (x : xs) = take' (n - 1) xs
last' :: [a] -> a
last' [x] = x
last' (x : xs) = last xs
7. Higher-order functions
Exercise 1
listCmp :: (a -> b) -> (b -> Bool) -> [a] -> [b]
listCmp f p = filter p . map f
Exercise 2
all' :: (a -> Bool) -> [a] -> Bool
all' p = and . map p
any' :: (a -> Bool) -> [a] -> Bool
any' p = or . map p
takeWhile' :: (a -> Bool) -> [a] -> [a]
takeWhile' p (x : xs) = if p x then x : takeWhile' p xs else []
dropWhile' :: (a -> Bool) -> [a] -> [a]
dropWhile' p (x : xs) = if p x then dropWhile' p xs else x : xs
Exercise 3
map' :: (a -> b) -> [a] -> [b]
map' p = foldr (\x xs -> p x : xs) []
filter' :: (a -> Bool) -> [a] -> [a]
filter' p = foldr (\x xs -> if p x then x : xs else xs) []
Exercise 4
dec2int :: [Int] -> Int
dec2int = foldl (\v x -> 10 * v + x) 0
Exercise 5
curry' :: ((a, b) -> c) -> a -> b -> c
curry' f x y = f (x, y)
uncurry' :: (a -> b -> c) -> ((a, b) -> c)
uncurry' f (x, y) = f x y
Exercise 6
type Bit = Int
unfold :: (t -> Bool) -> (t -> a) -> (t -> t) -> t -> [a]
unfold p h t x
| p x = []
| otherwise = h x : unfold p h t (t x)
int2bin :: Int -> [Bit]
int2bin = unfold (== 0) (`mod` 2) (`div` 2)
chop8 :: [Bit] -> [[Bit]]
chop8 = unfold null (take 8) (drop 8)
map' :: (a -> b) -> [a] -> [b]
map' f = unfold null (f . head) tail
iterate' :: (a -> a) -> a -> [a]
iterate' f = unfold (const False) id f
Exercise 7-10
import Data.Char
type Bit = Int
bin2int :: [Bit] -> Int
bin2int = foldr (\x y -> x + 2 * y) 0
int2bin :: Int -> [Bit]
int2bin 0 = []
int2bin n = n `mod` 2 : int2bin (n `div` 2)
make8 :: [Bit] -> [Bit]
make8 bits = take 8 (bits ++ repeat 0)
addParity :: [Bit] -> [Bit]
addParity bits = if odd (sum bits) then bits ++ [1] else bits ++ [0]
encode :: String -> [Bit]
encode = concat . map (addParity . make8 . int2bin . ord)
chop9 :: [Bit] -> [[Bit]]
chop9 [] = []
chop9 bits = take 9 bits : chop9 (drop 9 bits)
parityCheck :: [Bit] -> [Bit]
parityCheck bits = if even (sum bits) then init bits else error "Incorrect!"
decode :: [Bit] -> String
decode = map (chr . bin2int . parityCheck) . chop9
channel :: [Bit] -> [Bit]
channel = id
transmit :: String -> String
transmit = decode . channel . encode
altMap :: (a -> b) -> (a -> b) -> [a] -> [b]
altMap f g [] = []
altMap f g (x : xs) = f x : altMap g f xs
luhnDouble :: Int -> Int
luhnDouble x
| x * 2 > 9 = x * 2 - 9
| otherwise = x * 2
luhn :: [Int] -> Bool
luhn xs = sum (altMap id luhnDouble xs) `mod` 10 == 0
main = do
print (addParity [1, 0, 0, 0, 0, 0, 0, 0]) -- [1,0,0,0,0,0,0,0,1]
print (addParity [1, 1, 0, 0, 0, 0, 0, 0]) -- [1,1,0,0,0,0,0,0,0]
print (encode "abc") -- [1,0,0,0,0,1,1,0,0,1,0,0,0,1,1,0,1,1,0,0,0,1,1,0]
print (decode [1, 0, 0, 0, 0, 1, 1, 0, 1, 0, 1, 0, 0, 0, 1, 1, 0, 1, 1, 1, 0, 0, 0, 1, 1, 0, 0]) -- "abc"
-- print (decode (tail [1, 0, 0, 0, 0, 1, 1, 0, 1, 0, 1, 0, 0, 0, 1, 1, 0, 1, 1, 1, 0, 0, 0, 1, 1, 0, 0])) -- "Incorrect!"
print (altMap (+ 10) (+ 100) [0, 1, 2, 3, 4]) -- [10,101,12,103,14]
print (luhn [7, 9, 9, 2, 7, 3, 9, 8, 7, 1, 3]) -- True
8. Declaring types and classes
Exercise 1
data Nat = Zero | Succ Nat
nat2int :: Nat -> Int
nat2int Zero = 0
nat2int (Succ n) = 1 + nat2int n
int2nat :: Int -> Nat
int2nat 0 = Zero
int2nat n = Succ (int2nat (n - 1))
add :: Nat -> Nat -> Nat
add Zero n = n
add (Succ m) n = Succ (add m n)
mult :: Nat -> Nat -> Nat
mult Zero n = Zero
mult (Succ m) n = add (mult m n) n
main = do
print (nat2int (mult (Succ (Succ (Succ Zero))) (Succ (Succ Zero)))) -- 6
Exercise 2
data Tree a = Leaf a | Node (Tree a) a (Tree a)
occurs :: Ord a => a -> Tree a -> Bool
occurs x (Leaf y) = x == y
occurs x (Node l y r) = case compare x y of
EQ -> True
LT -> occurs x l
GT -> occurs x r
t :: Tree Int
t = Node (Node (Leaf 1) 3 (Leaf 4)) 5 (Node (Leaf 6) 7 (Leaf 9))
main = do
print (occurs 5 t) -- True
print (occurs 8 t) -- False
Exercise 3
balanced ってこれでいいんだろうか
data Tree a = Leaf a | Node (Tree a) (Tree a)
cnt :: Tree a -> Int
cnt (Leaf x) = 1
cnt (Node x y) = cnt x + cnt y
balanced :: Tree a -> Bool
balanced (Leaf x) = True
balanced (Node x y) = abs (cnt x - cnt y) <= 1
t1 :: Tree Int
t1 = Node (Node (Leaf 1) (Leaf 2)) (Node (Leaf 3) (Node (Leaf 4) (Leaf 5)))
t2 :: Tree Int
t2 = Node (Node (Leaf 1) (Leaf 2)) (Node (Leaf 3) (Node (Leaf 4) (Node (Leaf 5) (Leaf 6))))
main = do
print (balanced t1) -- True
print (balanced t2) -- False
Exercise 4
data Tree a = Leaf a | Node (Tree a) (Tree a)
deriving (Show)
balance :: [a] -> Tree a
balance [x] = Leaf x
balance xs = Node (balance xs') (balance ys')
where
(xs', ys') = splitAt (length xs `div` 2) xs
main = do
print (balance [1, 2, 3, 4, 5, 6, 7, 8, 9])
{-
Node
(Node
(Node
(Leaf 1) (Leaf 2))
(Node
(Leaf 3) (Leaf 4)))
(Node
(Node
(Leaf 5) (Leaf 6))
(Node
(Leaf 7)
(Node
(Leaf 8) (Leaf 9))))
-}
Exercise 5-6
data Expr = Val Int | Add Expr Expr
folde :: (Int -> a) -> (a -> a -> a) -> Expr -> a
folde f g (Val x) = f x
folde f g (Add x y) = g (folde f g x) (folde f g y)
eval :: Expr -> Int
eval = folde id (+)
size :: Expr -> Int
size = folde (const 1) (+)
main = do
let e = Add (Add (Val 1) (Val 2)) (Add (Add (Val 3) (Val 4)) (Val 5))
print (eval e) -- 15
print (size e) -- 5
Exercise 7
instance Eq a => Eq (Maybe a) where
Just x == Just y = x == y
Nothing == Nothing = True
_ == _ = False
x /= y = not (x == y)
instance Eq a => Eq [a] where
x == y = (length x == length y) && all [x' == y' | (x', y') <- zip x y]
x /= y = not (x == y)
Exercise 8
data Prop
= Const Bool
| Var Char
| Not Prop
| And Prop Prop
| Imply Prop Prop
| Or Prop Prop
| Iff Prop Prop
type Assoc k v = [(k, v)]
type Subst = Assoc Char Bool
find :: Eq k => k -> Assoc k v -> v
find k t = head [v | (k', v) <- t, k == k']
eval :: Subst -> Prop -> Bool
eval _ (Const b) = b
eval s (Var x) = find x s
eval s (Not p) = not (eval s p)
eval s (And p q) = eval s p && eval s q
eval s (Imply p q) = eval s p <= eval s q
eval s (Or p q) = eval s p || eval s q
eval s (Iff p q) = eval s (Imply p q) && eval s (Imply q p)
vars :: Prop -> [Char]
vars (Const _) = []
vars (Var x) = [x]
vars (Not p) = vars p
vars (And p q) = vars p ++ vars q
vars (Imply p q) = vars p ++ vars q
vars (Or p q) = vars p ++ vars q
vars (Iff p q) = vars p ++ vars q
bools :: Int -> [[Bool]]
bools 0 = [[]]
bools n = map (False :) bss ++ map (True :) bss
where
bss = bools (n - 1)
rmdups :: Eq a => [a] -> [a]
rmdups [] = []
rmdups (x : xs) = x : rmdups (filter (/= x) xs)
substs :: Prop -> [Subst]
substs p = map (zip vs) (bools (length vs))
where
vs = rmdups (vars p)
isTaut :: Prop -> Bool
isTaut p = and [eval s p | s <- substs p]
p1 :: Prop
p1 = Iff (Imply (Imply (Var 'A') (Var 'B')) (Var 'C')) (Or (And (Var 'A') (Not (Var 'B'))) (Var 'C'))
p2 :: Prop
p2 = Or (Imply (Var 'A') (Not (Var 'B'))) (And (Var 'C') (Var 'D'))
main = do
print (isTaut p1) -- True
print (isTaut p2) -- False
Exercise 9
data Expr = Val Int | Add Expr Expr | Mul Expr Expr
type Cont = [Op]
data Op = EVAL_ADD Expr | EVAL_MUL Expr | ADD Int | MUL Int
eval :: Expr -> Cont -> Int
eval (Val n) c = exec c n
eval (Add x y) c = eval x (EVAL_ADD y : c)
eval (Mul x y) c = eval x (EVAL_MUL y : c)
exec :: Cont -> Int -> Int
exec [] n = n
exec (EVAL_ADD y : c) n = eval y (ADD n : c)
exec (EVAL_MUL y : c) n = eval y (MUL n : c)
exec (ADD n : c) m = exec c (n + m)
exec (MUL n : c) m = exec c (n * m)
value :: Expr -> Int
value e = eval e []
main = do
print (value (Add (Add (Val 2) (Val 3)) (Val 4))) -- 9
print (value (Mul (Add (Mul (Val 2) (Val 3)) (Val 4)) (Mul (Add (Val 2) (Val 3)) (Val 4)))) -- 200
9. The countdown problem
Exercise 1
choices :: [a] -> [[a]]
choices xs = [ys | sub <- subs xs, ys <- perms sub]
Exercise 2
isChoice :: Eq a => [a] -> [a] -> Bool
isChoice [] [] = True
isChoice [] _ = False
isChoice _ [] = False
isChoice (x : xs) ys = isChoice xs (rm x ys)
Exercise 4
...
es :: [Expr]
es = [e | ns <- choices [1, 3, 7, 10, 25, 50], e <- exprs ns]
main = do
print (length es) -- 33665406
print (length [e | e <- es, not (null (eval e))]) -- 4672540
Exercise 5
valid :: Op -> Int -> Int -> Bool
valid Add _ _ = True
valid Sub _ _ = True
valid Mul _ _ = True
valid Div x y = y /= 0 && x `mod` y == 0
...
es :: [Expr]
es = [e | ns <- choices [1, 3, 7, 10, 25, 50], e <- exprs ns]
main = do
print (length es) -- 33665406
print (length [e | e <- es, not (null (eval e))]) -- 10839369
Exercise 6
c については "a suitable measure of simplicity" が具体的に何なのかわからなかったので，とりあえず () の深さが浅い順にソートしています．
import Data.List
data Op = Add | Sub | Mul | Div | Exp
instance Show Op where
show Add = "+"
show Sub = "-"
show Mul = "*"
show Div = "/"
show Exp = "^"
valid :: Op -> Int -> Int -> Bool
valid Add x y = x <= y
valid Sub x y = x > y
valid Mul x y = x /= 1 && y /= 1 && x <= y
valid Div x y = y /= 0 && y /= 1 && x `mod` y == 0
valid Exp x y = x /= 0 && x /= 1 && y > 1
apply :: Op -> Int -> Int -> Int
apply Add x y = x + y
apply Sub x y = x - y
apply Mul x y = x * y
apply Div x y = x `div` y
apply Exp x y = x ^ y
data Expr = Val Int | App Op Expr Expr
instance Show Expr where
show (Val n) = show n
show (App o l r) = brak l ++ show o ++ brak r
where
brak (Val n) = show n
brak e = "(" ++ show e ++ ")"
values :: Expr -> [Int]
values (Val n) = [n]
values (App _ l r) = values l ++ values r
eval :: Expr -> [Int]
eval (Val n) = [n | n > 0]
eval (App o l r) = [apply o x y | x <- eval l, y <- eval r, valid o x y]
subs :: [a] -> [[a]]
subs [] = [[]]
subs (x : xs) = yss ++ map (x :) yss
where
yss = subs xs
interleave :: a -> [a] -> [[a]]
interleave x [] = [[x]]
interleave x (y : ys) = (x : y : ys) : map (y :) (interleave x ys)
perms :: [a] -> [[a]]
perms [] = [[]]
perms (x : xs) = concat (map (interleave x) (perms xs))
choices :: [a] -> [[a]]
choices = concat . map perms . subs
split :: [a] -> [([a], [a])]
split [] = []
split [_] = []
split (x : xs) = ([x], xs) : [(x : ls, rs) | (ls, rs) <- split xs]
ops :: [Op]
ops = [Add, Sub, Mul, Div, Exp]
type Result = (Expr, Int)
combine' :: Result -> Result -> [Result]
combine' (l, x) (r, y) = [(App o l r, apply o x y) | o <- ops, valid o x y]
results :: [Int] -> [Result]
results [] = []
results [n] = [(Val n, n) | n > 0]
results ns = [res | (ls, rs) <- split ns, lx <- results ls, ry <- results rs, res <- combine' lx ry]
depth :: Expr -> Int
depth (Val n) = 1
depth (App o l r) = 1 + max (depth l) (depth r)
solutions'' :: [Int] -> Int -> [Expr]
solutions'' ns n = if minDiff == 0 then [e | (e, d) <- sols''] else [fst (head sols'')]
where
sols = [(e, abs (m - n)) | ns' <- choices ns, (e, m) <- results ns']
minDiff = minimum (map snd sols)
sols' = filter ((== minDiff) . snd) sols
sols'' = sortOn (depth . fst) sols'
main = do
print (solutions'' [1, 3, 7, 10, 25, 50] 765) -- [(25-10)*(1+50),(25-(3+7))*(1+50),((25-3)-7)*(1+50),((25-7)-3)*(1+50), ..., (50*(25+((3-1)^7)))/10]
print (solutions'' [1, 3, 7, 10, 25, 50] 831) -- [7+((1+10)*(25+50))]