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]

intersperse

Haskell の Data.List モジュールに intersperse という関数がある。リストの要素の間に値を挿入する関数だ。

Prelude> import Data.List
Prelude Data.List> intersperse 0 [1..3]
[1,0,2,0,3]

これを自前で実装するとこうなる。

module Main where

intersperse :: a -> [a] -> [a]
intersperse _ (x:[]) = x : []
intersperse y (x:xs) = x : y : intersperse y xs

main :: IO ()
main = print $ intersperse 0 [1..3]
takatoh@apostrophe $ runhaskell intersperse.hs
[1,0,2,0,3]

素直な再帰関数だ。

Scheme ではどうだろうか。実は Gauche には intersperse が用意されているんだけど、自前で実装してみたらこうなった。

(define my-intersperse
  (lambda (delim lis)
    (let loop ((l (cdr lis)) (r (list (car lis))))
      (if (null? l)
        (reverse r)
        (loop (cdr l) (cons (car l) (cons delim r)))))))

(print (my-intersperse 0 '(1 2 3)))
takatoh@apostrophe $ gosh my-intersperse.scm
(1 0 2 0 3)

Haskell のと違って末尾再帰になっているのは、まあ、それが身についていると言ってもいいのかな。

さて、ここまで書いてみて畳み込みが使えそうだと気がついた。

(define my-intersperse
  (lambda (delim lis)
    (reverse (fold (lambda (x acc) (cons x (cons delim acc)))
      (list (car lis))
        (cdr lis)))))

(print (my-intersperse 0 '(1 2 3)))
takatoh@apostrophe $ gosh my-intersperse2.scm
(1 0 2 0 3)

同様に Haskell で。

module Main where

intersperse :: a -> [a] -> [a]
intersperse y xs = reverse $ foldl f [head xs] (tail xs)
  where
    f acc a = a : y : acc

main :: IO ()
main = print $ intersperse 0 [1..3]
takatoh@apostrophe $ runhaskell intersperse2.hs
[1,0,2,0,3]

Haskell の場合は foldl を使うよりも、単純な再帰のほうが見やすい気がする。それに Haskell は非正格だから、リスト全体をたどる必要(それも2回も)のある前者よりも後者のほうが効率がいいのかも。

文字列間のレーベンシュタイン距離を求める(2)Haskell版

一昨日のお題を、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

文字列を指定した文字数ごとに分割する

今日は Windows マシンから更新。

 cf. ruby 文字列を指定数で分割する – それマグで!

Haskell でやってみた。

module Main where

slices :: Int -> [a] -> [[a]]
slices _ [] = []
slices n xs = h : slices n d
  where
    (h, d) = splitAt n xs

main :: IO ()
main = print $ slices 3 "abcdefghijklmnopqrstuvwxyz"
^o^ > runhaskell stringSlices.hs
["abc","def","ghi","jkl","mno","pqr","stu","vwx","yz"]

Scheme だとこう。

(define slices
  (lambda (lis n)
    (if (< (length lis) n)
      (list lis)
      (cons (take lis n) (slices (drop lis n) n)))))

(define string-slices
  (lambda (str n)
    (map list->string (slices (string->list str) n))))

(print (string-slices "abcdefghijklmnopqrstuvwxyz" 3))
^o^ > gosh string-slices.scm
(abc def ghi jkl mno pqr stu vwx yz)

最後に JavaScript。

function stringSlices(n, str) {
  var l = str.length;
  var result = [];
  for (var i = 0; i < l; i += n) {
    result.push(str.slice(i, i + n));
  }
  return result;
}

console.log(stringSlices(3, "abcdefghijklmnopqrstuvwxyz"));
^o^ > node stringSlices.js
[ 'abc', 'def', 'ghi', 'jkl', 'mno', 'pqr', 'stu', 'vwx', 'yz' ]

これ、もうちょっとスマートにいかないかな。

[追記]

JavaScript 版、Haskell 版や Scheme 版と同じように考えてみた。少しはスマートになったかな。そうでもないか?

function stringSlices(n, str) {
  if (str.length == 0) {
    return [];
  } else {
    var l = stringSlices(n, str.slice(n))
    l.unshift(str.slice(0, n))
    return l
  }
}

console.log(stringSlices(3, "abcdefghijklmnopqrstuvwxyz"));
^o^ > node stringSlices2.js
[ 'abc', 'def', 'ghi', 'jkl', 'mno', 'pqr', 'stu', 'vwx', 'yz' ]

scanlでフィボナッチ数列

たまには 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 でやってみた。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

Luhnアルゴリズムでクレジットカードの番号をチェック:Haskell版

こないだやったLuhnアルゴリズムでのチェックをHaskellでもやってみた。

module Main (main) where

import Data.Char

numbers = [
  "5555555555554444",
  "5105105105105100",
  "4111111111111111",
  "4012888888881881",
  "3530111333300000",
  "3566002020360505",
  "30569309025904",
  "38520000023237",
  "378282246310005",
  "371449635398431",
  "378734493671000",
  "6011111111111117",
  "6011000990139424"
]

checkNumber num = sum' `mod` 10 == 0
  where
    sum' = sum $ zipWith add' (cycle [1,2]) (reverse num)
    add' x y = let z = x * digitToInt y
    in
    if z > 9 then z - 9 else z

main = mapM_ (print . checkNumber) numbers

実行結果:

^o^ > runhaskell checkCardNumber.hs
True
True
True
True
True
True
True
True
True
True
True
True
True

suffix array ってのは

こないだのを参考にしてくれたらしい。

なんだか俺のコードよりもHaskellらしく見えるよ。

ところで,リンク先のコードだと検索するたびに suffix array というか suffix のリストを作っているように見える。俺の理解では,suffix array を利用するメリットというのは,suffix array を作るときには大量にメモリを必要とするけど検索するときには必要ない,ってことだと思うんだけど。

それはそれとして forever という関数を初めて知った。今度使ってみよう。

簡単なWebサーチエンジンの作り方を試す

気がつけば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を適用して,あとは適当にフォーマットして出力すればいいだけだ。ファイルは課題のページからリンクしてるこのページをダウンロードして使った(ファイル名決めうち)。

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

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

急勾配の判定

id:edvakfさんがやってるのを見かけたので久しぶりに。

 

どう書く?org にはこれをポストしたんだけど:

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