Haskellでいってみよう

日曜プログラマにも満たないレベルでもHaskellで何かソフトウェアを作りたい!

同一画像検索(2):Finder moduleのための確認

前回はダミーのFinderモジュールで、とりあえず外側を作ったので、 今回からFinderの作成をすすめたい。ただ、その前に幾つか基本的な ところを確認しておきたい。

同一の画像を見つけるやり方は前回も書いた通り解像度4x4に変換して その情報が同じものをグルーピングすることにした。 まずはこの部分を実現するために、次の2つを確認しておく。

  • 画像ファイルを解像度4x4に変換して48 bytesのデータを取り出す。
  • キーが同じファイルを集めてリストにする。

画像ファイルの変換

まず最初の方について検討する。画像ファイルの変換処理は書いてられない のでImageMagickを使って変換してみよう。最終的に、各画素の色情報 (256段階x3色)が欲しいので、PPM(バイナリ)形式にして後ろから48 bytesを 切り出す。前回も書いたが48 bytesなのは 4x4ドットx色3 bytesだから。 今後、このように画像ファイルを小さく変換して得られるデータを fingerprintと 表記する。今回は48 bytesのfingerprintということだ。なお、ImageMagickの convertコマンドの詳細はここでは割愛する。

$ convert -define jpeg:size=4x4 -filter Cubic -resize 4x4! test.jpg test.ppm

test.ppmの中身は次の通り。

$ tail -c 48 test.ppm > test.out
argent-2:work eiji$ od -x test.out
0000000      aecd    c17e    7fa9    7e95    8567    6672    ccf2    df9b
0000020      8dba    97b5    a57d    7d8e    cfe4    dbba    a5bf    bed7
0000040      e1a9    c6d3    c0d5    d7b1    a7bc    c2db    e6ad    cdd8
0000060

これを踏まえ、Haskellでconvertコマンドを実行する処理を考える。 外部コマンドを実行するにはSystem.Processモジュール を使うらしいので、それらしいものを探す。実行したいコマンドは、パイプを使って 必要な部分だけ切り取り、それをプログラムで取り出したいので runInteractiveCommandが相当しそうだ。 こことか ここ とかを参考に書いてみた。

Main-t0.hs
module Main where

import System.IO
import System.Process

reso = 4

getFingerPrint :: String -> IO String
getFingerPrint f = do
  (sin, sout, serr, ph) <- runInteractiveCommand command
  waitForProcess ph
  hGetLine sout
  where
    geo = (show reso) ++ "x" ++ (show reso)
    size = reso * reso * 3
    command = "convert -define jpeg:size=" ++ geo
           ++ " -filter Cubic -resize " ++ geo ++ "! "
           ++ f ++ " PPM:- | tail -c " ++ (show size)

main :: IO ()
main = do
  putStr =<< getFingerPrint "~/work/test1.jpg"

コンパイルして実行してみる。

$ ghc -o t0 Main-t1.hs
$ ./t0 > /tmp/out.dat
rcom: fd:5: hGetLine: invalid argument (invalid byte sequence)

出力結果を取り出すところでしくじっているらしい。ググってもよくわからな かったが、色情報は単なるバイト列なので「文字」にならないバイトも多い。 ということで、ByteStringに変えてみた。

Main-t0.hs (2)
module Main where

import Data.ByteString.Char8 as BS
import System.IO
import System.Process

reso = 4

getFingerPrint :: String -> IO ByteString
getFingerPrint f = do
  (sin, sout, serr, ph) <- runInteractiveCommand command
  waitForProcess ph
  BS.hGetLine sout
  where
    geo = (show reso) ++ "x" ++ (show reso)
    size = reso * reso * 3
    command = "convert -define jpeg:size=" ++ geo
           ++ " -filter Cubic -resize " ++ geo ++ "! "
           ++ f ++ " PPM:- | tail -c " ++ (show size)

main :: IO ()
main = do
  s <- getFingerPrint "~/work/test1.jpg"
  BS.putStr s

こんどはうまくいった。

$ ./t0 > /tmp/out.dat
$ od -x /tmp/out.dat
0000000      aecd    c17e    7fa9    7e95    8567    6672    ccf2    df9b
0000020      8dba    97b5    a57d    7d8e    cfe4    dbba    a5bf    bed7
0000040      e1a9    c6d3    c0d5    d7b1    a7bc    c2db    e6ad    cdd8
0000060

最初にハンドでコマンドを流したときと同じ出力が得られている。

同一キーのファイルを集める

画像から同じfingerprintを得られたとして、それらを同一とみなす方法が必要である。 簡単に実現しようとすると、連想配列を用いてキーが同じものをまとめてしまえばよい。 Haskellでは連想配列を扱うにはData.Mapを使うらしい。

ここでは入力はキー(文字列)とファイル名の組のListとし、結果は各キーに対しファイル名の Listが対応するMapとしたい。入力がListなので、変換する関数のシグネチャ

  [(String, String)] -> Map String [String]

になるだろう。ただ、再帰で処理させることを考えると、処理済みのMapも引数に与えて

  [(String, String)] -> Map String [String] -> Map String [String]

となるだろう。あとはこれに合うように再帰関数を書けば良い。とはいえHaskell再帰処理はよくわかっていないので、少々こんがらがったが最終的に下記のような関数 tomapに落ち着いた。

tomap :: [(String, String)] -> Map String [String] -> Map String [String]
tomap  (x:xs) m = tomap xs (Map.insert k l m)
  where
    k = fst x
    l = tolist x (Map.lookup k m)
    
tolist :: (String, String) -> Maybe [String] -> [String]                        
tolist x Nothing = [snd x]                                                      
tolist x (Just l) = (snd x:l)                                                   

ちなみに、tolistはすでに同じキーで登録されているもの(List)があればそれを取り出して 新しい要素をそのListに追加し、なければ新しく要素一つのListを作って返す関数。 なお、tomapの定義ではMapの初期値が現れてきていない。これについてはtomapを最初に 呼び出すときに引数としてMap.emptyを与えている。これが綺麗なやり方かどうかは不明。 てきとうに動くプログラムに仕立てて処理した結果は次の通り。

(input)  [("a", "apache"), ("e", "emacs"), ("a", "ant"), ("c", "ceph")] 
(output) [["ant","apache"],["ceph"],["emacs"]]

キーが"a"のものについては結果のListに複数の要素が入っている。

次回は、上記の確認を踏まえて同一画像を判定する簡易な関数を作ってみる。

同一画像検索(1):仕様と外枠作り

前回からかなり時間が空いてしまったが…気を取り直して進めよう。

作りたいのは複数の画像ファイルの中から同じ画像を抽出するプログラムだった。 基本的な仕様は次の通りとする。

  • 引数で調査したいディレクトリを指定する
  • ディレクトリ内にあるJPEGファイルを取り出し、それぞれを比較して 「同一の」画像ファイルかどうか確認する
  • 「同一の」画像ファイルが見つかったらそのファイル名を出力する

ここで「同一の」としたが、何をもって同一とするかという話がある。 難しい画像比較のアルゴリズムとか、「同じような画像」を見つけ出す とか言い出すと大変なので、「同一の」というのは、解像度は異なって いるかもしれないが同じ対象物が描画されているもの、とする。 本当のところは、多少サイドがクリッピングされていたり、コントラスト や色調をいじっていたりするものは「同一」とみなしたいが、大変 そうなので割愛する。

この前提で、どうやって「同一の」画像かどうか判断するかについては 外部プログラム(ImageMagick)の力を借りることにする。

  • まず、対象の画像を4x4の解像度の画像に変換し、各点の色の値 (256階調x3色)を取り出す。(48 bytesのデータになる)
  • この48 bytesが全く同じ画像をグルーピングして、同一画像の候補とする。
  • さらに詳細を見るために16x16の解像度の画像に変換し、各点の 色の値を取り出す。
  • 元画像の解像度が異なると、16x16に落としても各点の値が微妙に 異なる可能性があるので、各点の比較時に差を取り一定の範囲内で あれば同じとみなす。

上記を踏まえ、プログラムの骨格は以下のようになるだろう。

  1. 引数に指定されたディレクトリからJPEG画像ファイルのListを取得する

    ["image1.jpg", "image2.jpg", ..., "imagen.jpg"]

  2. 画像を相互に比較し、同一画像とみなされるものを一組のListとし、 結果はそのListのListとする

    [["image3.jpg", "image6.jpg"], ["image5.jpg", "image10.jpg", "image14.jpg"], ...]

  3. 同一画像の組ごとに、結果を画面に出力する

    probably same: image3.jpg, image6.jpg
    probably same: image5.jpg, image10.jpg, image14.jpg
    :

ということで、このプログラムの主体は2の部分なのだが、外堀から埋める つもりで1と3の部分を作ってみる。2の部分は適当なListを返すダミー関数で 誤魔化すことにする。

前回開発環境について記載したが、それに基づき src/ ディレクトリ以下に ファイルを作成していく。まずはメイン。

Main.hs
module Main where

import System.Directory
import System.Environment
import Data.List.Split
import Data.Char
import Finder

picext = "JPG"
delimiter = "/"

main :: IO ()
main = do
  ds <- getArgs
  fs <- mapM getFileLists ds
  putGroups $ findSame $ concat fs

getFileLists :: FilePath -> IO [String]
getFileLists d = do
  fs <- getDirectoryContents d
  return $ map (\ x -> d ++ delimiter ++ x) (filter isJpeg fs)

isJpeg :: String -> Bool
isJpeg f = if ext == picext then True else False
  where
  ext = map toUpper (last $ splitOn "." f)

putGroups :: [[String]] -> IO ()
putGroups [] = putStr ""
putGroups (p:ps) = do
  putStrLn ("probably same: " ++ showGroup p)
  putGroups ps

showGroup :: [String] -> String
showGroup [] = ""
showGroup (f:[]) = f
showGroup (f:fs) = f ++ ", " ++ showGroup fs

mainにおいて、骨格のうち1は最初の二行と3行目の後ろのconcatで実現 している。この例では、引数に複数のディレクトリを指定できるように してあるため少々ややこしいが、結局は画像ファイル名のListを作っている だけである。最後の行の findSame が骨格の2にあたるが、これは後述の Finderモジュールで定義する。最後に putGroups が骨格の3で、結果を 整形して出力する処理である。

今回、findSame は本来の処理ではなくとりあえずファイル名のListの Listを返すだけのダミー関数とした。

Finder.hs
module Finder where

findSame :: [String] -> [[String]]
findSame fs = map toPair fs

toPair :: String -> [String]
toPair f = [f, f]

コンパイルはmainの入っているファイルのみ指定すれば、あとは勝手に呼び 出されているモジュールのソースファイルも合わせてコンパイルしてリンク してくれる。

$ ghc -o picf Main.hs
[1 of 2] Compiling Finder           ( Finder.hs, Finder.o )
[2 of 2] Compiling Main             ( Main.hs, Main.o )
Linking picf ...

実行してみる。

$ ./picf work
probably same: work/image1.JPG, work/image1.JPG
probably same: work/image2.jpg, work/image2.jpg
probably same: work/image3.jpg, work/image3.jpg
probably same: work/image4.jpg, work/image4.jpg

一応「外堀」はできた。あとは肝心のfindSameを定義するだけ。 これが大変そうだが、、、それは次回にしよう。

開発環境の整備とプロジェクトディレクトリ

ちゃんとしたプロダクトを作るにあたり、まずは開発環境を整えないといけない。 ソース管理は当然なので、今ならgithubが妥当だろう。早速ユーザ登録して、 新規リポジトリを開始する。この辺の詳しいところは、以下の書籍を参考にした。

GitHub実践入門 ~Pull Requestによる開発の変革 (WEB+DB PRESS plus)

GitHub実践入門 ~Pull Requestによる開発の変革 (WEB+DB PRESS plus)

コラボレーションするようなモノではないので少々オーバースペックな感じはするが、 自宅でバージョン管理システムを運用するのは大変面倒くさいのでやはりクラウド サービスが楽だ。

新しく、"picfinder"というリポジトリを作ったので、これをローカルにcloneしてくる。

$ git clone https://github.com/eijian/picfinder.git

簡単そうなところで、指定したディレクトリ内に存在するJPEGファイルの中で、同じ 画像であるものを探し出してレポートしてくれるプログラムを作ってみようと思う。 さて、Haskellでビルドやテストを繰り返し行うには、Cabalというのを使うと良さそう。 この辺は以下の書籍を参考にした。

まずは初期化をする必要があるらしい。

$ cabal init
Package name? [default: picfinder] picfinder
Package version? [default: 0.1.0.0] 0.1.0.0
Please choose a license:
  :
   8) BSD3
  :
Your choice? [default: (none)] 8

とりあえずプロダクト名、初期バージョン、そしてライセンスを選ぶ。 Cabal(かHaskell界)のしきたりなのか、バージョンは4つの数字で表す ようにする、と先の[関数プログラミング…]に書いてある。まずは、 0.1.0.0で始めておく。

名前とかを入力した後、今回のプログラムは画像関係なのでカテゴリは Graphicsを、また実行プログラムとしておく。

Project category:
  :
  10) Graphics
  :
Your choice? [default: (none)] 10
What does the package build:
   1) Library
   2) Executable
Your choice? 2

あとはmainが入るソースファイル名やHaskellのバージョンなどを聞かれたが よくわからないのでデフォルトのままで。とりあえず最後まで進んだので良しとする。

Generating LICENSE...
Warning: LICENSE already exists, backing up old version in LICENSE.save0
Generating Setup.hs...
Generating picfinder.cabal...

You may want to edit the .cabal file and add a Description field.

あと、ソースツリーをどうするか考えないといけないがルートにバラバラいろんな ファイルやディレクトリが散らかっているのは嫌いなので、ソースとテストと文書用に 3つだけ作った。トップディレクトリは次のようになった。

.git                      <= gitが勝手に作った?
.gitignore                <= github登録時に指定
LICENSE                   <= githubで登録時に選択すると作られるがCabalが作った方を採用
README.md                 <= githubで登録した時に作られた
Setup.hs                  <= Cabalが生成
doc/
picfinder.cabal           <= Cabalが生成
src/
test/

次回からは少しずつプログラムを作ってみる。

簡易cat (2)

ファイル内容を表示するだけでは寂しいので、コマンドラインに オプションを追加してみる。ややこしいのは大変なので、先頭に 行番号を表示する -n モドキだけ。

-n オプションがある場合は各行の表示をする時に番号を付加する。 行番号はいわゆる「無限リスト」を各行とzipで組にしてみた。

Cat4.hs
-- 
-- Cat4
-- 

module Main (
  main
) where

import System.Environment

main :: IO ()
main = do
  xs <- getArgs
  putFiles $ checkArgs xs

checkArgs :: [String] -> (Bool, [String])
checkArgs [] = (False, [])
checkArgs (x:xs)
  | x == "-n" = (True, xs)
  | otherwise = (False, (x:xs))

putFiles :: (Bool, [String]) -> IO ()
putFiles (_, []) = putStr ""
putFiles (b, (x:xs)) = do
  cs <- readFile x
  putStr (decorate b cs)
  putFiles (b, xs)

decorate :: Bool -> String -> String
decorate False cs = cs
decorate True cs = unlines $ map tr (zip [1..] $ lines cs)

tr :: (Int, String) -> String
tr (n, l) = (show n) ++ "\t" ++ l

単に最初の引数が"-n"かどうかをチェックしているだけなのに 結構邪魔くさいことになっている。 doブロック内でできることできないことについて、下記ではまった。

putFiles (b, (x:xs)) = do
  cs <- readFile x
  putStr (decorate b cs)

putStrのところ、今回は短いのでいいが、一旦変数にバインドしようとして 単に代入文を書いたらコンパイルエラーになった。

  cs' = decorate b cs
  putStr cs'

しょうがないのでputStr一行にまとめてしまったが、あとで試したらletを 使えば大丈夫そう。

  let cs' = decorate b cs
  putStr cs'

一方で where句ではエラーになった。csがスコープにないと怒られたので where句の中に"cs <- readFile x"を書いてもエラーになってしまう。

  putStr cs'
  where
    cs' = decorate b cs

letとwhereの違いを確認しておこう。

次回は使えそうなプログラムを作ってみる。

簡易cat - コマンドライン引数

はじめに、このブログはHaskellの入門記事でも何でもないので、その辺りはご期待には添えないのであらかじめお断りしておくことにする。単に、私がHaskellで何かしらソフトウェアを作るということのモチベーションを維持するためであり、またその過程を記録するものである。記述が大雑把なのもご容赦願いたい。ただせっかく稚拙で恥ずかしいソースを晒すので、願わくば「高位のHaskell使い」の方からHaskellらしからぬところ、より的確な関数/ライブラリなど、改善につながるご助言をいただければ幸いである。

さて、実用的なアプリケーションを作るにはコマンドライン引数を扱えないと話にならない(と考えた)ので、その辺を確認しておく。サンプルとして超簡易的なcatコマンドを作成する。

STEP 1

引数に指定したファイルを単に表示するだけのcatを作ってみる。まずは、最初の引数のファイルだけを表示する仕様とする。二番目以降の引数は無視。ちなみに、これではcatとは名ばかりである…。

Cat1.hs
module Main (
  main
) where

import System.Environment

main :: IO ()
main = do
  (x:xs) <- getArgs
  putFile x

putFile :: String -> IO ()
putFile f = do
  cs <- readFile f
  putStr cs

実行してみる。

$ ghc -o cat1 Cat1.hs
$ ./cat1 Cat1.hs
module Main (
  :
  putStr cs

一応動いた。getArgsはリストを返すので最初の要素だけを取り出してみた。ファイルの読み出しと標準出力への書き出しはとても簡単。readFileで読んでputStrするだけ。ちなみにこの辺のテキスト処理的な簡易コマンドの書き方については、この本を参考にした。関数プログラミングの解説書として云々という評価はあるが、私的にはHaskellで実用アプリを作るという事ではなかなかいいアプローチで説明もわかりやすいと思う。ただしAmazonではもう新品は売ってないのかな?

ふつうのHaskellプログラミング ふつうのプログラマのための関数型言語入門

ふつうのHaskellプログラミング ふつうのプログラマのための関数型言語入門

STEP 2

次に複数のファイル名を与えてそれらを順に表示させる事にする。これで一応catを名乗ることができる? 複数のファイル名はリストで渡されるので、リストの各要素に対し同じ処理を実行するには map というのがいいらしい。なので先ほどのプログラムにちょっとmapを付けてみる。

Cat2.hs
module Main (
  main
) where

import System.Environment

main :: IO ()
main = do
  xs <- getArgs
  map putFile xs

putFile :: String -> IO ()
putFile f = do
  cs <- readFile f
  putStr cs

コンパイルすると…

$ ghc -o cat2 Cat2a
  :
Cat2a.hs:14:3:
    Couldn't match type ‘[]’ with ‘IO’
    Expected type: IO ()
      Actual type: [()]
  :

怒られた。確かに map の型は「(a -> b) -> [a] -> [b]」なのでmainの型と合わない。さすがに"純粋な" map をここで使う事に無理があるのか?あきらめて再帰関数に変えてみた。

Cat3.hs
module Main (
  main
) where

import System.Environment

main :: IO ()
main = do
  xs <- getArgs
  putFiles xs

putFiles :: [String] -> IO ()
putFiles [] = do
  putStr ""
putFiles (x:xs) = do
  putFile x
  putFiles xs

putFile :: String -> IO ()
putFile f = do
  cs <- readFile f
  putStr cs

うまく行った!(実行結果は割愛)

ちなみに最初は再帰の底(putFiles [] = do のところ)を書いていなかったので実行時に怒られた。この辺、慣れが必要か。でも 'putStr ""' という処理が適切かどうかはわからない。

続きは次回。

まずは "Hello, World!" から

実用的なプログラムを作ることが目的なので、実行ファイルを
作成できなくては始まらない。Haskellの本だと対話環境を使った
リスト操作や再起などの説明が多いが、そうではなくてまずは
コンパイルしてみる。お決まりの"Hello, World!"でも書いてみる。

(Greeting.hs)

main = putStrLn "Hello, World!"

Rubyほど短くないが、かなり簡潔に書ける方だと思う。Javaだと
いろいろ修飾が大変、というのもHaskellに流れてきた理由の一つ。

コンパイルする。

$ ghc Greeting

これで、"Greeting"という実行ファイルができる。簡単だ。
出力ファイルの名前指定(-o オプション)や最適化(-O, -O2)も
OK。(前は"--make"をつけていたが今は要らないらしい)

http://d.hatena.ne.jp/kazu-yamamoto/20140206/1391666962

$ ghc -o gre -O2 Greeting

大きなプログラムになるとモジュール分割とか出てくるので、
その辺も書いておく。mainの型も。

(Greeting2.hs)

module Main (
  main
) where

main :: IO ()
main = putStrLn "Hello, World!"

最初、モジュール名は何でもいいと思ってJavaみたいにファイル名と
同じにしてたら失敗した。ghcは「Mainモジュールの"main"」がないと
実行ファイルを作ってくれないみたい。最初の例ではモジュール名を
書かなかったので勝手にMainとして処置してくれたらしい。
Mainの後ろの括弧内に外部へ公開したい名前を羅列するそうだ
カプセル化みたいに?)。

最後に、画面から名前を入力させてあいさつさせてみる。

(Greeting3.hs)

module Main (
  main
) where

main :: IO ()
main = do
  putStrLn "What's your name? "
  name <- getLine
  putStrLn ("Hello, " ++ name ++ ". Nice to meet you!")

実行するとこんな感じ。

$ ghc -o gre Greeting3
  :
$ ./gre
What's your name?
Taro                              <= 入力
Hello, Taro. Nice to meet you!

できた。

Haskellコンパイラを入れる

どうやらHaskellコンパイラとしてはGHCがメジャーということらしい。もろもろライブラリも使いたいのでHaskell Platformを入れるのがよいそうで。自宅はMacで、パッケージ管理はHomebrewを使っている。

$ brew install haskell-platform
Warning: haskell-platform-2013.2.0.0 already installed

ああ、前に分けもわからず入れたんだった。ということでHomebrewの更新もやってしまおう。

$ brew update
Cloning into '/usr/local/Library/Taps/homebrew-dupes'...
   :
==> Deleted Formulae
   :
catdoc		    haskell-platform	mpio		    texmacs
   :

あれ?もう一度インストールを試すと

$ brew install haskell-platform
Error: No available formula for haskell-platform
We no longer package haskell-platform. Consider installing ghc
and cabal-install instead:
  brew install ghc cabal-install
    :

どうも"haskell-platform"という名前ではパッケージをインストールできなくなってしまっている。。。
指示通り、ghcとcabal-installを入れてみる。

$ brew install ghc cabal-install
Error: ghc-7.6.3 already installed
To install this version, first `brew unlink ghc'
==> Installing dependencies for cabal-install: gmp, ghc
==> Installing cabal-install dependency: gmp
==> Downloading https://downloads.sf.net/project/machomebrew/Bottles/gmp-6.0.0a.
######################################################################## 100.0%
==> Pouring gmp-6.0.0a.mavericks.bottle.tar.gz
🍺  /usr/local/Cellar/gmp/6.0.0a: 15 files, 3.2M
==> Installing cabal-install dependency: ghc
==> Downloading https://downloads.sf.net/project/machomebrew/Bottles/ghc-7.8.3.m
######################################################################## 100.0%
==> Pouring ghc-7.8.3.mavericks.bottle.1.tar.gz
🍺  /usr/local/Cellar/ghc/7.8.3: 5742 files, 724M
==> Installing cabal-install
==> Downloading https://downloads.sf.net/project/machomebrew/Bottles/cabal-insta
######################################################################## 100.0%
==> Pouring cabal-install-1.20.0.3_1.mavericks.bottle.1.tar.gz
==> Caveats
Bash completion has been installed to:
  /usr/local/etc/bash_completion.d
Error: The `brew link` step did not complete successfully
The formula built, but is not symlinked into /usr/local
Could not symlink bin/cabal
Target /usr/local/bin/cabal
is a symlink belonging to haskell-platform. You can unlink it:
  brew unlink haskell-platform

To force the link and overwrite all conflicting files:
  brew link --overwrite cabal-install

To list all files that would be deleted:
  brew link --overwrite --dry-run cabal-install

Possible conflicting files are:
/usr/local/bin/cabal -> /usr/local/Cellar/haskell-platform/2013.2.0.0/bin/cabal
==> Summary
🍺  /usr/local/Cellar/cabal-install/1.20.0.3_1: 5 files, 18M
$ ghc -v
Glasgow Haskell Compiler, Version 7.8.3, stage 2 booted by GHC version 7.8.3
    :

何とか入ったらしい。でも、本当にこの手順で良かったのか?