练习#
备注
所有习题均来自 Exercism。
简单#
华氏度和摄氏度#
华氏度F和摄氏度C的关系为：C = (F - 32) / 1.8。
题
定义两个函数，华氏度定义为整型，摄氏度为浮点型，实现华氏度和摄氏度的相互转换。转换为摄氏度时，结果向上取整。
例
输入：华氏 -148 度
输出：摄氏 -100.0 度
输入：摄氏 0.0 度
输出：华氏 32 度
解答
1module Temperature
2 ( tempToC
3 , tempToF
4 ) where
5
6type Fahrenheit = Integer
7type Celsius = Float
8
9-- fromInteger 将整型转换为浮点型
10tempToC :: Fahrenheit -> Celsius
11tempToC temp = (fromInteger temp - 32) / 1.8
12
13-- ceiling 自动将浮点型转换为整型
14tempToF :: Celsius -> Fahrenheit
15tempToF temp = ceiling $ temp * 1.8 + 32
倍数之和#
题
给定一串数字和一个上限值，计算该串数字所有小于上限值且不重复的倍数之和。
例
输入：[3, 5] 和 20
输出：3 + 6 + 9 + 12 + 15 + 18 + 5 + 10 = 78
解答 1
1module SumOfMultiples
2 ( sumOfMultiples
3 ) where
4
5import Data.Set ( fromList
6 , toList
7 )
8
9-- 去除小于 0 的数字
10-- 遍历数字列表
11-- 计算每个数字在上限范围内倍数的个数
12-- 若数字为 0，则个数也为 0
13-- 逐个列出所有倍数
14-- 去重并求和
15sumOfMultiples :: [Integer] -> Integer -> Integer
16sumOfMultiples factors limit = sum . toList $ fromList -- 备注*
17 [ multiple
18 | x <- filter (>= 0) factors
19 , let entries = if x == 0 then [0] else [1 .. (limit - 1) `div` x]
20 , y <- entries
21 , let multiple = x * y
22 ]
23
24-- 备注：对于大列表，toList . fromList 的速度比 nub 的速度高得多，
25-- 但占用空间也更多。详见 GHCi 中的比较
ghci> :set +s
ghci> sumOfMultiples' [3, 5] 100000 -- 使用 'nub'
2333316668
(17.31 secs, 19,809,520 bytes)
ghci> sumOfMultiples [3, 5] 100000 -- 使用 'toList' 和 'fromList'
2333316668
(0.10 secs, 33,174,568 bytes)
解答 2
1module SumOfMultiples
2 ( sumOfMultiples
3 ) where
4
5import Data.Set ( fromList
6 , toList
7 )
8
9-- 去除小于 0 的数字
10-- 从 1 遍历到上限减 1，判断数字是否为该串数字中任意一个数字的倍数
11-- 筛选出这样的数字并求和
12sumOfMultiples' :: [Integer] -> Integer -> Integer
13sumOfMultiples' factors limit =
14 sum $ filter divisableBy [1 .. limit - 1]
15 where
16 -- 判断某数字是否是该串数字的倍数
17 divisableBy :: Integer -> Bool
18 divisableBy n = any ((== 0) . (n `mod`)) $ filter (>= 0) factors
19
20-- 备注：相比解答 1，此实现速度稍慢，占用空间更大
完全数#
完全数，也叫完美数，是由古希腊数学家尼科马库斯提出的整数分类方法。若一个数除本身外的所有因数之和正好等于该数本身，则该数为完全数，和大于本身的为盈数，小于的为亏数（所有质数均为亏数）。
题
给定一个非负整数，判断是否为完全数、盈数或亏数。
例
输入：6
输出：完全数
解释：1 + 2 + 3 = 6
输入：12
输出：盈数
解释：1 + 2 + 3 + 4 + 6 = 16 > 12
输入：8
输出：亏数
解释：1 + 2 + 4 = 7 < 8
解答
1module PerfectNumbers
2 ( classify
3 , Classification(..)
4 ) where
5
6data Classification = Deficient | Perfect | Abundant deriving (Eq, Show)
7
8-- 判断数字是否有效
9-- 寻找因数并求和，再根据和判断是否为完全数、盈数或亏数
10classify :: Int -> Maybe Classification
11classify num | num > 0 = Just $ aliquot num
12 | otherwise = Nothing
13 where
14 -- 根据因数的和判断类型
15 aliquot :: Int -> Classification
16 aliquot n | sum (factors n) == n = Perfect
17 | sum (factors n) > n = Abundant
18 | otherwise = Deficient
19 -- 分解因数
20 -- 最大因数只能为该数的一半，因此不用遍历至 n - 1
21 factors :: Int -> [Int]
22 factors n = [ x | x <- [1 .. n `div` 2], n `mod` x == 0 ]
电话号码#
北美编号方案是一种在北美地区广泛使用的电话号码编号系统。该方案由一个国家码后跟 10 位数组成，后 10 位又由 3 位区域码和 7 位本地码组成，而本地码又由 3 位交换码和 4 为用户码组成，即：
(NXX)-NXX-XXXX
其中N取值范围为 2 到 9 的闭区间，X的取值范围为 0 到 9 的闭区间。
题
给定一串号码，输出有效的 10 位号码。由于本题仅处理北美编号方案的号码，因此国家码只有 1 有效。
例
输入：+1 (613)-995-0253
输出：6139950253
输入：613.995.0253
输出：6139950253
解答 1
1module Phone
2 ( number
3 ) where
4
5import Data.Char ( isNumber )
6
7-- 提取数字后判断国家码
8-- 去除国家码并验证剩余号码是否有效
9number :: String -> Maybe String
10number [] = Nothing
11number nums
12 | length cleaned == 11 && head cleaned == '1'
13 = validate . tail $ cleaned
14 | length cleaned == 10
15 = validate cleaned
16 | otherwise
17 = Nothing
18 where
19 -- 提取数字
20 cleaned :: String
21 cleaned = filter isNumber nums
22 -- 若第 1 和第 4 位数字在 2 到 9 之内，则号码有效
23 validate :: String -> Maybe String
24 validate ns | isValid 0 ns && isValid 3 ns = Just ns
25 | otherwise = Nothing
26 where
27 -- 对应数字必须在 2 到 9 之内
28 isValid :: Int -> String -> Bool
29 isValid index xs = '2' <= xs !! index && xs !! index <= '9'
解答 2
1module Phone
2 ( number
3 ) where
4
5import Data.Char ( isDigit )
6
7number :: String -> Maybe String
8number = check . dropCountryCode . filter isDigit
9 where
10 -- 第一位为 1 的只能是国家码
11 dropCountryCode :: String -> String
12 dropCountryCode ns = if head ns == '1' then tail ns else ns
13 -- 守卫匹配失败的会继续下一个模式匹配
14 check :: String -> Maybe String
15 check phone@[a, _, _, b, _, _, _, _, _, _]
16 | a > '1' && b > '1' = Just phone
17 check _ = Nothing
克拉兹猜想#
克拉兹猜想可描述为如下：
有任意整数 \(n\)，若该整数为奇数，则将该数乘以 3 后加 1 得到 \(n \times 3 + 1\)；若为偶数，则除以 2 得到 \(n \div 2\)；重复该过程。克拉兹猜想认为，无论起始值是多少，最终都会得到 1。
题
给定起始值 \(n\)，返回得到 1 需要的最少步骤。
例
输入：5
输出：5
解释：1. 5 * 3 + 1 = 16
2. 16 / 2 = 8
3. 8 / 2 = 4
4. 4 / 2 = 2
5. 2 / 2 = 1
解答 1
1module CollatzConjecture
2 ( collatz
3 ) where
4
5-- 判断是否为有效数字
6-- 使用无限列表无限计算下去，直到得到数字 1
7-- 从起始值到 1 之间元素的个数即为最少步骤
8collatz :: Integer -> Maybe Integer
9collatz n | n <= 0 = Nothing
10 | otherwise = return $ steps n
11 where
12 -- 打印从起始值开始无限计算下去的所有中间值
13 allValues :: Integer -> [Integer]
14 allValues n = scanl (flip ($)) n $ repeat nextValue
15 -- 计算下一个值
16 nextValue :: Integer -> Integer
17 nextValue n | odd n = n * 3 + 1
18 | otherwise n = n `div` 2
19 -- 1 之前的中间值个数
20 steps :: Integer -> Integer
21 steps = toInteger . length . takeWhile (/= 1) . allValues
解答 2
1module CollatzConjecture
2 ( collatz
3 ) where
4
5-- 判断数字是否有效
6-- 数字为 1 时，返回 Just 0，该值为递归的出口
7-- 每返回一层递归，便加 1，递归结束便得到最少步骤
8collatz :: Integer -> Maybe Integer
9collatz n | n <= 0 = Nothing
10 | n == 1 = Just 0
11 | even n = succ <$> collatz (n `div` 2)
12 | otherwise = succ <$> collatz (n * 3 + 1)
统计碱基#
核苷酸是 DNA 和 RNA 的组成部分。组成 DNA 的核苷酸中包含 A、C、G 和 T 四种碱基。通常将 DNA 序列表示为一串由“ACGT”四个字母组成的字符串。
题
给定一串 DNA 序列，统计每个碱基的数量，无效输入应报错。
例
输入："GATTACA"
输出：'A': 3, 'C': 1, 'G': 1, 'T': 2
输入："INVALID"
输出：报错
解答 1
1module DNA
2 ( nucleotideCounts
3 , Nucleotide(..)
4 ) where
5
6import Data.Map ( Map
7 , fromList
8 )
9
10data Nucleotide = A | T | G | C deriving (Eq, Ord, Show)
11
12-- 判断 DNA 是否有效
13-- 使用 filter 筛选指定碱基并统计个数
14-- 统计所有碱基并返回结果
15nucleotideCounts :: String -> Either String (Map Nucleotide Int)
16nucleotideCounts xs
17 | all (`elem` "ATGC") xs = Right (countNucleotides xs)
18 | otherwise = Left "Invalid DNA"
19 where
20 -- 统计指定碱基在 DNA 序列中的个数
21 amount :: Char -> String -> Int
22 amount ch = length . filter (== ch)
23 -- 统计四种碱基在 DNA 序列中的个数并返回映射
24 countNucleotides :: String -> Map Nucleotide Int
25 countNucleotides dna = fromList
26 [ (A, amount 'A' dna)
27 , (T, amount 'T' dna)
28 , (G, amount 'G' dna)
29 , (C, amount 'C' dna)
30 ]
解答 2
1module DNA
2 ( nucleotideCounts
3 , Nucleotide(..)
4 ) where
5
6import Data.Char ( toUpper )
7import Data.Map ( Map
8 , fromListWith
9 )
10
11data Nucleotide = A | T | G | C deriving (Eq, Ord, Show, Read)
12
13-- 判断 DNA 是否有效
14-- 创建默认映射
15-- 遍历 DNA，遇到相应碱基便加 1
16-- fromListWith 可处理重复的键，对逐字统计很有用
17-- 返回结果
18nucleotideCounts :: String -> Either String (Map Nucleotide Int)
19nucleotideCounts xs
20 | all (`elem` "ATGC") xs = Right $ countNucleotides xs
21 | otherwise = Left "Invalid DNA"
22 where
23 -- 默认数量
24 defaultCounts :: [(Nucleotide, Int)]
25 defaultCounts = [(A, 0), (T, 0), (G, 0), (C, 0)]
26 -- 逐个统计碱基数量，用 'fromListWith' 处理重复的键
27 countNucleotides :: String -> Map Nucleotide Int
28 countNucleotides dna =
29 fromListWith (+)
30 $ [ (read [toUpper d], 1) | d <- dna ]
31 ++ defaultCounts
32
33-- 备注：相比解答 1，此实现速度更慢，占用空间更大
RNA 转录#
RNA 转录是遗传信息由 DNA 转换到 RNA 的过程。DNA 和 RNA 均由一系列核苷酸组成，DNA 包含 A、C、G 和 T 四种碱基，而 RNA 包含 A、C、G 和 U 四种碱基。
DNA 根据碱基互补原则生成 RNA：
- G 转换为 C；
- C 转换为 G；
- A 转换为 U；
- T 转换为 A；
题
给定一串 DNA 序列，返回 RNA 序列，无效输入应返回第一个无效字符。
例
输入："ACGTTA"
输出："UGCAAU"
输入："AADTTE"
输出：'D'
解答 1
1module DNA
2 ( toRNA
3 ) where
4
5-- 转录单个碱基
6-- 合并两个碱基，使用 <$> 和 <*> 合并两个函子
7-- 通过 foldl 合并多个转录后的碱基
8toRNA :: String -> Either Char String
9toRNA = foldl mergeNuc (pure "") . map transcribe
10 where
11 -- 合并两个转录后的碱基
12 mergeNuc :: Either Char String -> Either Char String
13 -> Either Char String
14 mergeNuc x y = (++) <$> x <*> y
15 -- 转录单个碱基
16 transcribe :: Char -> Either Char String
17 transcribe dna | dna == 'A' = Right "U"
18 | dna == 'T' = Right "A"
19 | dna == 'G' = Right "C"
20 | dna == 'C' = Right "G"
21 | otherwise = Left dna
解答 2
1module DNA
2 ( toRNA
3 ) where
4
5type Nucleotide = Char
6type DNA = [Nucleotide]
7type RNA = [Nucleotide]
8
9-- 转录单个碱基
10-- 合并多个碱基，使用 mapM 直接将函子列表合并为一个包含列表的函子
11toRNA :: DNA -> Either Nucleotide RNA
12toRNA = mapM transcribe
13-- mapM :: (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b)
14 where
15 -- 转录单个碱基
16 transcribe :: Nucleotide -> Either Nucleotide Nucleotide
17 transcribe nuc | nuc == 'A' = Right 'U'
18 | nuc == 'T' = Right 'A'
19 | nuc == 'G' = Right 'C'
20 | nuc == 'C' = Right 'G'
21 | otherwise = Left nuc
秘密通信#
题
假设有一种二进制秘密通信叫“handshake”，其规则如下：
1 = wink
10 = double blink
100 = close your eyes
1000 = jump
10000 = 将操作倒序排序
给定一个整数，按上述规则返回秘密通信的操作序列。
例
输入：3
输出：wink 和 double wink
解释：3 的二进制为 11，即 10 + 1
输入：19
输出：double wink 和 wink
解答 1
1module SecretHandshake
2 ( handshake
3 ) where
4
5-- 将数字转换为二进制
6-- 若数字大于 10000，则倒序排序
7-- 将二进制转换为字符串
8-- 将字符串倒序排序，对应索引若为 1，则返回相应索引位置的操作
9handshake :: Int -> [String]
10handshake n = if toBinary n >= 10000
11 then reverse . generate . take 4 $ bin
12 else generate bin
13 where
14 -- 二进制转换为字符串后倒序排序
15 bin :: String
16 bin = reverse . show . toBinary $ n
17 -- 对应索引为 1，则包括对应索引的操作
18 generate :: String -> [String]
19 generate s = [ dict !! x | x <- [0 .. length s - 1], s !! x == '1' ]
20 where
21 dict :: [String]
22 dict = ["wink", "double blink", "close your eyes", "jump"]
23 -- 转换为（伪）二进制
24 toBinary :: Int -> Int
25 toBinary 0 = 0
26 toBinary d = 10 * toBinary (d `div` 2) + d `mod` 2
解答 2
1module SecretHandshake
2 ( handshake
3 ) where
4
5handshake :: Int -> [String]
6handshake = handshakeAcc []
7 where
8 -- 从大到小逐个减去，不必转换为二进制
9 handshakeAcc :: [String] -> Int -> [String]
10 handshakeAcc acc i
11 | i >= 16 = reverse $ handshakeAcc acc (i - 16)
12 | i >= 8 = handshakeAcc ("jump" : acc) (i - 8)
13 | i >= 4 = handshakeAcc ("close your eyes" : acc) (i - 4)
14 | i >= 2 = handshakeAcc ("double blink" : acc) (i - 2)
15 | i == 1 = handshakeAcc ("wink" : acc) (i - 1)
16 | otherwise = acc
首字母缩写#
众所周知，程序员喜欢 TLA（三字母缩写）。
题
给定一个字符串，生成首字母缩写词。
例
输入："Portable Network Graphics"
输出："PNG"
输入："Ruby on Rails"
输出："ROR"
输入："HyperText Markup Language"
输出："HTML"
解释：驼峰命名法
输入："The Road _Not_ Taken"
输出："TRNT"
解释：强调
输入："Complementary metal-oxide semiconductor"
输出："CMOS"
解释：连字符
输入："Halley's Comet"
输出："HC"
解答 1
1module Acronym
2 ( abbreviate
3 ) where
4
5import Data.Char ( isAlpha
6 , isUpper
7 )
8import qualified Data.Text as T
9
10-- 替换连字符为空格，方便分词
11-- 分词
12-- 去除单词首尾的非字母字符
13-- 首字母未大写的单词转换为大写
14-- 将小写字母替换为 '-'，方便处理驼峰大写
15-- 按 '-' 拆分单词
16-- 取首字母并合并
17abbreviate :: String -> String
18abbreviate = map T.head . splitText . T.pack
19
20-- 将字符串转换为多组大写字母的列表
21splitText :: T.Text -> [T.Text]
22splitText =
23 concatMap (splitCamels . toCapital . noPunctuations)
24 . T.words
25 . noHyphens
26 where
27 -- 将连字符转换为空格以便分词
28 noHyphens :: T.Text -> T.Text
29 noHyphens = T.replace (T.pack "-") (T.pack " ")
30 -- 将小写字母替换为 '-' 以便区分驼峰命名和全大写
31 -- HyperText 变为 H----T----
32 -- GNU 变为 GNU
33 splitCamels :: T.Text -> [T.Text]
34 splitCamels = filter (not . T.null)
35 . T.splitOn (T.singleton '-')
36 . T.map (\c -> if isUpper c then c else '-')
37 -- 去除首尾非字母字符
38 noPunctuations :: T.Text -> T.Text
39 noPunctuations = T.dropAround (not . isAlpha)
40 -- 首字母大写
41 toCapital :: T.Text -> T.Text
42 toCapital t = let (l, r) = T.splitAt 1 t in T.toUpper l <> r
解答 2
1module Acronym
2 ( abbreviate
3 ) where
4
5import Data.Char ( isAlpha
6 , isLower
7 , isUpper
8 , toUpper
9 )
10
11-- 自左向右逐个处理字符
12-- 用二元元组保存上一字符和提取的有效首字母
13-- 若上一字符为非字母但不为 "'"，当前字符为字母，保留
14-- 若上一字符为小写，当前字符为大写，保留（驼峰）
15-- 其余情况，跳过
16-- 返回提取的有效首字母
17abbreviate :: String -> String
18abbreviate = snd . foldl keepChar (' ', [])
19 where
20 -- 比较前后两个字符并保留有效首字母
21 keepChar :: (Char, String) -> Char -> (Char, String)
22 keepChar (prev, abbr) crt
23 | (not (isAlpha prev) && prev /= '\'') && isAlpha crt
24 = (crt, abbr ++ [toUpper crt])
25 | isLower prev && isUpper crt
26 = (crt, abbr ++ [crt])
27 | otherwise
28 = (crt, abbr)
普通#
异序词#
同素异序词，指所用字母相同但字母顺序不同而组成的新单词。
题
给定一个词和一组词，从该组词中找出该词的同素异序词。
例
输入："listen" 和 ["enlists", "google", "inlets", "banana"]
输出：["inlets"]
输入："master" 和 ["Stream", "pigeon", "maters"]
输出：["Stream", "maters"]
解释：大小写不敏感
输入："go" 和 ["go", "GO"]
输出：[]
解释：同素异序词不能为单词本身
解答 1
1module Anagram
2 ( anagramsFor
3 ) where
4
5import Data.Char ( toLower )
6import Data.Map ( Map
7 , fromListWith
8 )
9
10-- 将字符串转换为小写
11-- 统计单词中字母的出现次数
12-- 若字频相同，且两个字符串不同，则为异序词
13anagramsFor :: String -> [String] -> [String]
14anagramsFor pat cands =
15 [ cand
16 | cand <- cands
17 , let c = map toLower cand
18 , let p = map toLower pat
19 , p /= c
20 , frequency p == frequency c
21 ]
22 where
23 -- 统计字母在单词中的出现次数
24 frequency :: String -> Map Char Int
25 frequency str = fromListWith (+) [ (ch, 1) | ch <- str ]
解答 2
1module Anagram
2 ( anagramsFor
3 ) where
4
5import Data.Char ( toLower )
6import Data.List ( sort )
7
8-- 将字符串转换为小写
9-- 若排序后两者相同，且原字符串不同，则为异序词
10anagramsFor :: String -> [String] -> [String]
11anagramsFor pat cands =
12 [ cand
13 | let p = map toLower pat
14 , cand <- cands
15 , let c = map toLower cand
16 , p /= c
17 , sort p == sort c
18 ]
时钟#
题
实现一个 24 小时制的时钟数据类型，要求该时钟数据为Eq类型类的成员，且实现了以下方法：
toString：将时钟数据转换为字符串，0 补位；fromHourMin：从小时和分钟构造时钟数据；addDelta：时钟经过指定小时数和分钟数；
例
toString
输入：8 时 0 分
输出：08 : 00
输入：13 时 25 分
输出：13 : 25
fromHourMin
输入：25, 0
输出：01 : 00
输入：25, 160
输出：03 : 40
addDelta
输入：0, 65 和 22 : 55
输出：00 : 00
输入：0, -30 和 10 : 03
输出：09 : 33
解答 1
1module Clock
2 ( addDelta
3 , fromHourMin
4 , toString
5 ) where
6
7type Hour = Int
8type Minute = Int
9
10data Clock = Clock Hour Minute deriving Eq
11
12-- 直接相加
13addDelta :: Hour -> Minute -> Clock -> Clock
14addDelta hour minute (Clock h m) = fromHourMin (hour + h) (minute + m)
15
16-- 对分钟数取模
17-- 时钟数加上分钟数超过的部分再取模
18fromHourMin :: Hour -> Minute -> Clock
19fromHourMin hour minute =
20 let m = minute `mod` 60
21 h = (hour + minute `div` 60) `mod` 24
22 in Clock h m
23
24-- 将数字字符串化
25-- 判断字符串长度
26-- 若为 1，添加 0
27-- 否则，保留原样
28toString :: Clock -> String
29toString (Clock hour minute) = padding hour ++ ":" ++ padding minute
30 where
31 padding :: Int -> String
32 padding n | length (show n) == 1 = '0' : show n
33 | otherwise = show n
解答 2
1module Clock
2 ( addDelta
3 , fromHourMin
4 , toString
5 ) where
6
7import Text.Printf ( printf )
8
9-- 以分钟数储存时间
10newtype Clock = Clock {getMinutes :: Int} deriving Eq
11
12-- 一天总分钟数为 1440 分钟
13fromHourMin :: Int -> Int -> Clock
14fromHourMin h m = Clock $ (h * 60 + m) `mod` 1440
15
16-- printf 函数更简单
17-- divMod 函数方便地将商、余打包，实现进位效果
18toString :: Clock -> String
19toString clock =
20 let (h, m) = getMinutes clock `divMod` 60 in printf "%02d:%02d" h m
21
22addDelta :: Int -> Int -> Clock -> Clock
23addDelta h m clock = fromHourMin h $ getMinutes clock + m
二叉查找树#
二叉查找树是一种有序数据结构。
假设有顺序数组[1, 3, 4, 5]，当向该数组插入2时，有两种插入方案：
- 追加到数组末尾并对整个数组重新排序；
- 找到
2的正确位置后添加空位并插入；
两种插入方案都会消耗大量的空间或时间。为了高效处理有序数据，二叉查找树应运而生。
二叉树由一系列节点组成。每个节点都包含一个数据，左子树和右子树，子树又指向另一个子树或空节点。子树中，左子树包含所有小于或等于当前节点的值，右子树包含所有大于当前节点的值。例如，当向以下二叉树插入6时：
4
/
2
结果为：
4
/ \
2 6
再次插入3后结果为：
4
/ \
2 6
\
3
题
定义一个二叉树数据类型BST并使其成为Eq和Show类型类的成员。要求实现下列函数：
bstLeft：返回左子树；bstRight：返回右子树；bstValue：返回当前节点的值；empty：返回空节点；fromList：根据列表生成二叉树；insert：将值插入二叉树中；singleton：返回仅包含一个节点的二叉树；toList：根据二叉树生成列表；
解答
1module BST
2 ( BST
3 , bstLeft
4 , bstRight
5 , bstValue
6 , empty
7 , fromList
8 , insert
9 , singleton
10 , toList
11 ) where
12
13-- 递归定义代数数据类型
14data BST a = EmptyNode | Node a (BST a) (BST a) deriving (Eq, Show)
15
16bstLeft :: BST a -> Maybe (BST a)
17bstLeft EmptyNode = Nothing
18bstLeft (Node _ l _) = Just l
19
20bstRight :: BST a -> Maybe (BST a)
21bstRight EmptyNode = Nothing
22bstRight (Node _ _ r) = Just r
23
24bstValue :: BST a -> Maybe a
25bstValue EmptyNode = Nothing
26bstValue (Node x _ _) = Just x
27
28empty :: BST a
29empty = EmptyNode
30
31-- 遍历列表并逐个将每个值插入空节点中
32fromList :: Ord a => [a] -> BST a
33fromList = foldl (flip insert) EmptyNode
34
35insert :: Ord a => a -> BST a -> BST a
36insert x EmptyNode = singleton x
37insert x (Node a l r) | x > a = Node a l (insert x r)
38 | otherwise = Node a (insert x l) r
39
40singleton :: a -> BST a
41singleton x = Node x EmptyNode EmptyNode
42
43toList :: BST a -> [a]
44toList EmptyNode = []
45toList (Node x l r) = toList l ++ [x] ++ toList r
皇后攻击#
国际象棋中，皇后可以攻击同一行、同一列和同一对角线上的棋子。
题
实现以下函数：
boardString：打印 \(8 \times 8\) 大小的棋盘，白皇后用W表示，黑皇后用B表示，空白格子用_表示：_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ W _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ B _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
canAttack：给定两个皇后的坐标(row, column)，判断两个皇后是否能相互攻击；
例
输入：(2, 3) 和 (5, 6)
输出：boardString 返回题目中的棋盘，canAttack 返回 True
解答
1module Queens
2 ( boardString
3 , canAttack
4 ) where
5
6type Board = String
7type Coordinates = (Int, Int)
8type Queen = Maybe Coordinates
9
10-- 逐个判断棋子
11boardString :: Queen -> Queen -> Board
12boardString white black = unlines
13 [ unwords
14 [ chess
15 | c <- [0 .. 7]
16 , let chess | Just (r, c) == white = "W"
17 | Just (r, c) == black = "B"
18 | otherwise = "_"
19 ]
20 | r <- [0 .. 7]
21 ]
22
23-- 同一行行号相等，同一列列号相等
24-- 同一对角线横、纵坐标差值的绝对值相等
25canAttack :: Coordinates -> Coordinates -> Bool
26canAttack queenA queenB =
27 rA == rB || cA == cB || abs (rA - rB) == abs (cA - cB)
28 where
29 (rA, cA) = queenA
30 (rB, cB) = queenB
杨辉三角#
杨辉三角，也称帕斯卡三角，每一个数都由上一行左右两侧的数相加而来。
题
给定一个整数行号，返回从第一行到该行部分的杨辉三角。
例
输入：4
输出：1
1 1
1 2 1
1 3 3 1
输入：0
输出：无
解答 1
1module Triangle
2 ( rows
3 ) where
4
5-- 根据上一行计算当前行
6-- 添加缺失的首尾
7rows :: Int -> [[Integer]]
8rows x | x <= 0 = []
9 | x == 1 = [[1]]
10 | otherwise = prevRows ++ [[1] ++ walk (last prevRows) ++ [1]]
11 where
12 -- 当前行之前的所有行
13 prevRows :: [[Integer]]
14 prevRows = rows $ x - 1
15 -- 将上一行两两相加
16 walk :: [Integer] -> [Integer]
17 walk l@(a : b : _) = a + b : walk (tail l)
18 walk _ = []
解答 2
1module Triangle
2 ( rows
3 ) where
4
5-- 不断对前一结果应用相同函数、并保留所有结果的操作
6-- 适合使用函数 iterate
7rows :: Int -> [[Integer]]
8rows x = take x $ iterate next [1]
9 where
10 -- 首尾添加 0 后错位相加
11 next :: [Integer] -> [Integer]
12 next row = zipWith (+) (0 : row) (row ++ [0])
栅栏加密法#
栅栏加密法是一种古典加密法。
对于明文，仅保留明文中的字母和数字，然后将明文从左到右、从上到下书写为c列r行的方块，按列从上到下、从左到右重新将文本书写为一行。将文本分成c个r长度的文本块，并用空格分隔，若文本长度比c * r短n个字符，则在最后n个文本块末尾各补一个空格，得到最后的密文。
题
给定一个明文字符串，输出加密后的密文。
例
输入："Hello World!"
输出："hol ewd lo lr "
解释：1. "helloworld"
2. "hell"
"owor"
"ld "
3. "holewdlolr"
4. "hol ewd lo lr "
解答
1module CryptoSquare
2 ( encode
3 ) where
4
5import Data.Char ( isAlphaNum
6 , toLower
7 )
8import Data.List ( transpose )
9
10-- 转置后直接用空格连接文本块便可得到要求的密文
11encode :: String -> String
12encode xs =
13 let ns = map toLower . filter isAlphaNum $ xs
14 l = length ns
15 (c, r) = square l
16 chunks = chunksOf c $ ns ++ replicate (c * r - l) ' '
17 in unwords . transpose $ chunks
18 where
19 -- 递归在指定索引处分隔字符串
20 chunksOf :: Int -> String -> [String]
21 chunksOf _ [] = []
22 -- 也可以使用 take n str : chunksOf n (drop n str)
23 chunksOf n str = let (f, s) = splitAt n str in f : chunksOf n s
24 -- 平方根后向上取整，得到最接近正方形边长的值
25 square :: Int -> (Int, Int)
26 square n =
27 let c = ceiling $ sqrt (fromIntegral n :: Double)
28 in if c * (c - 1) >= n then (c, c - 1) else (c, c)
Luhn 算法#
Luhn 算法，一种简单的校验和算法。Luhn 算法通常用于身份识别码，如国际移动设备辨识码、加拿大社会保险码等。Luhn 算法的校验步骤如下：
- 小于两位数的无效；
- 去除空格；
- 从右向左，奇数位不变，偶数位乘 2，若乘 2 后结果为两位数，则结果减去 9；
- 将所有数字相加；
- 若和能被 10 整除，则该数字为有效数字，否则无效；
题
给定一串数字字符串，使用 Luhn 算法判断是否有效。
例
输入："4539 3195 0343 6467"
输出：有效
输入："8273 1232 7352 0569"
输出：无效
输入："0"
输出：无效
解答 1
1module Luhn
2 ( isValid
3 ) where
4
5import Data.Char ( digitToInt
6 , intToDigit
7 , isDigit
8 )
9
10-- 倒序排序
11-- zipWith 为每个字符标号
12-- 根据奇偶位进行计算
13-- 验证总和
14isValid :: String -> Bool
15isValid ds
16 | length fn <= 1
17 = False
18 | otherwise
19 = checksum
20 . map snd
21 . zipWith (curry validate) [1 .. length fn]
22 -- 倒序排序后再编号
23 $ reverse fn
24 where
25 -- 去除空格
26 fn :: String
27 fn = filter isDigit ds
28 -- 将每个字符进行编号后判断奇偶位
29 validate :: (Int, Char) -> (Int, Char)
30 validate (n, d) | odd n = (n, d)
31 | otherwise = (n, intToDigit doubled)
32 where
33 doubled =
34 let db = digitToInt d * 2
35 in if db >= 10 then db - 9 else db
36 -- 求和后取模
37 checksum :: String -> Bool
38 checksum xs = sum (map digitToInt xs) `mod` 10 == 0
解答 2
1module Luhn
2 ( isValid
3 ) where
4
5import Data.Char ( digitToInt
6 , isDigit
7 )
8
9isValid :: String -> Bool
10isValid ds | length (normalize ds) < 2 = False
11 | otherwise = luhn (normalize ds) `mod` 10 == 0
12 where
13 -- 转化为数字后直接校验，不必转回字符串
14 normalize :: String -> [Int]
15 normalize = map digitToInt . reverse . filter isDigit
16 -- 递归求和，偶数位用 (_ : y : _) 模式匹配
17 luhn :: [Int] -> Int
18 luhn [] = 0
19 luhn [x] = x
20 luhn (x : y : zs) =
21 x + (if y < 5 then y * 2 else y * 2 - 9) + luhn zs
找质数#
题
给定一个整数n，找到第n个质数。
例
输入：3
输出：5
输入：10001
输出：104743
解答 1
1module Prime
2 ( nth
3 ) where
4
5-- 在无限列表中筛选出质数，再索引对应值
6nth :: Int -> Maybe Integer
7nth n | n > 0 = Just (toInteger $ filter isPrime [1 ..] !! (n - 1))
8 | otherwise = Nothing
9 where
10 -- 分解质因数，若只有 1 和该数本身，则该数为质数
11 isPrime :: Int -> Bool
12 isPrime a =
13 [ (x, a `div` x) | x <- [1 .. a], a `mod` x == 0 ]
14 == [(1, a), (a, 1)]
解答 2
1module Prime
2 ( nth
3 ) where
4
5nth :: Int -> Maybe Integer
6nth n | n > 0 = Just $ primes !! (n - 1)
7 | otherwise = Nothing
8 where
9 primes :: [Integer]
10 primes = sieve [2 ..]
11 -- 质数不是所有质数的倍数
12 sieve :: [Integer] -> [Integer]
13 sieve [] = []
14 sieve (p : ps) = p : sieve [ x | x <- ps, x `mod` p /= 0 ]
15
16-- 备注：该实现比解答 1 的速度快得多
扫雷#
扫雷是一款风靡全球的经典游戏。在一句游戏中，雷场上会标记多个数字提示，每个数字代表在以该数字为中心的九宫格中埋下的地雷数，而游戏要求玩家根据数字提示挖出所有地雷。
题
若用*表示地雷，用空格表示无地雷，给定一个雷场，要求标注出数字提示。
例
输入：·*·*·
··*··
··*··
输出：1*3*1
13*31
·2*2·
解释：为方便表示，此例用 '·' 标注空格
相邻格子无地雷的，保留空格
解答 1
1module Minesweeper
2 ( annotate
3 ) where
4
5import Data.Char ( intToDigit )
6
7type Board = [String]
8type Coordinates = (Int, Int)
9type Square = (Coordinates, Char)
10
11-- 为所有格子标注坐标
12-- 获取指定格子相邻格子的合法坐标，并计算地雷数
13-- 若当前格子为地雷，则保留
14-- 若有地雷，则替换为地雷数，否则保留
15-- 返回标注结果
16annotate :: Board -> Board
17annotate board = map (map reveal) . enumerate $ board
18 where
19 -- 雷场的列数
20 columns :: Int
21 columns = length . head $ board
22 -- 雷场的行数
23 rows :: Int
24 rows = length board
25 -- 若该格子为地雷，则保留
26 -- 若相邻格子有地雷，则替换为数字，否则保留
27 reveal :: Square -> Char
28 reveal (coord, c)
29 | c == '*'
30 = c
31 | otherwise
32 = let cnt = countMines coord
33 in if cnt > 0 then intToDigit cnt else c
34 -- 获取该坐标相邻格子的合法坐标
35 -- 若相邻格子有地雷，则返回地雷数
36 countMines :: Coordinates -> Int
37 countMines (x, y) = length
38 [ (x', y')
39 | x' <- [x - 1 .. x + 1]
40 , x' >= 0 && x' < columns
41 , y' <- [y - 1 .. y + 1]
42 , y' >= 0 && y' < rows
43 , board !! y' !! x' == '*'
44 ]
45 -- 为雷场的所有格子标注坐标
46 enumerate :: Board -> [[Square]]
47 enumerate = zipWith
48 zip
49 [ [ (x, y) | x <- [0 .. columns - 1] ] | y <- [0 .. rows - 1] ]
解答 2
1module Minesweeper
2 ( annotate
3 ) where
4
5import Data.Char ( intToDigit )
6
7annotate :: [String] -> [String]
8annotate m = zipWith (zipWith toChar) mines adj
9 where
10 -- 布尔值表示该格是否原为地雷
11 mines :: [[Bool]]
12 mines = (map . map) (== '*') m
13 -- 数字表示地雷数量
14 adj :: [[Int]]
15 adj = smooth . (map . map $ fromEnum) $ mines
16 -- 根据布尔值和数字转换为字符
17 toChar :: Bool -> Int -> Char
18 toChar True _ = '*'
19 toChar False 0 = ' '
20 toChar False n = intToDigit n
21
22-- 相邻三行相加，然后相邻三列相加
23smooth :: [[Int]] -> [[Int]]
24smooth = map (trips add3 0) . trips (zipWith3 add3) (repeat 0)
25 where
26 add3 :: Num a => a -> a -> a -> a
27 add3 a b c = a + b + c
28
29-- 相邻三行或三列相加
30-- 在首尾补 0，防止超出索引范围
31trips :: (a -> a -> a -> b) -> a -> [a] -> [b]
32trips f border = go . (++ [border]) . (border :)
33 where
34 go l@(a : b : c : _) = f a b c : go (tail l)
35 go _ = []