コンテンツにスキップ

Haskell

関数プログラミング 珠玉のアルゴリズムデザイン

Reference

はじめに 関数プログラミング 珠玉のアルゴリズムデザイン

数学や物理, 特に物理を学ぶのに関数プログラミング, 特に Haskell が非常にうまく使えるという話がある. それを見て Haskell の勉強が急務だと思い色々な形で Haskell への知見を深めている.

例えば別企画で次のような記事 (群) もある.

そして何となくアルゴリズムをきちんと勉強しないといけないのかな, とずっと思って放置したままになっている. とりあえずいい加減何かやってみようと思い, 何となく買ってみたのが Richard Bird の pearls of functional algorithm design だ.

英語版を手に入れたのだが翻訳があったらしいと後で気付いた.

ウルトラ難しく 1 章を読んだ時点で既に心が折れている. ただせっかく読んだ分は記録に残しておきたい. 他の数学、物理系プログラミングを進めていて, うんざりしてきたら現実逃避でこちらを進めるというのもあっていいだろうとは思っている.

この本, Graham の本と同じスタイル, つまり正確なコードを書かずに一部疑似コード (疑似記号?) を使っていて, 慣れていないとすぐに翻訳できないのが最高に鬱陶しい. 例えば第 1 章で言うと本の P.1 で出てくる $\notin$ は not . flip elem のように表現しないといけないよう (本当によくわかっていない) だし, 本の P.2 で出てくる $\lor$ は本来の Haskell コードでは || だ.

先に書いたように最近また精力的に数学や物理, プログラミングのコンテンツを作っているけれども, こういうのはよくないな, と痛感させられるコンテンツだ. そういう意味でも厳しいコンテンツを見てみることは役に立つと思って, 無理せずゆるくやっていこう.

追記

翻訳者の山下伸夫さんからコメントを頂いてしまった.

Functional Pearls of Algorithm Designのプログラム表記と、ASCII記号によるHaskellプログラム表記との対応については、 http://pfad.sampou.org/ に追記しましたので、御笑覧くださいませ。

引用しておこう.

演算子記号とASCII文字列との対応

  • 本書の記号: HaskellのASCII文字
  • ≤: <=
  • ≥: >=
  • ∨: ||
  • ∧: &&
  • ⋅: .
  • ≠: /=
  • ∈: elem
  • ∉: notElem
  • ⊑: isPrefixOf
  • div: div
  • mod: mod
  • min: min
  • max: max
  • knows: knows

演算子以外の構文記号の一部については，GHCの言語拡張UnicodeSyntaxを有効にするとソースコード中に記述可能です． 詳細については，GHCユーザーガイド 9.3.1 Unicode syntaxをご覧ください．

演算子に関しては，Unicodeの記号が使えますので，たとえば，1章については，以下のような定義モジュールをインポートすれば，そのままコードで表現できます．

{-# LANGUAGE UnicodeSyntax #-} module Operators where

import qualified Data.List

infixr 5 \

(\) ∷ Eq a ⇒ [a] → [a] → [a] (\) = (Data.List.\)

infix 4 ∈, ∉

(∈) ∷ Eq a ⇒ a → [a] → Bool (∈) = elem

(∉) ∷ Eq a ⇒ a → [a] → Bool (∉) = notElem

infixr 2 ∨

(∨) ∷ Bool → Bool → Bool (∨) = (||)

infixr 3 ∧

(∧) ∷ Bool → Bool → Bool (∧) = (&&)

infix 4 ≤, ≥

(≤) ∷ Ord a ⇒ a → a → Bool (≤) = (<=)

(≥) ∷ Ord a ⇒ a → a → Bool (≥) = (>=)

数学関係だとほとんどコメント来ないのに (素人くさい) プログラミングの話だと やたら本質的に私が助かるコメントが来るのでありがたさしかない.

1. The smallest free number (最小自然数) 関数プログラミング 珠玉のアルゴリズムデザイン

投稿用メモ

  • URL: http://phasetr.com/blog/2017/01/05/smallest-free-number-pearls-of-func-algorithm/
  • title: Haskellで最小の自然数を求めるアルゴリズム
  • descripttion: 数学や物理、特に物理を学ぶのに関数プログラミング、特にHaskellが非常にうまく使えるという話がある。それを見てHaskellの勉強が急務だと思い色々な形でHaskellへの知見を深めている。その一環としてアルゴリズムも勉強しようと思い『関数プログラミング 珠玉のアルゴリズムデザイン』を読んでいく記録を残している。

導入部

集合$X \subset \mathbb{N}$の最小値を求めようという問題を考えよう. もちろん適当に派生的な問題もあるし現実的な応用もある. 解は$X$がどのように表現されているかによる.

任意の数のリストを線型時間でソートするアルゴリズムを考えてみる. 次のminfreeのような挙動をする関数を作りたい.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
-- Int を Nat にしたい: Nat 自体は例えば Data.Nat にはある. 適当にインポートしたりする必要あり?
minfree :: [Int] -> Int
--minfree xs = head $ [0..] Data.List.\\ xs
minfree xs = head $ [0..] Main.\\ xs

-- Data.List.\\ にある関数: 本の記述では notElem が TeX でいう $\notin$ の記号で書かれていた.
(\\) :: Eq a => [a] -> [a] -> [a]
us \\ vs = filter (not . flip elem vs) us

main = do
  let a = [8, 23, 9, 0, 12, 11, 1, 10, 13, 7, 41, 4, 14, 21, 5, 17, 3, 19, 2, 6]
--  print $ Data.List.sort a
  print $ minfree a

1
: 15

この関数minfreeは$O(n^2)$のオーダーなので困る. これをどうにかしたい.

Haskellの配列による解法

[0 .. length xs] の全ての要素が xs に入っているわけではないことに注意する. xs に入っていない最小の数は filter (<= (length xs)) xs に入っていない最小の数だ.

結果から書くと次のようになる. この実装は xs の要素が全て違う必要はないものの自然数であることは要請する.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
import Data.Array

minfree' = search . checklist

search :: Array Int Bool -> Int
search = length . takeWhile id . elems

checklist :: [Int] -> Array Int Bool
checklist xs = accumArray (||) False (0, n) $ zip (filter (<= n) xs) (repeat True)
    where n = length xs

main = do
  print $ minfree' [8, 23, 9, 0, 12, 11, 1, 10, 13, 7, 41, 4, 14, 21, 5, 17, 3, 19, 2, 6]

1
2
:
: 15

こんなさっくり書かれて意味がわかるわけもない. 当然 search と checklist をそれぞれじっくり追うしかない. まずは checklist を見てみる.

checklist

たぶん慣れていないと accumArray がめんどい. というかいまだにきちんと理解しきれていない. 次の節で別立てで見ることにして, まずは accumArray に食わせるリストを作るところからはじめよう. つまり zip (filter ( <= n) xs) (repeat True) だ.

repeat True は全要素がブーリアン True の無限リストを作る. zip ではめて有限リストを切り出している.

zip にかけるもう一方のリストは filter (<= n) xs で作る. これは特に言うことない.

1
2
3
4
5
6
7
main = do
  let xs = [8, 23, 9, 0, 12, 11, 1, 10, 13, 7, 41, 4, 14, 21, 5, 17, 3, 19, 2, 6]
  let n = length xs
  let a = zip (filter (<= n) xs) (repeat True)
  -- print $ repeat True
  print $ filter (<= n) xs
  print a

1
2
: [8,9,0,12,11,1,10,13,7,4,14,5,17,3,19,2,6]
: [(8,True),(9,True),(0,True),(12,True),(11,True),(1,True),(10,True),(13,True),(7,True),(4,True),(14,True),(5,True),(17,True),(3,True),(19,True),(2,True),(6,True)]

これでタプルのリストができる. このタプルのリストを accumArray にくわせる.

accumArray

多分これが一番めんどい. 泥臭くコード片を追いかけないとわからない. ふだん (手続き型で?) 書くときはループで書くところを関数でスパっと書いている感じ. 逐次 print デバッグみたいなのがやりづらいので何をやっているかまだ追いづらい. 多分慣れればもっとサクサク書けるのだろうなとは思う.

とにかく泥臭く追いかけよう. foldr などと同じくコレクションに関数を順次適用させて新たなコレクションを作る系の処理だ. 実コード例は次の通り.

1
2
3
4
5
6
7
import Data.Array

main = do
  -- 配列の添字は [1..3]
  -- 配列の各要素は第 2 引数 0 で初期化される
  let a = [(1, 2), (3, 4), (1, 5)]
  print $ accumArray (+) 0 (1,3) a

1
: array (1,3) [(1,7),(2,0),(3,4)]

accumArray の第 1 引数は当てる関数, 第 2 引数は初期値, 第 3 引数は新たな配列の添字の範囲, 第 4 引数はなめていく配列だ. Python あたりの標準的な記法を使って配列、リストを表すことにしよう. accumArray の結果の配列を b とする.

b[1] からはじまるので b[1] がどうなるかを調べよう. 結果から行くと a[0] と a[2] の第 1 要素の和, つまり b[1] = a[0][1] + a[2][1] になる. これを見ていく.

基本は a をなめていくのだ.

  • a[0][0] を調べると 1: これと b[1] の値を関連づける. 初期値は 0 で + を使うことになる. + のもう一方の引数として a[0][1] を使う.
  • 結果として b[1] = 0 + a[0][1] になる.
  • 次に a[1][0] を調べると 3: これと b[3] の値を関連づける. 初期値は 0 で + を使うことになる. + のもう一方の引数として a[1][1] を使う.
  • 結果として b[3] = 0 + a[1][1] になる.
  • 次に a[2][0] を調べると 1: これと b[1] の値を関連づける. 初期値は 0 で + を使うことになる. + のもう一方の引数として a[2][1] を使う.
  • 結果として b[1] = 0 + a[0][1] + a[2][1] になる.
  • 一度も出てこない b[2] は初期値そのまま b[2] = 0.

これが上の accumArray の結果.

checklist は 0 から $n$ 個までの $n+1$ スロットある. 最初は全て False だ.

改めて書くと次のように定義される.

1
2
3
4
5
6
7
8
minfree' = search . checklist

search :: Array Int Bool -> Int
search = length . takeWhile id . elems

checklist :: [Int] -> Array Int Bool
checklist xs = accumArray (||) False (0, n) $ zip (filter (<= n) xs) (repeat True)
    where n = length xs

Boolean の配列 (Data.Array) から整数を取る. この整数はもとのリストの最小値にあたる. この他に関数の合成 (.) も使っている.

elems から見ていこう. これは配列の要素をリストに格納して返す.

1
2
3
4
5
6
import Data.Array

main = do
  let a = listArray (0,3) [1,2,3,4]
  print $ a
  print $ elems a

1
2
: array (0,3) [(0,1),(1,2),(2,3),(3,4)]
: [1,2,3,4]

これも特に問題ないだろう. よくわからないのは id. なぜこれを挟む必要があるのだろうか? 外したらエラーになった. takeWhile に predicate を食わせないといけないからその役割なのだろうか. そう思えば必要な理由は理解できる. 今の私のレベルでは自分で書こうとすると多分解決できずそのまま死にそう.

takeWhile は predicate を食わせてそれが True を返すうちはリストを返し続けてくれる関数. False が来たら打ち切ってそこまでの長さを測れば目的の値が取れる.

分割統治法(divide & conquer)

xsの要素は全て異なることを前提にしている. 基本的なアイデアはリストを分けてそのリストのそれぞれに対処するべし.

最初のコードは次の通り. 徐々に改善する.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
import Data.List
minfreeDivideAndConquer b xs =
  if null ([0..b-1] Data.List.\\ us)
  then head ([b..] Data.List.\\ vs)
  else head ([0..] Data.List.\\ us)
  where (us, vs) = partition (< b) xs

main = do
  let a = [8, 23, 9, 0, 12, 11, 1, 10, 13, 7, 41, 4, 14, 21, 5, 17, 3, 19, 2, 6]
  print $ Data.List.sort a
  print $ minfreeDivideAndConquer 4 a

1
2
: [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,17,19,21,23,41]
: 15

いくつか関数の挙動を調べておこう. まずはnull.

1
2
3
main = do
  print $ null []
  print $ null [1]

1
2
3
:
: True
: False

次にpartition.

1
2
3
import Data.List
main = do
  print $ Data.List.partition (< 2) [1,2,3,4]

1
: ([1],[2,3,4])

最初の改良点はnull ([0..b-1] Data.List.\\ us)で, $O(n^2)$かかるこの処理を軽くしたい. リストに重複がなければnull ([0..b-1] \\ us) == (length us == b)であることを使う. ここでリストに重複がないことを使っている. これと次のminfromを使う.

1
2
minfrom :: Int -> [Int] -> Int
minfrom a xs = head ([a..] \\ xs)

そこで次のコードが出てくる.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
import Data.List
b = 5
minfreeDivideAndConquer' xs = minfrom 0 xs
minfrom a xs | null xs            = a
             | length us == b - a = minfrom b vs
             | otherwise          = minfrom a us
  where (us, vs) = partition (< b) xs

main = do
  print $ minfreeDivideAndConquer' [8, 23, 9, 0, 12, 11, 1, 10, 13, 7, 41, 4, 14, 21, 5, 17, 3, 19, 2, 6]

このコードをrunhaskellで動かそうと思ったら動かない. エラーになるわけではなく処理が回りっぱなしという感じ. 何なのだろう.

何はともあれ, 上のコードはb=5のハードコードが気に入らない. これを消した以外にもlength usを何度も計算しないように whereに押し込めたりと工夫したのが次のコード.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
import Data.List
minfreeDivideAndConquer'' xs = minfrom 0 (length xs, xs)
minfrom a (n, xs) | n == 0     = a
                  | m == b - a = minfrom b (n - m, vs)
                  | otherwise  = minfrom a (m, us)
  where (us, vs) = partition (< b) xs
        b        = a + 1 + n `div` 2
        m        = length us

main = do
  print $ minfreeDivideAndConquer'' [8, 23, 9, 0, 12, 11, 1, 10, 13, 7, 41, 4, 14, 21, 5, 17, 3, 19, 2, 6]

1
2
:
: 15

今回はこれでおしまい.

2. A surpassing problem (上位者問題) 関数プログラミング 珠玉のアルゴリズムデザイン

投稿用メモ

  • URL:
  • title: Haskellで上位者問題を解くアルゴリズム
  • descripttion: 数学や物理、特に物理を学ぶのに関数プログラミング、特にHaskellが非常にうまく使えるという話がある。それを見てHaskellの勉強が急務だと思い色々な形でHaskellへの知見を深めている。その一環としてアルゴリズムも勉強しようと思い『関数プログラミング 珠玉のアルゴリズムデザイン』を読んでいく記録を残している。

元書籍とここまでの内容

書籍
原著
翻訳

翻訳の公式ページはここ.

ここまでの内容

冒頭部

Rem による解法では二分探索を使っていたそうだが, この本では分割統治法を使うとのこと 配列の要素の上位者は右にある要素より大きい要素のことをいう. 例えば $i<j$ かつ $x[i] < x[j]$ なら $x[j]$ は $x[i]$ の上位者であるという.

文字列と文字に対してアルファベットが小さい方が上位者という順序をつければ, 次のように上位者数がカウントできる.

G E N E R A T I N G
5 6 2 5 1 4 0 1 0 0

Specification

作る関数は msc (maximum surpassor count の略) と名付けられている. 次の実装は $O(n^2)$ なのでもっと軽くしたいという話.

1
2
3
4
5
6
7
8
9
msc :: Ord a => [a] -> Int
msc xs = maximum [scount z zs | z : zs <- tails xs]
scount x xs = length (filter (x <) xs)

tails [ ] = [ ]
tails (x : xs) = (x : xs) : tails xs

main = do
  print $ msc [1,2,3,4]

1
: 3

標準ライブラリにも Data.List.tails があるがそれとは別に新たに定義する. 具体的には空リストを返さない. tails の挙動を調べておこう.

1
2
3
4
5
tails [] = []
tails (x : xs) = (x : xs) : tails xs

main = do
  print $ tails [1,2,3,4]

1
: [[1,2,3,4],[2,3,4],[3,4],[4]]

標準ライブラリの Data.List.tails は次の通り.

1
2
3
import Data.List
main = do
  print $ Data.List.tails [1,2,3,4]

1
: [[1,2,3,4],[2,3,4],[3,4],[4],[]]

分割統治法

$O(n \log n)$ のオーダーにしたい.

全ての上位者数のテーブルを作る.

1
2
3
4
5
6
7
8
9
scount x xs = length (filter (x <) xs)

tails [ ] = [ ]
tails (x : xs) = (x : xs) : tails xs

table xs = [(z, scount z zs) | z : zs <- tails xs]

main = do
  print $ table [1,2,3,4,6,5]

1
: [(1,5),(2,4),(3,3),(4,2),(6,0),(5,0)]

このとき msc' = maximum . map snd . table とすれば第 2 の msc ができる.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
scount x xs = length (filter (x <) xs)

tails [ ] = [ ]
tails (x : xs) = (x : xs) : tails xs

table xs = [(z, scount z zs) | z : zs <- tails xs]

msc' = maximum . map snd . table

main = do
  print $ table [1,2,3,4,6,5]
  print $ msc' [1,2,3,4,6,5]

1
2
: [(1,5),(2,4),(3,3),(4,2),(6,0),(5,0)]
: 5

ちなみに snd は名前の通り (タプルの) 2 番目を取ってくる関数. 1 番目を取りたければ fst.

1
2
3
4
main = do
  let l = [(1,5),(2,4),(3,3),(4,2),(6,0),(5,0)]
  print $ map fst l
  print $ map snd l

1
2
: [1,2,3,4,6,5]
: [5,4,3,2,0,0]

もっと効率よく

これではまだ不満: 分割統治法のために table (xs ++ ys) = join (table xs) (table ys) をみたす線型時間の join を作りたい.

本では間にごちゃごちゃ計算 (式または関数の変換) しているし, 途中にいろいろある. よくわからないのでまずは結論から.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
msc' :: Ord a => [a] -> Int
msc' = maximum . map snd . table

table [x] = [(x, 0)]
table xs = join (m-n) (table ys) (table zs)
  where m        = length xs
        n        = m `div` 2
        (ys, zs) = splitAt n xs

join _ tys [] = tys
join _ [] tzs = tzs
join n tys@((y, c):tys') tzs@((z, d):tzs')
    | y < z     = (y, c+n) : join n     tys' tzs
    | otherwise = (z, d)   : join (n-1) tys  tzs'

main = do
  let l = [1,2,3,4,6,5]
  print $ table l
  print $ msc' l

1
2
: [(1,5),(2,4),(3,3),(4,2),(5,0),(6,0)]
: 5

join の定義で txs は tys に, tys は tzs に変えて table での引数との対応を見やすくした.

本での join の定義は join 単独で見た場合に全ケースを尽くしているのだろうか. 上のように書けば問題ないだろうとは思う.

@ はシノニム: 聞き慣れないのでめちゃくちゃわかりづらいが, 単に別名をつけているだけのようだ.

1
2
3
testFunc lst@(x:xs) = [(x, 0)] ++ [(a, 1) | a <- xs]
main = do
  print $ testFunc [1,2,3]

1
: [(1,0),(2,1),(3,1)]

これは引数の lst を x:xs に分解して, この分解した値を関数本体で使っている.

: はリストへの要素追加.

1
2
3
main = do
  let list = 1 : [2, 3]
  print list

1
: [1,2,3]

あとは join に食わせる n の値が問題か. 本ではもちろん最初から追いかけて最後に上のようにまとめているので, それを逆に追いかける必要がある. join と table は相互に関係があるから両方見ないと決まらないのか.

一般的に考えるより具体例を追いかけた方が早そう.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
main = do
  let xs = [1,3,2]
  let m = length xs
  let n = m `div` 2
  let ys = fst $ splitAt n xs
  let zs = snd $ splitAt n xs

  print m
  print n
  print (m - n)
  print ys
  print zs

1
2
3
4
5
: 3
: 1
: 2
: [1]
: [3,2]

ここまで書いてみたはいいものの, 具体的に書き下していくのがあまりにも面倒で断念. 頭の中で簡単なシミュレーションをして何となく事情は察した.

このくらいならまだ結果を見てシミュレーションすれば何となく雰囲気は掴める. 単純に慣れていないだけなのだとは思っているが, 関数が相互に定義されていてしかも再帰的になっている状況, どうしても追いかけるのがつらい. デバッグもどうしたらいいのかよくわからない. 「(Haskell に) 慣れたら print デバッグなんてそもそもしなくなった」みたいなことも見かけるので, もっとどっぷり浸かってみろということなのだろう.

数学や物理のコンテンツを作っていても他人に言うことだし, しばらく地道にやっていくしかない.

あとやはり実行可能なコード片を実際に作り, ちょこちょこ小さくコードを積んでいくのがよさそう. 今回もそれをやりたかったのだが table と join のように 2 つの関数が絡んでくる場合にどうしたものか. もっとじっくり解きほぐすしかないか. 今回はソートされたリストのマージで挫折した. $\land$ を重ねたような記号で書いてあるところ.

ああいう記号だか関数だか Haskell に本当にあるの. 単に気分だけを表現しているのか何なのか, それすら全くわからない. 自分がコンテンツを作っているときにこうなっていないか, 反省する題材でもある.

追記

またコメントを頂いた. 本文にコメントを引用する.

(⩕)演算子はHaskellの標準ライブラリでは定義されていません。 この演算子の仕様が、「整列済みの2つのリストをマージして1つの整列済みのリストにする」です。 ここでは、この仕様どおりの(⩕)が与えられているとしたら、(2.2)の等式が満たされていることが判るということが重要です。つまりプログラムを実行しなくても、あるいはテストしなくても、その正しさが判るということが、肝になっています。

以下の様に定義すれば仕様を満していることは容易に判ると思います。

コードは別枠で引用.

1
2
3
4
5
6
7
infixr 4 ⩕
(⩕) ∷ Ord a ⇒ [a] → [a] → [a]
[] ⩕ ys = ys
xs ⩕ [] = xs
xxs@(x:xs) ⩕ yys@(y:ys)
  | x > y = y : (xxs ⩕ ys)
  | otherwise = x : (xs ⩕ yys)

話がずれるが「⩕」がフォント (?) 的に存在していたことに衝撃を受けた.

ちなみに infixr はこの辺参照.

投稿用メモ

  • URL:
  • title: Haskellで鞍型探索の改良アルゴリズム
  • descripttion: 数学や物理、特に物理を学ぶのに関数プログラミング、特にHaskellが非常にうまく使えるという話がある。それを見てHaskellの勉強が急務だと思い色々な形でHaskellへの知見を深めている。その一環としてアルゴリズムも勉強しようと思い『関数プログラミング 珠玉のアルゴリズムデザイン』を読んでいく記録を残している。

元書籍とここまでの内容

書籍
原著
翻訳

翻訳の公式ページはここ.

ここまでの内容

冒頭部

$f$ は各引数に対して単調増加な 2 変数関数で, それに対する適当な探索をするアルゴリズムを作ろうという話. $f$ の引数はタプルで与える前提のようだ.

チェック用に $f$ の代表例を定義しておこう.

1
2
3
saddleBackSample (x, y) = x^2 + 2 * y^2
main = do
  print $ saddleBackSample (1, 2)

一番シンプルなのは次の実装.

1
2
3
4
5
saddleBackSample (x, y) = x^2 + 2 * y^2
invert f z = [(x,y) | x <- [0..z], y <- [0..z], f (x,y) == z]

main = do
  print $ invert saddleBackSample 18

いつも通りこれはコストが高い: 全ペアを走査しないといけないから. コストをどう減らすかを順次考えていく.

案その 1

$f$ の各引数に対する単調性を使う. $f (x,y) \geq x + y$ だから「対角線」以下を走査すればいい. どちらでもいいので $y$ が動く範囲を変えたのが次のコード.

1
2
3
4
5
saddleBackSample (x, y) = x^2 + 2 * y^2
invert1 f z = [(x,y) | x <- [0..z], y <- [0..z-x], f (x,y) == z]

main = do
  print $ invert1 saddleBackSample 18

案その 2

単調性があるから最初のコードで動く範囲を制限できる. 図については本を見よう.

新たな関数 find をかませているのがポイント. これで探索域を制限する.

1
2
3
4
5
6
saddleBackSample (x, y) = x^2 + 2 * y^2
find (u, v) f z = [(x, y) | x <- [u..z], y <- [v, v-1..0], f (x,y) == z]
invert2 f z = find (0, z) f z

main = do
  print $ invert2 saddleBackSample 18

案その 3

次に find の効率を上げる.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
saddleBackSample (x, y) = x^2 + 2 * y^2
invert3 f z = find (0, z) f z
find (u, v) f z
  | u > z || v < 0 = []
  | z' < z         = find (u+1, v) f z
  | z' == z        = (u, v) : find (u+1, v-1) f z
  | z' > z         = find (u, v-1) f z
  where z' = f (u, v)

main = do
  print $ invert3 saddleBackSample 18

== の場合は「正解」なのでちゃんと値を抜き出す必要がある. ふだん解析学で評価している悪い癖で, 等号は不等号に入れたり入れなかったり = の場合を分けなかったりと雑に扱いがちだが, 今の場合そういうのは禁忌. 反省した. find の定義で x <- [u..z], y <- [v, v-1..0] としているために z' < z' や反対の場合の(u, v)` に入れる値が決まる.

案その 4

探索範囲はもっと小さくできる. 先程紹介した図で $(0,z)$, $(z, 0)$ は overestimate なのでそれを削るのだ. 適当に $m$, $n$ を計算して $(z+1) \times (z+1)$ の正方形を $(m+1) \times (n+1)$ の長方形にまで小さくする.

まず完成系はこれ.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
saddleBackSample (x, y) = x^2 + 2 * y^2
invert4 f z = find (0, m) f z n
  where m = bsearch (\y -> f (0, y)) (-1, z+1) z
        n = bsearch (\x -> f (x, 0)) (-1, z+1) z

find (u,v) f z n
  | u > n || v < 0 = []
  | z' < z = find (u+1, v) f z n
  | z' > z = find (u, v-1) f z n
  | otherwise = (u,v) : find (u+1, v-1) f z n
  where z' = f (u,v)

bsearch g (a,b) z
  | a+1 == b  = a
  | g m <= z  = bsearch g (m,b) z
  | otherwise = bsearch g (a,m) z
  where m = (a + b) `div` 2

main = do
  print $ invert4 saddleBackSample 18

$m$ と $n$ は当然 $f$ に依存する. 気分的には次のように書けばいい: $f$ が生の形で出てくるので次のコードはそのままでは実行できないことに注意しよう.

1
2
m = maximum $ filter (\y -> f (0, y) <= z) [0..z]
n = maximum $ filter (\z -> f (0, z) <= z) [0..z]

これはこれでリストを全部なめて filter して最大値を取らないといけない. つまり効率が悪い. ここを 2 分探索でコストカットする.

4. A selection problem (選択問題) 関数プログラミング 珠玉のアルゴリズムデザイン

イントロ

$X$ と $Y$ が互いに素な有限順序集合で, $X \cup Y$ のうち $k$ 番目に小さい元を取得することを考える.

$X$ と $Y$ がソートされたリストなら $O (\abs{X} + \abs{Y})$ ステップで十分. 2 つのリストのマージは線型時間で, マージされたリストの $k$ 番目に来るまでさらに $O(k)$ ステップ必要.

実際にはマージされたリストの $k+1$ 番目までがわかればいいので, 実際は $O(k)$ ステップあれば十分.

$X$ と $Y$ が配列になっている場合はさらに $O(\abs{X} + \abs{Y})$ まで落ちる. これは配列が各要素に定数時間でアクセスできるから. 今回はこの配列がキーになるようだ.

形式化と第 1 ステップ

中置演算子

(演算子名) で関数を定義する. バッククオートでくくるとふつうの関数も中置演算子として使える.

1
2
3
4
5
6
7
add m n = m + n
(.+.) a b = add a b

8 `add` 6 -- 14
add 8 6 -- 14
8 .+. 6 -- 14
(.+.) 8 6 -- 14

パーサー attoparsec

サンプル ごく単純な置換

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
{-# LANGUAGE OverloadedStrings #-}

import Data.Attoparsec.Text
import Control.Applicative

sectionTopParser =
     (string "* "       >> return "# ")
 <|> (string "** "      >> return "## ")
 <|> (string "*** "     >> return "### ")
 <|> (string "**** "    >> return "#### ")
 <|> (string "***** "   >> return "##### ")
 <|> (string "****** "  >> return "###### ")
 <|> (string "******* " >> return "####### ")

main :: IO ()
main = do
  print $ parseOnly sectionTopParser "* test        **a** $f * g$"
  print $ parseOnly sectionTopParser "** test       **a** $f * g$"
  print $ parseOnly sectionTopParser "*** test      **a** $f * g$"
  print $ parseOnly sectionTopParser "**** test     **a** $f * g$"
  print $ parseOnly sectionTopParser "***** test    **a** $f * g$"
  print $ parseOnly sectionTopParser "****** test   **a** $f * g$"
  print $ parseOnly sectionTopParser "******* test  **a** $f * g$"
  print $ parseOnly sectionTopParser "******** test **a** $f * g$"

1
2
3
4
5
: <interactive>:124:11-19: error:
:     Variable not in scope: parseOnly :: t0 -> [Char] -> ()
:
: <interactive>:124:21-36: error:
:     Variable not in scope: sectionTopParser

サンプル ごく単純な置換

  • https://www.schoolofhaskell.com/school/starting-with-haskell/libraries-and-frameworks/text-manipulation/attoparsec

その 1 型の定義, IP のパース

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
{-# LANGUAGE OverloadedStrings #-}
import Data.Attoparsec.ByteString.Char8
import Data.Word

data IP = IP Word8 Word8 Word8 Word8 deriving Show

parseIP :: Parser IP
parseIP = do
  d1 <- decimal
  char '.'
  d2 <- decimal
  char '.'
  d3 <- decimal
  char '.'
  d4 <- decimal
  return $ IP d1 d2 d3 d4

main :: IO ()
main = print $ parseOnly parseIP "131.45.68.123"

1
: Right (IP 131 45 68 123)

その 1

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
{-# LANGUAGE OverloadedStrings #-}
import Data.Time
import Data.Attoparsec.ByteString.Char8

timeParser :: Parser LocalTime
timeParser = do
  y  <- count 4 digit
  char '-'
  mm <- count 2 digit
  char '-'
  d  <- count 2 digit
  char ' '
  h  <- count 2 digit
  char ':'
  m  <- count 2 digit
  char ':'
  s  <- count 2 digit
  return $
    LocalTime { localDay = fromGregorian (read y) (read mm) (read d)
              , localTimeOfDay = TimeOfDay (read h) (read m) (read s)
                }

main :: IO ()
main = print $ parseOnly timeParser "2013-06-30 14:33:29"

1
: Right 2013-06-30 14:33:29

その 2 シンタックスの定義, 日時のパース

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
{-# LANGUAGE OverloadedStrings #-}

import Data.Attoparsec.ByteString.Char8
import Control.Applicative

data Product = Mouse | Keyboard | Monitor | Speakers deriving Show

productParser :: Parser Product
productParser =
     (string "mouse"    >> return Mouse)
 <|> (string "keyboard" >> return Keyboard)
 <|> (string "monitor"  >> return Monitor)
 <|> (string "speakers" >> return Speakers)

main :: IO ()
main = do
  print $ parseOnly productParser "mouse"
  print $ parseOnly productParser "mouze"
  print $ parseOnly productParser "monitor"
  print $ parseOnly productParser "keyboard"

1
2
3
4
: Right Mouse
: Left "string"
: Right Monitor
: Right Keyboard

その 3 パーサーを組み合わせる

 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
69
70
71
72
73
74
75
76
77
78
{-# LANGUAGE OverloadedStrings #-}
import Data.Word
import Data.Time
import Data.Attoparsec.ByteString.Char8
import Control.Applicative

{- TYPES -}
-- | Type for IP's.
data IP = IP Word8 Word8 Word8 Word8 deriving Show

data Product = Mouse | Keyboard | Monitor | Speakers deriving Show

data LogEntry =
  LogEntry { entryTime :: LocalTime
           , entryIP   :: IP
           , entryProduct   :: Product
             } deriving Show

-- | Parser of values of type 'IP'.
parseIP :: Parser IP
parseIP = do
  d1 <- decimal
  char '.'
  d2 <- decimal
  char '.'
  d3 <- decimal
  char '.'
  d4 <- decimal
  return $ IP d1 d2 d3 d4

-- | Parser of values of type 'LocalTime'.
timeParser :: Parser LocalTime
timeParser = do
  y  <- count 4 digit
  char '-'
  mm <- count 2 digit
  char '-'
  d  <- count 2 digit
  char ' '
  h  <- count 2 digit
  char ':'
  m  <- count 2 digit
  char ':'
  s  <- count 2 digit
  return $
    LocalTime { localDay = fromGregorian (read y) (read mm) (read d)
              , localTimeOfDay = TimeOfDay (read h) (read m) (read s)
                }

-- | Parser of values of type 'Product'.
productParser :: Parser Product
productParser =
     (string "mouse"    >> return Mouse)
 <|> (string "keyboard" >> return Keyboard)
 <|> (string "monitor"  >> return Monitor)
 <|> (string "speakers" >> return Speakers)

-- show
-- | Parser of log entries.
logEntryParser :: Parser LogEntry
logEntryParser = do
  -- First, we read the time.
  t <- timeParser
  -- Followed by a space.
  char ' '
  -- And then the IP of the client.
  ip <- parseIP
  -- Followed by another space.
  char ' '
  -- Finally, we read the type of product.
  p <- productParser
  -- And we return the result as a value of type 'LogEntry'.
  return $ LogEntry t ip p

{- TEST -}
main :: IO ()
main =
  print $ parseOnly logEntryParser "2013-06-29 11:16:23 124.67.34.60 keyboard"

1
: Right (LogEntry {entryTime = 2013-06-29 11:16:23, entryIP = IP 124 67 34 60, entryProduct = Keyboard})

その 4

 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
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
{-# LANGUAGE OverloadedStrings #-}
import Data.Word
import Data.Time
import Data.Attoparsec.ByteString.Char8
import Control.Applicative
import qualified Data.ByteString as B

-- Settings
-- | File where the log is stored.
logFile :: FilePath
logFile = "babel_haskell_selling.log"

-- Types
data IP = IP Word8 Word8 Word8 Word8 deriving Show
data Product = Mouse | Keyboard | Monitor | Speakers deriving Show

-- | Type for log entries.
--   Add, remove of modify fields to fit your own log file.
data LogEntry =
  LogEntry { entryTime :: LocalTime
           , entryIP   :: IP
           , entryProduct :: Product
             } deriving Show

type Log = [LogEntry]

-- Parsing
-- | Parser of values of type 'IP'.
parseIP :: Parser IP
parseIP = do
  d1 <- decimal
  char '.'
  d2 <- decimal
  char '.'
  d3 <- decimal
  char '.'
  d4 <- decimal
  return $ IP d1 d2 d3 d4

-- | Parser of values of type 'LocalTime'.
timeParser :: Parser LocalTime
timeParser = do
  y  <- count 4 digit
  char '-'
  mm <- count 2 digit
  char '-'
  d  <- count 2 digit
  char ' '
  h  <- count 2 digit
  char ':'
  m  <- count 2 digit
  char ':'
  s  <- count 2 digit
  return $
    LocalTime { localDay = fromGregorian (read y) (read mm) (read d)
              , localTimeOfDay = TimeOfDay (read h) (read m) (read s)
                }

-- | Parser of values of type 'Product'.
productParser :: Parser Product
productParser =
     (string "mouse"    >> return Mouse)
 <|> (string "keyboard" >> return Keyboard)
 <|> (string "monitor"  >> return Monitor)
 <|> (string "speakers" >> return Speakers)

-- | Parser of log entries.
logEntryParser :: Parser LogEntry
logEntryParser = do
  -- First, we read the time.
  t <- timeParser
  -- Followed by a space.
  char ' '
  -- And then the IP of the client.
  ip <- parseIP
  -- Followed by another space.
  char ' '
  -- Finally, we read the type of product.
  p <- productParser
  -- And we return the result as a value of type 'LogEntry'.
  return $ LogEntry t ip p

logParser :: Parser Log
logParser = many $ logEntryParser <* endOfLine

-- Main
main :: IO ()
main = do
  a <- B.readFile logFile
  print $ parseOnly logParser a

1
: Right [LogEntry {entryTime = 2013-06-29 11:16:23, entryIP = IP 124 67 34 60, entryProduct = Keyboard},LogEntry {entryTime = 2013-06-29 11:32:12, entryIP = IP 212 141 23 67, entryProduct = Mouse},LogEntry {entryTime = 2013-06-29 11:33:08, entryIP = IP 212 141 23 67, entryProduct = Monitor},LogEntry {entryTime = 2013-06-29 12:12:34, entryIP = IP 125 80 32 31, entryProduct = Speakers},LogEntry {entryTime = 2013-06-29 12:51:50, entryIP = IP 101 40 50 62, entryProduct = Keyboard},LogEntry {entryTime = 2013-06-29 13:10:45, entryIP = IP 103 29 60 13, entryProduct = Mouse}]

その 5 変更

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
{-# LANGUAGE OverloadedStrings #-}

import Data.Attoparsec.ByteString.Char8
import Control.Applicative

data Source = Internet | Friend | NoAnswer deriving Show

sourceParser :: Parser Source
sourceParser =
      (string "internet" >> return Internet)
  <|> (string "friend" >> return Friend)
  <|> (string "noanswer" >> return NoAnswer)

main :: IO ()
main = print $ parseOnly sourceParser "internet"

1
: Right Internet

その 6

  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
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
{-# LANGUAGE OverloadedStrings #-}
import Data.Word
import Data.Time
import Data.Attoparsec.ByteString.Char8
import Control.Applicative
-- We import ByteString qualified because the function
-- 'Data.ByteString.readFile' would clash with
-- 'Prelude.readFile'.
import qualified Data.ByteString as B

-----------------------
------ SETTINGS -------
-----------------------

-- | File where the log is stored.
logFile :: FilePath
logFile = "babel_haskell_selling.log"

-----------------------
-------- TYPES --------
-----------------------

-- | Type for IP's.
data IP = IP Word8 Word8 Word8 Word8 deriving Show

data Product = Mouse | Keyboard | Monitor | Speakers deriving Show

data Source = Internet | Friend | NoAnswer deriving Show

-- show
data LogEntry =
  LogEntry { entryTime :: LocalTime
           , entryIP   :: IP
           , entryProduct   :: Product
             -- Addition of the 'Source' field
           , source    :: Source
             } deriving Show
-- /show

type Log = [LogEntry]

-----------------------
------- PARSING -------
-----------------------

-- | Parser of values of type 'IP'.
parseIP :: Parser IP
parseIP = do
  d1 <- decimal
  char '.'
  d2 <- decimal
  char '.'
  d3 <- decimal
  char '.'
  d4 <- decimal
  return $ IP d1 d2 d3 d4

-- | Parser of values of type 'LocalTime'.
timeParser :: Parser LocalTime
timeParser = do
  y  <- count 4 digit
  char '-'
  mm <- count 2 digit
  char '-'
  d  <- count 2 digit
  char ' '
  h  <- count 2 digit
  char ':'
  m  <- count 2 digit
  char ':'
  s  <- count 2 digit
  return $
    LocalTime { localDay = fromGregorian (read y) (read mm) (read d)
              , localTimeOfDay = TimeOfDay (read h) (read m) (read s)
                }

-- | Parser of values of type 'Product'.
productParser :: Parser Product
productParser =
     (string "mouse"    >> return Mouse)
 <|> (string "keyboard" >> return Keyboard)
 <|> (string "monitor"  >> return Monitor)
 <|> (string "speakers" >> return Speakers)

sourceParser :: Parser Source
sourceParser =
      (string "internet" >> return Internet)
  <|> (string "friend" >> return Friend)
  <|> (string "noanswer" >> return NoAnswer)

-- show
-- | Parser of log entries.
logEntryParser :: Parser LogEntry
logEntryParser = do
  t <- timeParser
  char ' '
  ip <- parseIP
  char ' '
  p <- productParser
  -- Addition of the 'Source' field
  char ' '
  s <- sourceParser
  --
  return $ LogEntry t ip p s
-- /show

logParser :: Parser Log
logParser = many $ logEntryParser <* endOfLine

----------------------
-------- MAIN --------
----------------------

main :: IO ()
main = B.readFile logFile >>= print . parseOnly logParser

1
: Right [LogEntry {entryTime = 2013-06-29 16:40:15, entryIP = IP 154 41 32 99, entryProduct = Monitor, source = Internet},LogEntry {entryTime = 2013-06-29 16:51:12, entryIP = IP 103 29 60 13, entryProduct = Keyboard, source = Internet},LogEntry {entryTime = 2013-06-29 17:13:21, entryIP = IP 121 95 68 21, entryProduct = Speakers, source = Friend},LogEntry {entryTime = 2013-06-29 18:20:10, entryIP = IP 190 80 70 60, entryProduct = Mouse, source = NoAnswer},LogEntry {entryTime = 2013-06-29 18:51:23, entryIP = IP 102 42 52 64, entryProduct = Speakers, source = Friend}]

その 7

  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
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
{-# LANGUAGE OverloadedStrings #-}
import Data.Word
import Data.Time
import Data.Attoparsec.ByteString.Char8
import Control.Applicative
-- We import ByteString qualified because the function
-- 'Data.ByteString.readFile' would clash with
-- 'Prelude.readFile'.
import qualified Data.ByteString as B

-----------------------
------ SETTINGS -------
-----------------------

-- | File where the log is stored.
logFile :: FilePath
logFile = "babel_haskell_selling7.log"

-----------------------
-------- TYPES --------
-----------------------

-- | Type for IP's.
data IP = IP Word8 Word8 Word8 Word8 deriving Show

data Product = Mouse | Keyboard | Monitor | Speakers deriving Show

data Source = Internet | Friend | NoAnswer deriving Show

data LogEntry =
  LogEntry { entryTime :: LocalTime
           , entryIP   :: IP
           , entryProduct   :: Product
           , source    :: Source
             } deriving Show

type Log = [LogEntry]

-----------------------
------- PARSING -------
-----------------------

-- | Parser of values of type 'IP'.
parseIP :: Parser IP
parseIP = do
  d1 <- decimal
  char '.'
  d2 <- decimal
  char '.'
  d3 <- decimal
  char '.'
  d4 <- decimal
  return $ IP d1 d2 d3 d4

-- | Parser of values of type 'LocalTime'.
timeParser :: Parser LocalTime
timeParser = do
  y  <- count 4 digit
  char '-'
  mm <- count 2 digit
  char '-'
  d  <- count 2 digit
  char ' '
  h  <- count 2 digit
  char ':'
  m  <- count 2 digit
  char ':'
  s  <- count 2 digit
  return $
    LocalTime { localDay = fromGregorian (read y) (read mm) (read d)
              , localTimeOfDay = TimeOfDay (read h) (read m) (read s)
                }

-- | Parser of values of type 'Product'.
productParser :: Parser Product
productParser =
     (string "mouse"    >> return Mouse)
 <|> (string "keyboard" >> return Keyboard)
 <|> (string "monitor"  >> return Monitor)
 <|> (string "speakers" >> return Speakers)

sourceParser :: Parser Source
sourceParser =
      (string "internet" >> return Internet)
  <|> (string "friend" >> return Friend)
  <|> (string "noanswer" >> return NoAnswer)

-- show
-- | Parser of log entries.
logEntryParser :: Parser LogEntry
logEntryParser = do
  t <- timeParser
  char ' '
  ip <- parseIP
  char ' '
  p <- productParser
  -- Look for the field 'Source' and return
  -- a default value ('NoAnswer') when missing.
  -- The arguments of 'option' are default value
  -- followed by the parser to try.
  s <- option NoAnswer $ char ' ' >> sourceParser
  --
  return $ LogEntry t ip p s
-- /show

logParser :: Parser Log
logParser = many $ logEntryParser <* endOfLine

----------------------
-------- MAIN --------
----------------------

main :: IO ()
main = do
  a <- B.readFile logFile
  print $ parseOnly logParser a

1
: Right [LogEntry {entryTime = 2013-06-29 11:16:23, entryIP = IP 124 67 34 60, entryProduct = Keyboard, source = NoAnswer},LogEntry {entryTime = 2013-06-29 11:32:12, entryIP = IP 212 141 23 67, entryProduct = Mouse, source = NoAnswer},LogEntry {entryTime = 2013-06-29 11:33:08, entryIP = IP 212 141 23 67, entryProduct = Monitor, source = NoAnswer},LogEntry {entryTime = 2013-06-29 12:12:34, entryIP = IP 125 80 32 31, entryProduct = Speakers, source = NoAnswer},LogEntry {entryTime = 2013-06-29 12:51:50, entryIP = IP 101 40 50 62, entryProduct = Keyboard, source = NoAnswer},LogEntry {entryTime = 2013-06-29 13:10:45, entryIP = IP 103 29 60 13, entryProduct = Mouse, source = NoAnswer},LogEntry {entryTime = 2013-06-29 16:40:15, entryIP = IP 154 41 32 99, entryProduct = Monitor, source = Internet},LogEntry {entryTime = 2013-06-29 16:51:12, entryIP = IP 103 29 60 13, entryProduct = Keyboard, source = Internet},LogEntry {entryTime = 2013-06-29 17:13:21, entryIP = IP 121 95 68 21, entryProduct = Speakers, source = Friend},LogEntry {entryTime = 2013-06-29 18:20:10, entryIP = IP 190 80 70 60, entryProduct = Mouse, source = NoAnswer},LogEntry {entryTime = 2013-06-29 18:51:23, entryIP = IP 102 42 52 64, entryProduct = Speakers, source = Friend}]

その 8

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
-- | Different kind of products are numbered from 1 to 4, in the given
--   order.
data Product = Mouse | Keyboard | Monitor | Speakers deriving (Enum,Show)

productFromID :: Int -> Product
productFromID n = toEnum (n-1)

productToID :: Product -> Int
productToID p = fromEnum p + 1

main :: IO ()
main = do
  print $ productFromID 1
  print $ productFromID 3
  print $ productToID Keyboard
  print $ productToID $ productFromID 4

1
2
3
4
: Mouse
: Monitor
: 2
: 4

その 9

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
{-# LANGUAGE OverloadedStrings #-}
import Data.Attoparsec.ByteString.Char8
import Control.Applicative

data Product = Mouse | Keyboard | Monitor | Speakers deriving (Enum,Show)

productFromID :: Int -> Product
productFromID n = toEnum (n-1)

-- show
productParser2 :: Parser Product
productParser2 = productFromID . read . (:[]) <$> digit

main :: IO ()
main = print $ parseOnly productParser2 "4"

1
: Right Speakers

その 10

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
{-# LANGUAGE OverloadedStrings #-}
import Data.Time
import Data.Attoparsec.ByteString.Char8

timeParser2 :: Parser LocalTime
timeParser2 = do
  d  <- count 2 digit
  char '/'
  mm <- count 2 digit
  char '/'
  y  <- count 4 digit
  char ' '
  h  <- count 2 digit
  char ':'
  m  <- count 2 digit
  char ':'
  s  <- count 2 digit
  return $
    LocalTime { localDay = fromGregorian (read y) (read mm) (read d)
              , localTimeOfDay = TimeOfDay (read h) (read m) (read s)
                }

main :: IO ()
main = print $ parseOnly timeParser2 "29/06/2013 15:32:23"

1
: Right 2013-06-29 15:32:23

その 11

 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
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
{-# LANGUAGE OverloadedStrings #-}

import Data.Word
import Data.Time
import Data.Attoparsec.ByteString.Char8
import Control.Applicative

-----------------------
-------- TYPES --------
-----------------------

-- | Type for IP's.
data IP = IP Word8 Word8 Word8 Word8 deriving Show

data Product = Mouse | Keyboard | Monitor | Speakers deriving (Show,Enum)

productFromID :: Int -> Product
productFromID n = toEnum (n-1)

data Source = Internet | Friend | NoAnswer deriving Show

data LogEntry =
  LogEntry { entryTime :: LocalTime
           , entryIP   :: IP
           , entryProduct   :: Product
           , source    :: Source
             } deriving Show

type Log = [LogEntry]

-----------------------
------- PARSING -------
-----------------------

-- | Parser of values of type 'IP'.
parseIP :: Parser IP
parseIP = do
  d1 <- decimal
  char '.'
  d2 <- decimal
  char '.'
  d3 <- decimal
  char '.'
  d4 <- decimal
  return $ IP d1 d2 d3 d4

timeParser2 :: Parser LocalTime
timeParser2 = do
  d  <- count 2 digit
  char '/'
  mm <- count 2 digit
  char '/'
  y  <- count 4 digit
  char ' '
  h  <- count 2 digit
  char ':'
  m  <- count 2 digit
  char ':'
  s  <- count 2 digit
  return $
    LocalTime { localDay = fromGregorian (read y) (read mm) (read d)
              , localTimeOfDay = TimeOfDay (read h) (read m) (read s)
                }

productParser2 :: Parser Product
productParser2 = productFromID . read . (:[]) <$> digit

sourceParser :: Parser Source
sourceParser =
      (string "internet" >> return Internet)
  <|> (string "friend" >> return Friend)
  <|> (string "noanswer" >> return NoAnswer)

-- show
logEntryParser2 :: Parser LogEntry
logEntryParser2 = do
  ip <- parseIP
  char ' '
  t <- timeParser2
  char ' '
  p <- productParser2
  char ' '
  s <- sourceParser
  return $ LogEntry t ip p s

main :: IO ()
main = print $ parseOnly logEntryParser2 "54.41.32.99 29/06/2013 15:32:23 4 internet"

1
: Right (LogEntry {entryTime = 2013-06-29 15:32:23, entryIP = IP 54 41 32 99, entryProduct = Speakers, source = Internet})

ごく単純な置換

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
{-# LANGUAGE OverloadedStrings #-}

import Data.Attoparsec.Text
import Control.Applicative

data Product = Mouse | Keyboard | Monitor | Speakers deriving Show

productParser :: Parser Product
productParser =
     (string "mouse"    >> return Mouse)
 <|> (string "keyboard" >> return Keyboard)
 <|> (string "monitor"  >> return Monitor)
 <|> (string "speakers" >> return Speakers)

main :: IO ()
main = do
  print $ parseOnly productParser "mouse"
  print $ parseOnly productParser "mouze"
  print $ parseOnly productParser "monitor"
  print $ parseOnly productParser "keyboard"

1
2
3
4
: Right Mouse
: Left "string"
: Right Monitor
: Right Keyboard

サンプル

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
{-# LANGUAGE OverloadedStrings #-}
-- stack install attoparsec

import qualified Data.Text    as T -- 重複を防ぐ
import qualified Data.Text.IO as TIO -- 重複を防ぐ
import Data.Attoparsec.Text hiding (take)
import Control.Applicative

quotedText :: Parser T.Text
quotedText = char '{' *> takeTill (== '}') <* char '}'

labeledName :: Parser T.Text
labeledName = manyTill anyChar "\\label" *> quotedText

texLabelParser =
  manyTill anyChar "\\label"
  *> char '{'
  *> takeTill (== '}')
  <* char '}'

main :: IO ()
main = do
  print $ parse texLabelParser "name:\\label{Yamada Ichiro}" `feed` ""

1
: Done "" "Yamada Ichiro"

サンプル

 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
{-# LANGUAGE OverloadedStrings #-}
-- stack install attoparsec

import qualified Data.Text    as T -- 重複を防ぐ
import qualified Data.Text.IO as TIO -- 重複を防ぐ
import Data.Attoparsec.Text hiding (take)
import Control.Applicative

data SimpleDate = SimpleDate
    { year :: Int
    , month :: Int
    , day :: Int
    } deriving (Eq, Ord, Show, Read)

simpleDate :: Parser SimpleDate
simpleDate =
    SimpleDate <$>
        (read <$> (count 4 digit)) <* char '/' <*>
        (read <$> (count 2 digit)) <* char '/' <*>
        (read <$> (count 2 digit))

labeledBirthday :: Parser SimpleDate
labeledBirthday = "birthday:" *> simpleDate

main :: IO ()
main = do
  print $ parse labeledBirthday "birthday:2016/11/01" `feed` ""

1
: Done "" (SimpleDate {year = 2016, month = 11, day = 1})

サンプル

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
{-# LANGUAGE OverloadedStrings #-}
-- stack install attoparsec

import qualified Data.Text    as T -- 重複を防ぐ
import qualified Data.Text.IO as TIO -- 重複を防ぐ
import Data.Attoparsec.Text hiding (take)
import Control.Applicative

data Term = Add Expr deriving Show
data Expr = ExTerm Double Term | ExEnd Double deriving Show

termParser :: Parser Term
termParser = addParser
  where
    addParser :: Parser Term
    addParser = Add <$ char '+' <*> exprParser

exprParser :: Parser Expr
exprParser = ExTerm <$> double <*> termParser <|> ExEnd <$> double

main :: IO ()
main = do
  print $ parse (exprParser <* endOfInput) "1+2+3" `feed` ""

1
: Done "" (ExTerm 1.0 (Add (ExTerm 2.0 (Add (ExEnd 3.0)))))

サンプル

 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
{-# LANGUAGE OverloadedStrings #-}
-- stack install attoparsec

import qualified Data.Text as T
import Data.Attoparsec.Text hiding (take)
import Control.Applicative

data YMD = YMD Int Int Int deriving Show
data HMS = HMS Int Int Int deriving Show

ymdParser :: Parser YMD
ymdParser = YMD
  <$> (countRead 4 digit <?> "Year") <* (char '/' <?> "Delim Y/M")
  <*> (countRead 2 digit <?> "Month") <*
  (char '/' <?> "Delim M/D")
  <*> (countRead 2 digit <?> "Day")

hmsParser :: Parser HMS
hmsParser = HMS
  <$> (countRead 2 digit <?> "Hour") <* (char ':' <?> "Delim H:M")
  <*> (countRead 2 digit <?> "Minute") <* (char ':' <?> "Delim M:S")
  <*> (countRead 2 digit <?> "Second")

dateTimeParser :: Parser (YMD, HMS)
dateTimeParser = (,)
  <$> (ymdParser <?> "YMD")
  <*  (char ' ' <?> "space")
  <*> (hmsParser <?> "HMS")

countRead :: Read a => Int -> Parser Char -> Parser a
countRead i = fmap read . count i

main :: IO ()
main = do
  print $ parse (dateTimeParser <* endOfInput) "2018/08/21hoge 12:00:00" `feed` ""
  print $ parse (dateTimeParser <* endOfInput) "2018/08/21 12:00.00" `feed` ""
  print $ parse (dateTimeParser <* endOfInput) "2018/08/21 12:00:00" `feed` ""

1
2
3
: Fail "hoge 12:00:00" ["space","' '"] "Failed reading: satisfy"
: Fail ".00" ["HMS","Delim M:S","':'"] "Failed reading: satisfy"
: Done "" (YMD 2018 8 21,HMS 12 0 0)

プラグマ設定をオフにする

1
{-# OPTIONS_GHC -Wno-unused-top-binds #-}