競プロ AOJ Haskell

オンラインジャッジを使って体で覚えるHaskell入門 パート4

Haskell完全初心者向けにHaskellを理論ではなく実際にAizu Online Judgeの問題を解きながら体で覚えようというHaskell入門シリーズの第4弾です。
Feb. 8, 2020, 12:30 p.m.

この記事の対象読者と目的

この記事は、Haskell完全初心者向けにHaskellを理論ではなく実際にAizu Online Judgeの問題を解きながら体で覚えようというHaskell入門シリーズの第4弾です。

前回までの内容はこちら。

オンラインジャッジを使って体で覚えるHaskell入門 パート3

目次

ITP1_5_A - 長方形の描画

問題

コンソールで長方形を描く問題です。

https://onlinejudge.u-aizu.ac.jp/courses/lesson/2/ITP1/all/ITP1_5_A

解答

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
main = readAndDo

readAndDo = do
  line <- getLine
  if line == "0 0" then return ()
  else do
    solve . input $ line
    putStrLn ""
    readAndDo

-- 入力
input :: String -> [Int]
input = (map read) . words

-- 解答
solve [0, b] = return ()
solve [a, b] = do
  putStrLn $ foldr (++) "" $ replicate b "#"
  solve [a-1, b]

新しい要素は特にありません。
横一列に#を出力するきれいな方法が分からなかったのでreplicateでリストを生成し、foldrで文字列連結するという方法を取りました。

ITP1_5_B - フレームの描画

問題

以下のようなフレームを描画する問題です。

####
#..#
#..#
####

https://onlinejudge.u-aizu.ac.jp/courses/lesson/2/ITP1/all/ITP1_5_B

解答

 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
main = readAndDo

readAndDo = do
  line <- getLine
  if line == "0 0" then return ()
  else do
    let [a, b] = input line
    solve [a, b, a]
    putStrLn ""
    readAndDo

-- 入力
input :: String -> [Int]
input = (map read) . words

-- 解答
solve [0, b, c] = return ()
solve [a, 1, c] = do
  putStrLn "#"
  solve [a-1, 1, c]
solve [a, b, c]
  | a == 1 || a == c = do
    putStrLn $ foldr (++) "" $ replicate b "#"
    solve [a-1, b, c]
  | otherwise = do
    putStrLn $ "#" ++ (foldr (++) "" $ replicate (b-2) ".") ++ "#"
    solve [a-1, b, c]

新しい要素はありません。
枠の最上列と最下列だけ特別ですべて#なので、パターンマッチで判定するようにしました。

ITP1_5_C - チェスボードの描画

問題

#.が交互に出現するチェスボードを描画する問題です。

https://onlinejudge.u-aizu.ac.jp/courses/lesson/2/ITP1/all/ITP1_5_C

解答

 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
main = readAndDo

readAndDo = do
  line <- getLine
  if line == "0 0" then return ()
  else do
    let [a, b] = input line
    solve [0..a-1] b
    putStrLn ""
    readAndDo

-- 入力
input :: String -> [Int]
input = (map read) . words

-- 解答
solve [] b = return ()
solve (a:xs) b = do
  putStrLn $ foldr (++) "" $ map (flip a) $ [0..b-1]
  solve xs b
  where
    flip y x | y `mod` 2 == 0 && x `mod` 2 == 0 = "#"
             | y `mod` 2 == 0 && x `mod` 2 == 1 = "."
             | y `mod` 2 == 1 && x `mod` 2 == 0 = "."
             | y `mod` 2 == 1 && x `mod` 2 == 1 = "#"

座標に応じて正しく#.を選択するところでプログラミング的に苦労しました。
結局flipという関数にまとまっていて、縦と横のインデックスがそれぞれ決まれば#.が一意に決まります。

Haskell的に新しいのは、(a:xs)という新しいタイプのパターンマッチが登場しています。
以前から[a, b]というタイプのリストのパターンマッチは何度も登場していますが、このタイプは固定長のリストにのみマッチします。
[a, b][1, 2, 3, 4]などの要素が2つではないリストにはマッチしません。
一方で(x:xs)タイプは要素が1つ以上のすべてのリストにマッチします。
[1, 2, 3, 4]であれば、x = 1, xs = [2, 3, 4]というように値が代入されます。
[1]の場合にはx = 1, xs = []という値が代入されます。
ただし、空のリストにはマッチしません。
そのためにsolve [] b = return ()のパターンマッチを書いています。
Haskellではこのように1つの関数に対して引数のパターンごとに処理を分けて書くことが出来ます。
空のリストを受け取った時には何も出力せずにreturnしています。

ITP1_5_D - 構造化プログラミング

問題

C言語のGOTOで書かれた難解なロジックをHaskellで書き直すという問題です・・・(読み取りが難しいです)。

https://onlinejudge.u-aizu.ac.jp/courses/lesson/2/ITP1/all/ITP1_5_D

解答

 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
import Text.Printf

main = getLine >>= solve 1 . input

-- 入力
input :: String -> Int
input = read

-- 解答
include3 i x n
  | x `mod` 10 == 3 = do
    p i
    solve (i + 1) n
  | otherwise = do
    let x' = div x 10
    if x' > 0 then include3 i x' n
    else solve (i + 1) n

solve i n | i > n = putStrLn ""
  | otherwise= do
    if i `mod` 3 == 0 then do
      p i
      solve (i+1) n
    else do
      include3 i i n

p i = putStr $ printf " %d" i

目新しいことは無いですが、循環参照の関数を2つ定義してみました。
問題なくコンパイルは通りました。

ITP1_6_A - 数列の反転

問題

リストを反転(リバース)する問題です。

https://onlinejudge.u-aizu.ac.jp/courses/lesson/2/ITP1/all/ITP1_6_A

解答

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
main = do
  _ <- getLine
  getLine >>= solve . input

-- 入力
input :: String -> [Int]
input = map read . words

-- 解答
solve xs = putStrLn . unwords . map show . reverse' $ xs

reverse' [] = []
reverse' (x:xs) = (reverse' xs) ++ [x]

Haskellの標準関数にもreverseはあると思いますが、勉強のために実装してみました。
正解でしたが、この書き方だと末尾再帰最適化が効かなそうな気がするので再実装しました。

1
2
3
4
solve xs = putStrLn . unwords . map show . (reverse' []) $ xs

reverse' acc [] = acc
reverse' acc (x:xs) = reverse' (x:acc) xs

C言語とかであればこれで末尾再帰最適化が効くようになります。
が、実装後に遅延評価Haskellではこれは無意味という記事を見つけました。
さらに、デフォルトで遅延評価をOFFにするオプションもあるそうです。
これは良さそうですね。

ITP1_6_B - 不足しているカードの発見

問題

欠けているトランプのカードを列挙する問題です。

https://onlinejudge.u-aizu.ac.jp/courses/lesson/2/ITP1/all/ITP1_6_B

解答

1
2
import Data.List
main = getContents >>= putStr . unlines . (\\) [x ++ " " ++ show y | x <- ["S", "H", "C", "D"], y <- [1..13]] . lines

この問題が1行で解けるなんて、Haskellは本当に驚きですね。
決して無理をして1行に収めているわけではなく、自然にデータの流れを書いていくと1行になっています。

アルゴリズム的な解説としては、まず52枚の全パターンのカードを列挙して、そこから入力のカードのリストを引いて残ったものを出力します。

今回新しく登場した1番大きいものはリスト内包表記です。
リストのフィルタやマップに使用できます。
例えば1から20の偶数のリストであれば[x | x <- [1..20], xmod2 == 0]のように書けます。

今回使っているのは以下の部分です。

[x ++ " " ++ show y | x <- ["S", "H", "C", "D"], y <- [1..13]]

変数が1つだけではなく2つ使っています。
この場合はxyの2つのリストの要素同士の全ての組み合わせ(デカルト積)を列挙する事ができます。
これでカードを全て列挙しています。

もう1つ新しい関数としてData.Listにある\\です。
これはリストの差分を返します。

ITP1_6_C - 公舎の入居者数

問題

複数のマンションに対して入居・退去の情報が可変長で与えられるので最終的な全戸の入居人数を出力する問題です。
C++なら配列を1つ用意してそれを更新していけば簡単に求まります。
が、変数への代入が使えないのでどうするかという感じですね。

https://onlinejudge.u-aizu.ac.jp/problems/ITP1_6_C

解答

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
import Data.List

main = getContents >>= putStrLn.solve.parseInput.tail.lines
  where
    buildingSep = replicate 20 '#'
    floorSep = "\n"
    space = ' '
    parseInput = map (map read . words)
    solve input = intercalate floorSep . intersperse buildingSep $ buildings
      where
        buildings = [intercalate floorSep $ floors b | b <- [1..4]]
        floors b = [space:(unwords $ rooms b f) | f <- [1..3]]
        rooms b f = [show $ numPersons b f r input | r <- [1..10]]
        numPersons b f r input = numPersons' b f r 0 input
        numPersons' _ _ _ acc [] = acc
        numPersons' b f r acc ([xb, xf, xr, xv]:xs)
          | b == xb && f == xf && r == xr = numPersons' b f r (acc + xv) xs
          | otherwise = numPersons' b f r acc xs

これをwhereを使っているにしても1行で解けるのははっぱりHaskell楽しいですね!
しかも

さて、新しい要素としてはintercalate関数とintersperse関数の2つです。
intercalate関数は、intercalate 区切り文字列 文字列リストという2つの引数をとります。
そして、文字列リストを区切り文字列で連結した新しい文字列を返します。
例えば、以下のように書くと、

1
putStr $ intercalate "\n" ["aaa", "bbb", "ccc"]

以下のような出力になります。

aaa
bbb
ccc

リストを改行で繋げる関数には他にunlinesが以前出てきました。
が、unlinesは最後の行にも改行を入れる点がintercalateと異なります。
今回はそれが理由で使えませんでした。

intersperse関数はintersperse 区切り文字列 文字列リストという2つの引数をとります。
が、intercalateと違うのは文字列に連結せずにリストのまま返すところです。

例えば以下のように書くと、

1
putStr $ intersperse "\n" ["aaa", "bbb", "ccc"]

以下のデータが返ります。

1
["aaa", "\n", "bbb", "\n", "ccc"]

ITP1_6_D - ベクトルと行列の積

問題

ベクトルと行列が1つずつ与えられるのでその積を求める問題です。
積の定義を知らなくても計算方法は問題文中に書いてあります。
数学ではなく純粋なプログラミングの問題です。

https://onlinejudge.u-aizu.ac.jp/courses/lesson/2/ITP1/all/ITP1_6_D

解答

1
2
3
4
5
6
7
8
9
main = getContents >>= putStr . unlines . map show . solve . parseInput . map parseLine . lines
  where
    solve (matrix, vector) = map (mul vector) matrix
    mul vec row = sum $ zipWith (*) row vec
    parseInput ([n,m]:xs) = parseMV n m [] [] xs
    parseMV 0 0 mAcc vAcc xs = (mAcc, vAcc)
    parseMV 0 m mAcc vAcc (x:xs) = parseMV 0 (m-1) mAcc (vAcc ++ x) xs
    parseMV n m mAcc vAcc (x:xs) = parseMV (n-1) m (mAcc ++ [x]) vAcc xs
    parseLine = map read . words :: String -> [Int]

この問題も関数合成で1つの関数で解くことが出来ました。
linesunlinesが対になっているときれいな感じがしますね。

Haskell的に新しい要素はzipWith関数です。
これはzipという有名な関数の亜種なので、まずはzipの方を説明します。
zipはリストを2つ受け取ってそれを1つのタプルにして返します。
例えば、zip [1, 2, 3, 4] [10, 100, 1000, 10000]であれば[(1, 10), (2, 100), (3, 1000), (4, 10000)]です。
zipWithの方は、さらに第1引数に関数を受け取り、結果をただタプルにするのではなくこの関数を適用します。
例えば、zip (*) [1, 2, 3, 4] [10, 100, 1000, 10000]であれば*を毎回適用するので[10, 200, 3000, 40000]となります。
これを利用して行列の行とベクトルの積を計算しています。

ここまで解いた後に調べているうちにinteractsplitAtという2つの関数の存在を知りました。
interactは入力を受け取って出力するという便利な関数で、これまで毎回書いてきたgetContents >>= putStrをそのままinteractに置き換えられます。
splitAtはリストをあるインデックスで前後2つに分ける関数です。
今回行列部分とベクトル部分を区切るために長々と書いたparseMVを置き換えられます。

上記2つの関数を使うと以下のように短くきれいになりました。

1
2
3
4
5
6
7
8
main = interact $ unlines . show' . solve . read' . lines
  where
    solve (matrix, vector) = map (sum . zipWith (*) vector) matrix
    show' = map show
    read' (nm:xs) = (map (map read .words) matrix, map read vector)
      where
        (matrix, vector) = splitAt n xs
        n = head . (map read) . words $ nm