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