カテゴリー: Haskell

こないだのリフル・シャッフルを Haskell でやってみた。

Prelude> concat $ zip [0,2,4,6,8] [1,3,5,7,9]

:2:10:
    Couldn't match type `(a1, b0)' with `[a0]'
    Expected type: [[a0]]
      Actual type: [(a1, b0)]
    In the return type of a call of `zip'
    In the second argument of `($)', namely
      `zip [0, 2, 4, 6, ....] [1, 3, 5, 7, ....]'
    In the expression:
      concat $ zip [0, 2, 4, 6, ....] [1, 3, 5, 7, ....]

あれ。そうか、zip はタプルのリストを返すんだっけ。

Prelude> zip [0,2,4,6,8] [1,3,5,7,9]
[(0,1),(2,3),(4,5),(6,7),(8,9)]

じゃあ、foldr を使ってみようか。

Prelude> foldr (\(x,y) acc -> x:y:acc) [] $ zip [0,2,4,6,8] [1,3,5,7,9]
[0,1,2,3,4,5,6,7,8,9]

うまくいった。
いや、zipWith のほうがいいか？

Prelude> concat $ zipWith (\x y -> x:y:[]) [0,2,4,6,8] [1,3,5,7,9]
[0,1,2,3,4,5,6,7,8,9]

一昨日のお題を、Haskell でやってみた。

module Main where

import System.Environment (getArgs)

mValue :: [[a]] -> Int -> Int -> a
mValue m i j = (m !! i) !! j

mReplace :: [[a]] -> Int -> Int -> a -> [[a]]
mReplace m i j v = bi ++ [bj ++ [v] ++ aj] ++ ai
  where
    bi = take i m
    ji = m !! i
    ai = drop (i + 1) m
    bj = take j ji
    aj = drop (j + 1) ji

ldInit :: String -> String -> [[Int]]
ldInit s1 s2 = [[0 | j <- [0..n]] | i <- [0..m]]
  where
    m = length s1
    n = length s2

ldBuild :: ([[Int]], String, String) -> (Int, Int) -> ([[Int]], String, String)
ldBuild (m, s1, s2) (i, j) = (mReplace m i j v, s1, s2)
  where
    v = ldCalc m s1 s2 i j

ldCalc :: [[Int]] -> String -> String -> Int -> Int -> Int
ldCalc m s1 s2 i j =
  if i == 0 && j == 0 then
    0
  else if i == 0 then
    j
  else if j == 0 then
    i
  else
    let x = if (s1 !! (i-1)) == (s2 !! (j-1)) then 0 else 1
  in
  minimum [(mValue m i (j-1)) + 1, (mValue m (i-1) j) + 1, (mValue m (i-1) (j-1)) + x]

levenshteinDistance :: String -> String -> Int
levenshteinDistance s1 s2 = mValue ldM (length s1) (length s2)
  where
    m = ldInit s1 s2
    ij = [(i, j) | i <- [0..(length s1)], j <- [0..(length s2)]]
    (ldM, _, _) = foldl ldBuild (m, s1, s2) ij

main :: IO ()
main = do
  args <- getArgs
  let s1 = args !! 0
  let s2 = args !! 1
  print $ levenshteinDistance s1 s2

0 で初期化した二次元リスト（マトリックス）から foldl を使ってレーベンシュタイン距離のマトリックスを作る、というアイデアは出たんだけど、マトリックスを 0 で初期化する（ldInit）のと要素を置き換えたマトリックスを作る（mReplace）のがなかなか難産だった。結果として ldInit はリスト内包表記を使って簡潔にかけたけど、mReplace のほうはなんか泥臭くなってしまった。もっとエレガントにいかないもんだろうか。 実行例：

takatoh@nightschool $ runhaskell ld.hs apple play
4
takatoh@nightschool $ runhaskell ld.hs perl pearl
1

たまには Haskell のエントリを。

昨日、unfoldr の使い方を調べてるときに気づいたんだけど、scanl を使ってもフィボナッチ数列を作れる。Haskell だから当然無限リストだ。

Prelude> let fib = scanl (+) 0 (1:fib)
Prelude> take 20 $ fib
[0,1,1,2,3,5,8,13,21,34,55,89,144,233,377,610,987,1597,2584,4181]

これは以前書いた zipWith を使うやつよりももっと簡単。

先日のお題を、今度は Haskell でやってみた。Haskell はだいぶ忘れてるな。
乱数の使い方は↓ここを参考にした。

cf. haskell で乱数 – はわわーっ

module Main where

import System.Environment ( getArgs )
import System.Random
import Control.Monad

strPool :: String
strPool = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"

lenPool :: Int
lenPool = length strPool - 1

randomStr :: Int -> IO String
randomStr n = do
  lis <- replicateM n $ (getStdRandom $ randomR (0, lenPool) :: IO Int)
  return $ map (\ x -> strPool !! x) lis

main :: IO ()
main = do
  argv <- getArgs
  let n = read $ head argv
  randStr <- randomStr n
  putStrLn randStr

実行結果：

^o^ > runhaskell randomString.hs 20
GhDADFMuNNxrUBbpMXw3

気がつけば12月も中旬だよ……。

少し前になるけど，「あとで試す」タグをつけといたやつをやってみる。これ↓：

cf. 簡単なWebサーチエンジンの作り方 – 加藤 和彦のブログ

具体的な手順はこっちのページで公開されている。

cf. http://www.osss.cs.tsukuba.ac.jp/kato/wiki/kato/index.php?Jikken-search-engine

さて，順にやってみよう。

課題1-1

与えられた文字列のsuffix arrayを作成するプログラムを作成せよ．

import Data.List

suffixArray :: String -> [Int]
suffixArray xs = map fst $ sort' $ zip [1..] $ init $ tails xs
  where
    sort' = sortBy (\a b -> compare (snd a) (snd b))

実行例：

*Main> suffixArray "abcbccab"
[7,1,8,2,4,6,3,5]

課題1-2

与えられた文字列に対し，その部分文字列を入力し，部分文字列が出現する全位置を列挙する検索プログラムを作成せよ．（ヒント： suffix array上の2分探索を行う）

二分探索とはいうものの，検索対象の部分文字列の出現箇所すべてを列挙するには，中央の値（suffix）の右か左を単純に無視してしまうわけには行かない。場合によっては左右両方にあるかもしれないから。なので，まずは整理してみる。

1. 検索文字列よりも小さい → 左にはない。右を検索。
2. 検索文字列と等しい → 当たり。左にはないが，まだ右にはあるかもしれないので検索。
3. 検索文字列よりも大きい → これはさらに2ケースに分けられる。
   1. 検索文字列がプレフィックスになっている → 当たり。さらに左にも右にもあるかもしれないので両方を検索。
   2. 検索文字列がプレフィックスになっていない → 右にはない。左を検索。

これをコードにするとこうだ：

import Data.List

suffixArray :: String -> [Int]
suffixArray xs = map fst $ sort' $ zip [1..] $ init $ tails xs
  where
    sort' = sortBy (\a b -> compare (snd a) (snd b))

suffixOf :: String -> Int -> String
suffixOf s n = drop (n-1) s

search :: String -> [Int] -> String -> [Int]
search _ [] _ = []
search s ary sb = let n = (length ary) `div` 2
                  sfx = suffixOf s (ary !! n)
                  in
                  if sfx < sb then
                    search s (drop (n+1) ary) sb
                  else if sfx == sb then
                    (ary !! n) : search s (drop (n+1) ary) sb
                  else if isPrefixOf sb sfx then
                    (search s (take n ary) sb) ++ [ary !! n] ++ (search s (drop (n+1) ary) sb)
                  else
                    search s (take n ary) sb 

実行例：

*Main> search "abcbccab" (suffixArray "abcbccab") "ab"
[7,1]

課題1-3

指定された1個のHTMLテキストファイルをメモリ中に読み込んで1個の文字列とし，それに対する suffix array をメモリ中に作成し，ユーザから入力された文字列を検索して，入力文字列が出現する全位置を列挙するプログラムを作成せよ．

ファイルを読み込んで，searchを適用して，あとは適当にフォーマットして出力すればいいだけだ。ファイルは課題のページからリンクしてるこのページをダウンロードして使った（ファイル名決めうち）。

• CodeConvTOC.doc.html

module Main where

import Data.List
import System.Environment ( getArgs )

-------------------------------------------------------------------------------

filename = "CodeConvTOC.doc.html"

main :: IO ()
main = do argv <- getArgs
           contents <- readFile filename
          substring <- return $ head argv
          mapM_ (putStrLn . format contents) $ search contents (suffixArray contents) substring

format :: String -> Int -> String
format str pos = show pos ++ ": " ++ take 10 (suffixOf str pos)

-------------------------------------------------------------------------------

suffixArray :: String -> [Int]
suffixArray xs = map fst $ sort' $ zip [1..] $ init $ tails xs
  where
    sort' = sortBy (\a b -> compare (snd a) (snd b))

suffixOf :: String -> Int -> String
suffixOf s n = drop (n-1) s

search :: String -> [Int] -> String -> [Int]
search _ [] _ = []
search s ary sb = let n = (length ary) `div` 2
                  sfx = suffixOf s (ary !! n)
                  in
                  if sfx < sb then
                    search s (drop (n+1) ary) sb
                  else if sfx == sb then
                    (ary !! n) : search s (drop (n+1) ary) sb
                  else if isPrefixOf sb sfx then
                    (search s (take n ary) sb) ++ [ary !! n] ++ (search s (drop (n+1) ary) sb)
                  else
                    search s (take n ary) sb
-------------------------------------------------------------------------------

実行例：

^o^ >runhaskell suffixArray.hs File
10208: File Examp
1959: File Names
1664: File Names
2250: File Organ
1815: File Suffi
2422: Files</a>

課題1-4

ちょっと時間があいたけど続き。

以下の手順で，複数ファイルに対して全文検索を行うプログラムを作成せよ．

1. 指定された1個以上のm個のファイルをメモリ内で連結した長い文字列を作る．そのときにファイルの境 界に，テキストファイル中には通常は現れない文字（例えばヌル文字’\0’等）を入れ，検索時に複数ファイルを またいだ文字列にマッチしないようにしておく．

2. 1.で作った作った長い文字列中の文字位置から元のファイル名を得られるようにするための表を作る． 例えば，file1.html, file2.html, file3.htmlがそれぞれ100, 200, 300のファイルサイズをもつとき，[(“file 1.html”, 100), (“file2.html”, 200), (“file3.html”, 300)]というような表を作る（効率的な方法，プログ ラムしやすい方法を各自工夫せよ）．

3. 課題1-3で作成したプログラムと，1.および2.で作ったデータを用いて，ユーザから入力された文字列を 検索し，入力文字列が出現するファイル名とファイル内の位置（ファイルの先頭から数えた文字数）を全て列 挙するプログラムを作成せよ．

課題1-3から変えたとこだけ：

main :: IO ()
main = do argv <- getArgs
          files <- mapM readFile $ tail argv
          let contents = concat $ intersperse "\0" files
          let table = makeFileTable (tail argv) $ map length files
          let substring = head argv
          mapM_ (putStrLn . format table contents) $ search contents (suffixArray contents) substring 

-------------------------------------------------------------------------------

format :: [(String, Int)] -> String -> Int -> String
format t str pos = let (f, p) = filePos t pos
                   in
                   f ++ ": " ++ show p ++ ": " ++ take 15 (suffixOf str pos)

-------------------------------------------------------------------------------

makeFileTable :: [String] -> [Int] -> [(String, Int)]
makeFileTable fs ls = zip fs $ snd $ mapAccumL (\a x -> (a+x+1, a)) 1 ls

filePos :: [(String, Int)] -> Int -> (String, Int)
filePos (f:[]) n = (fst f, n - snd f + 1)
filePos (f1:f2:fs) n | snd f2 < n = filePos (f2:fs) n
                     | otherwise = (fst f1, n - snd f1 + 1)
-------------------------------------------------------------------------------

元ファイルの表はファイル名とその開始位置をタプルにした。

実行例：

^o^ >runhaskell suffixArray.hs Intro CodeConvTOC.doc.html CodeCOnventions.doc.html
CodeConvTOC.doc.html: 1063: Introduction</a
CodeCOnventions.doc.html: 517: Introduction</h

今日はここまで。続きは明日……やれるといいなぁ。

import List

steep xs = and $ zipWith (>) xs $ map sum $ tail $ tails xs

$ が多くてうっとうしいからがんばって無くしてみた。ついでに引数もなくなった。

import List

steep2 = and . s (zipWith (>)) sums
  where
    s f g x = f x (g x)
    sums = map sum . tail . tails

なんかかえって解りにくいかも。

実行結果：

*Main> steep2 [32,16,8,4,2,1]
True
*Main> steep2 [31,16,8,4,2,1]
False