Yifu's Blog
0%

Programming in Haskell Chapter10 Exercises Solutions

Posted on Edited on In

Programming in Haskell是一本入门Haskell的好书，介绍页面以及配套的slides, vedios, codes都在这里。

第九章的习题暂时跳过了，先更第十章。
开学了，事情多了起来，还要找工作，加把劲最近把这本书刷完吧！:P

其实从第8章开始，这本书对于monad就讲的太少，过几天这本书要出第二版，希望能在这方面改进改进。。。
我下单了一本《Haskell趣学指南》，打算结合起来看，然后再补上跳过的习题。

定义函数 mult :: Nat -> Nat -> Nat

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
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 _ = Zero
mult (Succ m) n = add (mult m n) n

-- *Main> nat2int(mult (int2nat 2) (int2nat 3))
-- 6
-- *Main> nat2int(mult (int2nat 0) (int2nat 3))
-- 0
-- *Main> nat2int(mult (int2nat 1) (int2nat 3))
-- 3
-- *Main> nat2int(mult (int2nat 10) (int2nat 13))
-- 130

重新定义occurs :: Int -> Tree -> Bool

需要使用标准库data Ordering = LT | EQ | GT, 以及
compare :: Ord => a -> a -> Ordering。

1
2
3
4
5
6
7
8
9
data Tree = Leaf Int | Node Tree Int Tree
tr :: Tree
tr = Node (Node (Leaf 1) 3 (Leaf 4)) 5 (Node (Leaf 6) 7 (Leaf 9))
occurs :: Int -> Tree -> Bool
occurs m (Leaf n) = m == n
occurs m (Node l n r) = case compare m n of
                            LT -> occurs m l
                            EQ -> True
                            GT -> occurs m r

判断平衡树balanced :: Tree -> Bool

平衡树：左、右子树的叶子数量相差不超过一个

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
data Tree1 = Leaf1 Int | Node1 Tree1 Tree1

t1 :: Tree1
t1 = Node1 (Node1 (Leaf1 1) (Leaf1 4)) (Node1 (Leaf1 6) (Leaf1 9))

t2 :: Tree1
t2 = Node1 (Node1 (Leaf1 1) (Node1 (Leaf1 1) (Leaf1 4))) (Node1 (Leaf1 6) (Leaf1 9))

t3 :: Tree1
t3 = Node1 (Node1 (Leaf1 1) (Node1 (Leaf1 1) (Leaf1 4))) (Leaf1 6)
leafs :: Tree1 -> Int
leafs (Leaf1 _) = 1
leafs (Node1 l r) = leafs l + leafs r

balanced :: Tree1 -> Bool
balanced (Leaf1 _) = True
balanced (Node1 l r) = abs (leafs l - leafs r) <= 1

-- *Main> balanced t1
-- True
-- *Main> balanced t2
-- True
-- *Main> balanced t3
-- False

根据list生成一个平衡树

思路也蛮简单，把list分成两半，然后递归就成了。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
balance :: [Int] -> Tree1
balance xs
    | null xs = error ""
    | length xs == 1 = Leaf1 (head xs)
    | otherwise = Node1 (balance x) (balance y)
                    where n = length xs `div` 2
                          x = take n xs
                          y = drop n xs

flatten :: Tree1 -> [Int]
flatten (Leaf1 n) = [n]
flatten (Node1 l r) = flatten l ++ flatten r

-- *Main> flatten (balance [])
-- *** Exception:
-- CallStack (from HasCallStack):
--   error, called at ch10ex.hs:71:24 in main:Main
-- *Main> flatten (balance [1])
-- [1]
-- *Main> flatten (balance [1,2,3,4])
-- [1,2,3,4]

修改Tautology checker使之支持\/(disjunction)和<=>(equivalence)运算符

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
type Assoc k v = [(k, v)]
find :: Eq k => k -> Assoc k v -> v
find k t = head [v | (k', v) <- t, k == k']

data Prop = Const Bool
          | Var Char
          | Not Prop
          | And Prop Prop
          | Disj Prop Prop -- disjunction
          | Equi Prop Prop -- equivalence
          | Imply Prop Prop



type Subst = Assoc Char Bool
-- [('A', True), ('B', False)]

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 (Disj p q) = eval s p || eval s q
eval s (Equi p q) = eval s p == eval s q
eval s (Imply p q) = eval s p <= eval s q

vars :: Prop -> String
vars (Const _) = []
vars (Var x) = [x]
vars (Not p) = vars p
vars (And p q) = vars p ++ vars q
vars (Disj p q) = vars p ++ vars q
vars (Equi p q) = vars p ++ vars q
vars (Imply 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 us) (bools (length us))
            where us = rmdups (vars p)
isTaut :: Prop -> Bool
isTaut p = and [eval s p | s <- substs p]

p1 :: Prop
p1 = Equi (Var 'A') (Not (Var 'A'))
p2 :: Prop
p2 = Equi (Var 'A') (Var 'A')
p3 :: Prop
p3 = Equi (Disj (Not (Var 'B')) (Var 'A')) (Disj (Var 'A') (Var 'B'))

-- p4 : (!(!(!P \/ Q) \/ P) \/ P)
p4 :: Prop
p4 = Disj (Not (Disj (Not (Disj (Not (Var 'A')) (Var 'B'))) (Var 'A'))) (Var 'A')

-- *Main> isTaut p1
-- False
-- *Main> isTaut p2
-- True
-- *Main> isTaut p3
-- False
-- *Main> isTaut p4
-- True

扩展Abstract machine使之支持乘法

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
-- 7 abstract machine
data Expr = Val Int | Add Expr Expr | Mul Expr Expr
-- value :: Expr -> Int
-- value (Val n) = n
-- value (Add x y) = value x + value y

type Cont = [Op]
data Op = EVALADD Expr | EVALMUL Expr | ADD Int | MUL Int

eval :: Expr -> Cont -> Int
eval (Val n) c = exec c n
eval (Add x y) c = eval x (EVALADD y : c)
eval (Mul x y) c = eval x (EVALMUL y : c)

exec :: Cont -> Int -> Int
exec [] n = n
exec (EVALADD y : c) n = eval y (ADD n : c)
exec (EVALMUL 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 []

p1 :: Expr
p1 = Add (Mul (Val 3) (Val 2)) (Val 5) -- 3 * 2 + 5

p2 :: Expr
p2 = Add (Mul (Val 3) (Add (Val 3) (Val 2))) (Val 1) -- 3 * (3 + 2) + 1

-- *Main> value p2
-- 16
-- *Main> value p1
-- 11