レイトレーシング(1): バージョン1の定義、ベクトル演算
Haskellは数学と関連があるというような話をちょくちょく見ることがある。 圏論がどうとか数学的な概念が…といったところは筆者にはわからないが、 ソース（見た目）はかなり数学っぽいと思う。実際これが一番Haskellに はまっている理由かもしれない。この簡潔さは素晴らしい。 数学とくればレイトレーシング？ということで作ってみる。
手元にこんな本がある。
- 作者: Henrik Wann Jensen,苗村健
- 出版社/メーカー: オーム社
- 発売日: 2002/07
- メディア: 単行本
- 購入: 4人 クリック: 58回
- この商品を含むブログ (9件) を見る
古典的なレイトレーシングソフトは作ったことがあるので、今回は フォトンマッピングに手を出してみよう。そういうことだから、 完成できる保証はない。また、途中でときどき別のネタに脱線すると思う。 なお、ここでは理論の詳細には触れない。 レイトレーシングのアルゴリズムや実装については上記の本や ここを参照するとよいかもしれない。
"バージョン1"の定義
フォトンマッピング法に詳しいわけではないので、大ウソの連発かもしれない ことはあらかじめ言い訳しておく。
さてこの手法は第一フェーズでフォトンマップを作成し、第二フェーズで レイトレーシングする、二段階アルゴリズムである。ただし第二フェーズでは 普通のレイトレだと光源が見えるかどうか調べるが、この手法は光が到達する量を フォトンマップから「推定」する。これがみそ。
最初から超リアルな画像を生成できるものは無理なので、簡単なものを 作って少しずつ肉付けしていけばいいだろう。 バージョン1ではだいぶ単純化した仕様にして、まずは動くものを作る。 以下が最初の仕様だ。
- 光源は点光源だけ
- 物体表面は拡散反射のみ（鏡面反射・屈折は無視）
- フォトンの追跡は反射を無視（=相互拡散反射による効果はお預け）
- 物体は球と無限平面のみ
- 材質（というか色）は単色
この仕様で画像が生成できるのか今の時点ではよくわからないが、とりあえずは 進めてみよう。
ベクトル演算
レイトレーシングの処理は、ほとんどが3次元ベクトルか光量(輝度）の
演算で占められている。まずはベクトル演算のモジュールを作ろう。
代数に関するモジュールなので名前をAlgebraにしよう。
開発用ディレクトリの基本的な構造は以前に書いた通り
(GitHub)。
今回はsrcディレクトリの下にRayというディレクトリを作って
その中にソースファイルを作ることにする。トップディレクトリから見ると
src/Ray/Algebra.hsだ。
そうそう、三次元座標系は筆者の好みで「左手系」かつy軸が上(x軸は右、 z軸は奥)を正方向とする。
主要なベクトル演算は型クラスで定義しておくと2次元ベクトルや行列など 似たような型を定義するのにも使えそうである。どちらかというとベクトルは 行列の特殊なものと考えれば、型クラスは
BasicMatrix --> Matrix, Vector
という親子関係にしたほうがよさそう。BasicMatrixに行列やベクトルに
共通な基本的な演算(関数)を定義し、特有の演算はそれぞれMatrixと
Vectorクラスに定義するようにしよう。まずBasicMatrixで基本的な
演算を定義する。加減算、スカラー倍、スカラー除算、ノルムにしよう。
他に必要なものがあれば出てきてから追加する。なお、こっそりShowクラスと
Eqクラスの子にしておく。
(実はこの歳になって初めてノルムにも色々な種類があると知った。
ただここでは一般的(?)な、ベクトルで長さを意味するノルムとしよう。）
class (Show a, Eq a) => BasicMatrix a where madd :: a -> a -> a -- 加算 msub :: a -> a -> a -- 減算 mscale :: Double -> a -> a -- スカラー倍 mdiv :: a -> Double -> Maybe a -- スカラー除算 mdiv a s | s == 0 = Nothing | otherwise = Just ((1 / s) `mscale` a) norm :: a -> Double -- ノルム nearlyEqual :: a -> a -> Bool -- ≒ class (BasicMatrix a) => Vector a where dot :: a -> a -> Double -- 内積 normalize :: a -> Maybe a -- 正規化 normalize a = a `mdiv` (norm a) square :: a -> Double -- 二乗 square a = a `dot` a
mdivは逆数を掛けるのと等しいことをクラス定義で記述しておく。除算
なのでsが0の場合はエラーだ。ここでは解をMaybe型にし、エラーなら
Nothingを返すようにしている。
Vectorクラスのnormalize(正規化)とsquare(二乗)についても
同じくクラス定義で実装してしまおう。normalEqualはベクトル同士の
比較用関数である。ご存知の通りコンピュータで実数を扱うと誤差が
生じるので、理論上同一になる筈の結果がそうならないことがある。
「誤差の範囲なら同じとみなす」ような比較用だ。使うかどうかわからないが。
またこれに付随して(?)、nearly0::Doubleも定義しておく。
のちのちMaybe型に関連する関数を使うためにはData.Maybeモジュールをimportしないといけない。今のうちに入れておく。
import Data.Maybe
なお、Matrix(行列)は将来的には使うが、とりあえず今は無視する。
次に三次元ベクトル型を定義しよう。Vector3だ。
data Vector3 = Vector3 Double Double Double (中略) instance Matrix Vector3 where madd (Vector3 ax ay az) (Vector3 bx by bz) = Vector3 (ax + bx) (ay + by) (az + bz) msub (Vector3 ax ay az) (Vector3 bx by bz) = Vector3 (ax - bx) (ay - by) (az - bz) (中略) cross :: Vector3 -> Vector3 -> Vector3 cross (Vector3 ax ay az) (Vector3 bx by bz) = Vector3 (ay * bz - by * az) (az * bx - bz * ax) (ax * by - ay * bx) (以下続く…)
外積だけは三次元ベクトル特有の演算なので（本当かどうか知らない）、
クラス定義には含められず独立した関数crossとして定義した。
動作確認のため、対話環境(ghci)で試す。以下はsrcディレクトリ内で
実行した場合である。
$ ghci Prelude> :l Ray.Algebra [1 of 1] Compiling Ray.Algebra ( Ray/Algebra.hs, interpreted ) Ok, modules loaded: Ray.Algebra. *Ray.Algebra> let a = Vector3 1 2 3 *Ray.Algebra> a [1.0,2.0,3.0] *Ray.Algebra> let b = Vector3 4 5 6 *Ray.Algebra> putStrLn $ show $ madd a b [5.0,7.0,9.0] *Ray.Algebra> putStrLn $ show $ msub a b [-3.0,-3.0,-3.0] *Ray.Algebra> *Ray.Algebra> putStrLn $ show $ mscale 5 a [5.0,10.0,15.0] *Ray.Algebra> putStrLn $ show $ mdiv a 5 Just [0.2,0.4,0.6000000000000001] *Ray.Algebra> putStrLn $ show $ norm a 3.7416573867739413 *Ray.Algebra> putStrLn $ show $ dot a b 32.0 *Ray.Algebra> let c = normalize a *Ray.Algebra> c Just [0.2672612419124244,0.5345224838248488,0.8017837257372732] *Ray.Algebra> let d = fromJust c *Ray.Algebra> d [0.2672612419124244,0.5345224838248488,0.8017837257372732] *Ray.Algebra> putStrLn $ show $ norm d 1.0 *Ray.Algebra> let x = Vector3 1 0 0 *Ray.Algebra> let y = Vector3 0 1 0 *Ray.Algebra> let z = cross x y *Ray.Algebra> z [0.0,0.0,1.0]
それなりにうまくいっているようだ。が、いくつか適当な値で試しても、 正直な所ちゃんとテストできているかどうかわからない。ということで 次回はユニットテストを考える。
同一画像検索(6): 改良して完成
このネタの最後に幾つか確認と改良をして完成させよう。
総当たり処理を少し改善
roundRobinは再帰で定義しているが、場合分けが格好悪い。isSameの
戻り値がBoolなところが問題か。
roundRobin x (y:ys) | isSame x y == False = roundRobin x ys | otherwise = (snd y):(roundRobin x ys)
同一ならyのFilePathを、そうでなければ空リストを返せばよさそう。
ついでに、前回isSame内で同一かどうかを判定するのにfindを使った
のをanyに変えておこう。「同一」かどうかBoolで返してくれれば
よいのでfindである必要はない。（単にanyを知らなかっただけ）
roundRobin x (y:ys) = isSame x y ++ roundRobin x ys isSame :: Image -> Image -> [FilePath] isSame x y = if any differ (zip (fst x) (fst y)) then [] else [snd y] where differ :: (Word8, Word8) -> Bool differ (a, b) = (if a > b then a - b else b - a) > threshold
これでだいぶすっきりした。
重複した出力を取り除く
前回の出力結果を再掲する。
probably same: work/IMG_0309-2.jpg, work/IMG_0309-3.jpg, work/IMG_0309-4.jpg, work/IMG_0309.jpg probably same: work/IMG_0309-3.jpg, work/IMG_0309-4.jpg, work/IMG_0309.jpg probably same: work/IMG_0309-4.jpg, work/IMG_0309.jpg probably same: work/sample1.jpg, work/sample7.jpg probably same: work/sample2.jpg, work/sample5.jpg
2行目、3行目は1行目の部分集合であることがわかる。部分集合かどうかを
調べるのはHaskellなら簡単にできそう。
Webを検索したらやはり、Data.List
の中にそのものズバリisInfixOfがあった！matchImageから返って
くるリストについて、ある要素が他のすべての要素と比較してどれの
部分集合でもなければ自身を返すようにすればよいだろう。
findSameの中でmatchImageの結果を渡すようにする。
findSame fs = do fps <- mapM (getFingerPrint 4) fs let ps = matchImage $ zip fps fs return $ deduplicate ps ps deduplicate :: [[FilePath]] -> [[FilePath]] -> [[FilePath]] deduplicate _ [] = [] deduplicate xs (y:ys) | any (y `isInfixOf`) xs = deduplicate xs ys | otherwise = y:deduplicate xs ys
動かしてみると。。。だめだ、一件も同じ画像とみなされなくなった!? ここで30分ほどハマった。確認したいのは自分が「他の要素に」 含まれているかどうかだ。しかし上記のxsには「自分自身も」含まれている! これでは自分自身にマッチしてしまって全要素が消える。自分以外で という条件をつけよう。
deduplicate xs (y:ys) | any isProperSubset xs = deduplicate xs ys | otherwise = y:deduplicate xs ys where isProperSubset :: [FilePath] -> Bool isProperSubset x = x /= y && y `isInfixOf` x
簡潔に書く方法がよく分からないのでちょっと面倒くさくなってしまったが、 とりあえず無駄な要素は除去できた!
probably same: work/IMG_0309-2.jpg, work/IMG_0309-3.jpg, work/IMG_0309-4.jpg, work/IMG_0309.jpg probably same: work/sample1.jpg, work/sample7.jpg probably same: work/sample2.jpg, work/sample5.jpg
パラメータを引数で与える
ここまでのところ、ソース中に2つの定数が埋め込まれている。fingerprintの 解像度と画像比較時の差の閾値だ。何度か試して適した値を埋め込んでおく のも良いが、試すためにもコマンド実行時にいろいろ変えて与えたい。 そこで、"-p"オプションをサポートしよう。ただし、細かいエラーチェックは 面倒なので割愛する。第一引数が"-p"で始まっていたらオプションが指定された とし、そうでなければ第一引数も処理対象のディレクトリとみなす。 オプションは"-pR,T"で、Rが解像度、Tが閾値。 両パラメータとも正整数である前提だ。よって、変な引数を与えたときの動作は保証されない。
まず、オプションをちゃんと理解できたと仮定して、その後の処理ができる
ように改造しよう。両パラメータともfindSameに渡す必要があるので
関数定義を変更する。
findSame :: Int -> Int -> [FilePath] -> IO [[FilePath]] findSame r t fs = do fps <- mapM (getFingerPrint r) fs let ps = matchImage (fromIntegral t) $ zip fps fs
第一引数が解像度、第二が閾値だ。解像度をgetFingerPrintの引数に
そのまま渡せば良い。閾値は初お目見えなのでmatchImageに渡して
最終的にはisSameで条件判定に使われるようにしておく。
(ソースはこちら)
なおfromIntegral tとしているのはisSame内ではWord8として
比較しているからIntのまま渡せないため。
下準備ができたところで引数処理に移ろう。引数全部を渡してオプションの
有無、両パラメータを処理するparseOptを定義する。戻り値は
解像度、閾値、処理対象ディレクトリのリスト、の3つ。
parseOpt :: [String] -> (Int, Int, [FilePath]) parseOpt (d:ds) | "-p" `isPrefixOf` d = (r, t, ds) | otherwise = (8, 8, d:ds) where [r, t] = map (read :: String -> Int) (splitOn "," (drop 2 d))
当初、どうしたら引数の有無やパラメータを取り出せるかだいぶ悩んだが、
まずは第一引数が"-p"で始まっていなければ、与えられたリスト(=d:dsだ)を
そのまま、パラメータはデフォルト値(両方とも8とした)を
返せば良いとした(otherwiseの行)。"-p"で始まるかどうかは、先に
"部分集合"の判定を考えていた時にisPrefixOfもチェックしていたので
それが使えると判断。あとはそう難しくない。最初の二文字(="-p")を
除き、","(カンマ)で分割、それぞれの文字列を「正整数と仮定」して
Intに変換すればよい。最後の変換のところ、ちょっと立ち止まったが、
最終的には上記の通りread関数でなんとかなった。
（エラー処理を無視すれば）
$ ghc -o picf Main.hs
$ ./picf -p16,4 ~/work
:
ちゃんと動く！パラメータを変えると条件がきつくなって同一と表示 されなくなる。スバラシイ。
cabalでコンパイル
この件の最初の回でcabalを使う準備をしていながら最後まで何も使わない
のはもったいないので、本プログラムをcabalでコンパイルしてみる。
cabalを使った一連の流れはここを参考にした。cabal buildとすれば
よいらしい。cabalファイルはプロジェクトディレクトリのトップに
あるのでそこで実行する・・・と、エラーが出た。
$ cabal build ./picfinder.cabal has been changed. Re-configuring with most recently used options. If this fails, please run configure manually. Warning: The package list for 'hackage.haskell.org' is 103 days old. Run 'cabal update' to get the latest list of available packages. Resolving dependencies... Configuring picfinder-0.1.0.0... Building picfinder-0.1.0.0... Preprocessing executable 'picfinder' for picfinder-0.1.0.0... cabal: can't find source for Main in .
ソースが見つからないだと。指定していないから当たり前だ。
hs-source-dirsで指定するらしい。気を取り直して。
$ cabal build
./picfinder.cabal has been changed. Re-configuring with most recently used
(中略)
Preprocessing executable 'picfinder' for picfinder-0.1.0.0...
src/Finder.hs:7:8:
Could not find module ‘Data.ByteString’
It is a member of the hidden package ‘bytestring-0.10.4.0’.
Perhaps you need to add ‘bytestring’ to the build-depends in your .cabal file.
Use -v to see a list of the files searched for.
(以下略)
よくわからないがbuild-dependsにXXXXを足せとある。
今度は成功した！
$ cabal build ./picfinder.cabal has been changed. Re-configuring with most recently used (中略) Resolving dependencies... Configuring picfinder-0.1.0.0... Building picfinder-0.1.0.0... Preprocessing executable 'picfinder' for picfinder-0.1.0.0...
実行ファイルはdist/build/picfinder/picfinderとしてできている
らしい。実行してみる。
$ dist/build/picfinder/picfinder -p4,4 ~/work probably same: work/IMG_0309-2.jpg, work/IMG_0309-3.jpg, work/IMG_0309-4.jpg, work/IMG_0309.jpg :
やっとここまでたどり着いた。最終回ということで詰め込みすぎた感は あるがよしとしよう。
次は何をしようか。
同一画像検索(5): 同一判定方法の再考
前回簡易版を作ってみたが、縮小した画像が「同一」と見做されなかった。 今回はこれにどう対処するか検討してみる。 この問題は、各画像を4x4解像度に変換した結果(=fingerprint)を取った時に、 元画像と縮小画像とで微妙に異なるのが原因だった。 簡易版は「同一画像ならfingerprintが全く同じになる」ことを前提に作って あったからだ。
そこで、同一画像と見做せるようにする対策案を考えてみた。
- 解像度をもっと減らす
- 色階調を減らす
- fingerprintの微妙な違いを許容する
a. 解像度をもっと減らす
前回のサンプル画像で試してみる。解像度を2x2に減らしたところ、2つの画像の 差はなくなった。これは行けるかもと思ったが、別の画像で試したらやはり差が生じた。 また、そもそも2x2程度では、異なる画像がたまたま同一のfingerprintになる 可能性も高まる。この方法は却下だ。
b. 色階調を減らす
各色256階調、3原色で1600万色であるから、画像の縮尺が変われば同じ画像でも 多少の差が出てきてしかるべき。であれば、階調を減らせば多少の差は吸収される のではないか。階調を減らすには256段階(=1byte)の下数桁をマスクして 0にしてやれば良いだろう。たとえば、
<色値> AND 0xFC (0xFCは下2桁を除外するマスク→64段階にする）
といった処理をfingerprintの全バイトへ適用するということ。
しかしこの方法は根本解決にならない。階調を減らしたところで近い色値が「同一」 になる保証はない。極端な例だと、2つの画像のある点で色値がそれぞれ127と128と なるような場合、きわめて近い色なのにどのようなマスクを設定しても「同一」と 見做されない。ゆえにこの方法も却下だ。
c. fingerprintの微妙な違いを許容する
微妙な違いを許容して「同一」と考えるために、2画像のfingerprintの各点が閾値 以下の差なら「同一」とみなそう。(当初のロジックで、2段階目に解像度16x16で やろうとしたことだ)
元々、fingerprintが一致する前提ならMapを使って計算量を抑えられそうと
見込んだ。Mapなら計算量は (?)。しかし、差を調べるには総当たり
するしかないので計算量は
だ。画像数が数千枚レベルになると
大変そうなので嫌なのだが・・・仕方ない。
総当たりなので基本的なロジックは、、、
- リスト中の最初の画像とそれ以降の画像のfingerprintを比較して同じと みなせるものがあればそれらをリストで返す => (n-1回の比較)
- 二番目の画像とそれ以降の・・・（以下略）=> (n-2回の比較)
- 三番目の・・・（以下略)
- ・・・n-1番目の・・・（以下略）=> (1回の比較)
- => しめて
回の比較
だろう。返ってくるのは「同一」と判断されたリストの集合（リスト）。
ちなみに、比較がやり易いようにFingerPrintの型をByteStringから
[Word8]に変更し、画像を表すあらたな型Imageも定義してみた。
type FingerPrint = [Word8] type Image = (FingerPrint, FilePath)
先のロジックをコードにすると次のような感じ。
matchImage :: [Image] -> [[FilePath]] matchImage [] = [] matchImage (x:[]) = [] matchImage (x:xs) | ps == [] = matchImage xs | otherwise = (snd x:ps):(matchImage xs) where ps = roundRobin x xs roundRobin :: Image -> [Image] -> [FilePath] roundRobin x [] = [] roundRobin x (y:ys) | isSame x y == False = roundRobin x ys | otherwise = (snd y):(roundRobin x ys)
matchImageでn-1回の繰り返し、roundRobinである画像とその他の
画像を比較して同じとみなせるものがあればリストにして返す、とやっている。
なおisSameが同一かどうかの判別関数であり、同一の場合はその画像を
リストに加えている。
画像(のfingerprint)を同じとみなす方法もいくつかある(fingerprintをn次ベクトル
とみて距離を取るとか、同色の点が何割以上とか)が、今回は「各点の色の差が
すべて閾値以下」を条件とした。上記の通りfingerprintをWord8
(1バイト符号なし整数)のリストと定義しなおしたので、二つのリストを先頭から順に
比べていけばよいだろう。
閾値を超えたところで「違う」のだから比較をやめればよい。
isSame :: Image -> Image -> Bool isSame x y = d == Nothing where d = find differ (zip (fst x) (fst y)) differ :: (Word8, Word8) -> Bool differ (a, b) = d' > threshold where d' = if a > b then a - b else b - a threshold = 4 :: Word8
何かもっとスマートな書き方がありそうだが…。これは今後の課題にしよう。
thresholdは各点の各色の差の許容範囲(閾値)。ここでは4にしたが、
適当に決めた。色階調が256段階だから1.5%ぐらい。どれぐらいが適当か不明だが
5%ぐらいまでは許容範囲かなと思う。
あと、getFingerPrintにバグがあった。修正したものは以下の通り。
getFingerPrint :: Int -> FilePath -> IO FingerPrint getFingerPrint r f = do (sin, sout, serr, ph) <- runInteractiveCommand command waitForProcess ph fp <- BS.hGet sout size return $ B.unpack fp where geo = (show r) ++ "x" ++ (show r) size = r * r * 3 command = "convert -filter Cubic -resize " ++ geo ++ "! " ++ f ++ " PPM:- | tail -c " ++ (show size)
まず、コマンドの出力を取り込むところ、BS.hGetLineをBS.hGetに訂正。
出力にたまたま改行コードと同じものがあるとそこで切れてしまうバグだった。
次にImageMagickのコマンド部分、引数から-defineを抜いた。これをつけると
縮小処理が大幅に高速化するのだが、逆に画像の品質が悪くなった。今回の場合
fingerprintの誤差が本来よりかなり大きくなってしまった。これはいただけない。
(気付くのにだいぶ時間がかかった…)
実行してみた結果がこれ。
probably same: work/IMG_0309-2.jpg, work/IMG_0309-3.jpg, work/IMG_0309-4.jpg, work/IMG_0309.jpg probably same: work/IMG_0309-3.jpg, work/IMG_0309-4.jpg, work/IMG_0309.jpg probably same: work/IMG_0309-4.jpg, work/IMG_0309.jpg probably same: work/sample1.jpg, work/sample7.jpg probably same: work/sample2.jpg, work/sample5.jpg
前回試した画像に対し、50%、25%縮小画像でもちゃんと同一とみなしてくれている。 他にも2種類の画像(sample?.jpg)を試したが、いずれも認識できた。やれやれ。 ただ、一行目と二行目を比べるとわかるように、3つ以上の画像A,B,Cがあって、 それらが互いに「同一」と判断された場合は複数行に結果が出てくる。しかも 後の方は前のリストに包含されているので無駄だ。これは何とかしたい。
ということで、次回はこの件の最終回。上記の無駄を省く処理と若干の ソースの改善をしたいと思う。
同一画像検索(4): 簡易版を作ってみた
これまでの確認などを踏まえ、今回は簡易版を作ろう。仕様では4x4解像度の画像比較をして 一致したら次に16x16解像度でもう少し詳細に比較する、としているところ、まずは4x4解像度での 比較だけで作ってみようと思う。
最初に、「外枠」で示したfindSame関数の型シグネチャに問題があったので訂正する。
これまで示したのは下記の形だった。
findSame :: [String] -> [[String]]
画像比較のためImageMagickを呼び出す仕様なので、どうしても副作用が発生する。
haskellではそれが含まれる場合はどうやっても純粋な（副作用のない）型シグネチャには
できなさそうだ。（言われてみれば、その関数の処理のどこか一部に副作用があるなら
全体として関数の処理結果が引数だけで一意に決まらないのは当然か。）
下記が訂正版とその呼び出し元mainの変更部分。
findSame :: [String] -> IO [[String]] : main = do ds <- getArgs fs <- mapM getFileLists ds ss <- findSame $ concat fs putGroups ss
さて、肝心のfindSameをどうするかだが、処理の流れは次の通りかと。
- 各画像のfingerprint(前々回説明)を取得(ここでImageMagickを使う)
- 同じfingerprintを持つ画像群をListにまとめる
- 同じものが見つかった(=Listの長さが2以上)ら、そういった画像群のListを返す
これを関数にしてみる。プログラムが上の"処理の流れ"そのまんまなのはさすが haskellといったところか。なお、以後のコード片ではファイル名をStringではなく 別名のFilePath(Preludeで定義済み)、fingerprintもByteStringではなく FingerPrint型とした。
findSame :: [FilePath] -> IO [[FilePath]] findSame fs = do fps <- mapM getFingerPrint4 fs let es = Map.elems $ foldl insertItem Map.empty (zip fps fs) return $ filter (\x -> length x > 1) es
getFingerPrint4は4x4解像度のfingerprintを取得する関数だが、実際は
解像度を引数で与えるgetFingerPrintに第一引数を4としたもの。この辺も
関数型言語らしい。
getFingerPrint :: Int -> FilePath -> IO FingerPrint getFingerPrint r f = do (sin, sout, serr, ph) <- runInteractiveCommand command waitForProcess ph BS.hGetLine sout where geo = (show r) ++ "x" ++ (show r) size = r * r * 3 command = "convert -define jpeg:size=" ++ geo ++ " -filter Cubic -resize " ++ geo ++ "! " ++ f ++ " PPM:- | tail -c " ++ (show size) getFingerPrint4 = getFingerPrint 4
insertItemは前回書いたままである。万が一、全ソースに興味がある方は
GitHubをどうぞ。
早速実行して試してみよう。以下がサンプルで使った画像(の25%縮小版)。
オリジナル(IMG_0309.jpg)、その単純なコピー(IMG_0309-2.jpg)、
50%縮小版(IMG_0309-3.jpg)、25%縮小版(IMG_0309-4.jpg)を用意して試した。
結果は惨敗。
$ 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/IMG_0309.jpg, work/IMG_0309-2.jpg
同じサイズの画像しか同一とみなしていない。オリジナルと50%版のfingerprintを 比べてみる。
$ convert -define jpeg:size=4x4 -filter Cubic -resize 4x4! ~/work/IMG_0309.jpg PPM:- | tail -c 48 | od -x 0000000 4f47 5d52 6561 9996 bd9b c6c1 3d3e 4d36 0000020 3b43 6171 7e59 7476 555d 5a40 3b4c 596f 0000040 7f47 5970 707a 7b4f 4f6e 7485 8c54 5a7c 0000060 $ convert -define jpeg:size=4x4 -filter Cubic -resize 4x4! ~/work/IMG_0309-3.jpg PPM:- | tail -c 48 | od -x 0000000 4f47 5d52 6561 9996 bd9b c5c1 3d3e 4d37 0000020 3b43 6171 7e59 7476 555d 5a40 3b4c 596f 0000040 7f47 5970 707a 7b4e 4f6e 7485 8c54 5a7c 0000060
違う箇所が3つあるので3つの画素でRGBのうち一色だけ1/256の差があると。。。 本当に微妙な差だが、fingerprintが違うのだから「別の画像」ですね・・・。
さてどうしたものか。ちょっと考えてみて、結果は次回で報告。
同一画像検索(3): 再帰のKAIZEN
前回の記事で、同一キーのファイルを集める処理に再帰を使った関数tomapを示した。
やりたいのはListを与えて最終的にMap(連想配列)が欲しいだけなのだが、
引数にもMapが入っていて気持ち悪い感じだった。
そのあと、いろいろ記事を見たり本を読んだりして、やはりかっこ悪い書き方だったので KAIZENする。参考にしたのはこの本。プログラミングHaskell
再帰関数の基本形は次のような形らしい。
f [] = v f (x:xs) = x (+) f xs
ここでvは基底、(+)はいわゆる算術加算ではなく、xとf xsを混ぜ合わせる(笑)
関数とする。この形で前回の処理を書き換えてみる。
(前回) m = tomap dat Map.empty -- 呼び出し元 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) (KAIZEN) m = tomap dat -- 呼び出し元 tomap :: [(String, String)] -> Map String [String] tomap [] = Map.empty tomap (x:xs) = insertItem x (tomap xs) insertItem :: Map String [String] -> (String, String) -> Map String [String] insertItem m x = Map.insert k l m where k = fst x l = tolist x (Map.lookup k m)
前回は引数にMapが必要だったがそれがなくなっている。またMap.emptyが関数の中に
移ったことで、呼び出し元でいちいち書かなくて良くなった。とはいえ、あらたにinsertItemが必要になったので、トータルとしてどうなんだろう。
ということで次につながると。基本的な再帰の形になったら再帰ではなくfoldが使えるそうだ。 書き換えてみる。
m = Prelude.foldl insertItem Map.empty dat -- 呼び出し元 insertItem :: Map String [String] -> (String, String) -> Map String [String] insertItem m x = Map.insert k l m where k = fst x l = tolist x (Map.lookup k m)
呼び出し元にfoldlを使った。ただし、foldlはPreludeにもMapにも定義されているので、 Preludeを明示する必要がある。これで無駄な関数定義が不要になってすっきり。
次回はこれまで確認したところを組み合わせて、実際に動く同一画像検索プログラムを 作ることにしよう。
同一画像検索(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に落としても各点の値が微妙に 異なる可能性があるので、各点の比較時に差を取り一定の範囲内で あれば同じとみなす。
上記を踏まえ、プログラムの骨格は以下のようになるだろう。
- 引数に指定されたディレクトリからJPEG画像ファイルのListを取得する
["image1.jpg", "image2.jpg", ..., "imagen.jpg"]
- 画像を相互に比較し、同一画像とみなされるものを一組のListとし、
結果はそのListのListとする
[["image3.jpg", "image6.jpg"], ["image5.jpg", "image10.jpg", "image14.jpg"], ...]
- 同一画像の組ごとに、結果を画面に出力する
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を定義するだけ。 これが大変そうだが、、、それは次回にしよう。
