カテゴリー: Haskell

パソコン甲子園というのを見つけた。
プログラミング部門の問題が公開されてるので（↓）ちょっとやってみよう。

• http://www.pref.fukushima.jp/pc-concours/common/2006honsen.pdf

正方行列つながりってことで問題01。

8文字×8行のパターンを右回りに90度、180度、270度回転させて出力し終了するプログラムを作成してください。

rotateMatrixR で右に90度回転させる。左に回転させる rotateMatrixL があるのは，勘違いしてさきに書いちゃったから。でも考えると右回転はちょっと面倒そうだな。これで正解かも。
main は手抜き。美しくない。

module Main (main) where

main :: IO ()
main = do cs <- getContents >>= return . lines
          putStrLn "90"
          showMatrix $ rotateMatrixR cs
          putStrLn "180"
          showMatrix $ rotateMatrixR $ rotateMatrixR cs
          putStrLn "270"
          showMatrix $ rotateMatrixR $ rotateMatrixR $ rotateMatrixR cs

rotateMatrixL :: [[a]] -> [[a]]
rotateMatrixL [xs] = [[x]| x <- reverse xs]
rotateMatrixL (xs:xss) = zipWith (:) (reverse xs) (rotateMatrixL xss)

rotateMatrixR :: [[a]] -> [[a]]
rotateMatrixR = reverse . rotateMatrixL . reverse

showMatrix :: [String] -> IO ()
showMatrix = putStr . unlines

実行例。

D:\>type input01.txt
#*******
#*******
#*******
#*******
#*******
#*******
#*******
########
D:\>runhaskell problem01.hs < input01.txt
90
########
#*******
#*******
#*******
#*******
#*******
#*******
#*******
180
########
*******#
*******#
*******#
*******#
*******#
*******#
*******#
270
*******#
*******#
*******#
*******#
*******#
*******#
*******#
########

追記：
右回転の方が簡単だった……orz

rotateMatrixR' :: [[a]] -> [[a]]
rotateMatrixR' = transpose . reverse

*Main> showMatrix sampleMatrix
#*******
#*******
#*******
#*******
#*******
#*******
#*******
########
*Main> showMatrix $ rotateMatrixR' sampleMatrix
########
#*******
#*******
#*******
#*******
#*******
#*******
#*******
*Main> showMatrix $ rotateMatrixR' $ rotateMatrixR' sampleMatrix
########
*******#
*******#
*******#
*******#
*******#
*******#
*******#

さらに追記：
ちがう！左回転も同じくらい簡単だ。

rotateMatrixL' :: [[a]] -> [[a]]
rotateMatrixL' = reverse . transpose

cf. 今日の一行 – リストによる正方行列処理

問題１。

matrix n = [[x+(n^2*y) | x <- [1..n^2]] | y <- [0..n^2-1]]

*Main> matrix 2
[[1,2,3,4],[5,6,7,8],[9,10,11,12],[13,14,15,16]]
*Main> matrix 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,5
3,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]]

問題２。
Data.List の transpose そのままでは芸がないので。

transpose' m = [[m!!x!!y| x <- [0..l]] | y <- [0..l]]
  where
    l = length m - 1

*Main> transpose' $ matrix 2
[[1,5,9,13],[2,6,10,14],[3,7,11,15],[4,8,12,16]]

問題３はあとで。

追記：
問題２の別解。foldr を使う。これなら正方行列でなくてもOK。

transpose'2 m = foldr (\a b -> zipWith (:) a b) (replicate (length m) []) m

*Main> transpose'2 $ matrix 2
[[1,5,9,13],[2,6,10,14],[3,7,11,15],[4,8,12,16]]

こういうのもできるのか。

Prelude> [x| x <- [0..3], y <- [0..3]]
[0,0,0,0,1,1,1,1,2,2,2,2,3,3,3,3]
Prelude> [y| x <- [0..3], y <- [0..3]]
[0,1,2,3,0,1,2,3,0,1,2,3,0,1,2,3]

cf. 今日の一行 – loopの列挙

trail はすでにたどったノードのリスト p と次にたどるノードの候補 q を受け取って，全ての経路を列挙する。「次のノード」がスタートと同じならそこでそのループは終わり。違うなら再帰的にノードをたどる。
各ノードは比較さえできればいいので Eq a にした。入出力の関係で結局は文字列になってるけど。

module Main (main) where

import Data.List (intersperse)
import System (getArgs)

trail :: (Eq a) => [a] -> [a] -> [[a]]
trail p q = concat $ map trail' q
  where
    trail' q1 | head p == q1 = [ p ++ [q1] ]
              | otherwise = trail (p ++ [q1]) $ filter (q1/=) q

trailLoop :: (Eq a) => a -> [a] -> [[a]]
trailLoop s = trail [s]

enumLoops :: (Eq a) => [a] -> [[a]]
enumLoops nodes = concat $ map (flip trailLoop nodes) nodes

showLoop :: [String] -> String
showLoop = concat . intersperse " -> "

main :: IO ()
main = do nodes <- getArgs
          mapM_ (putStrLn . showLoop) $ enumLoops nodes

実行例

D:\>runghc enumLoops.hs 1 2 3
1 -> 1
1 -> 2 -> 1
1 -> 2 -> 3 -> 1
1 -> 3 -> 1
1 -> 3 -> 2 -> 1
2 -> 1 -> 2
2 -> 1 -> 3 -> 2
2 -> 2
2 -> 3 -> 1 -> 2
2 -> 3 -> 2
3 -> 1 -> 2 -> 3
3 -> 1 -> 3
3 -> 2 -> 1 -> 3
3 -> 2 -> 3
3 -> 3

ノードが１つ増えるとループはぐっと増える。

D:\>runghc enumLoops.hs 1 2 3 4
1 -> 1
1 -> 2 -> 1
1 -> 2 -> 3 -> 1
1 -> 2 -> 3 -> 4 -> 1
1 -> 2 -> 4 -> 1
1 -> 2 -> 4 -> 3 -> 1
1 -> 3 -> 1
1 -> 3 -> 2 -> 1
1 -> 3 -> 2 -> 4 -> 1
1 -> 3 -> 4 -> 1
1 -> 3 -> 4 -> 2 -> 1
1 -> 4 -> 1
1 -> 4 -> 2 -> 1
1 -> 4 -> 2 -> 3 -> 1
1 -> 4 -> 3 -> 1
1 -> 4 -> 3 -> 2 -> 1
2 -> 1 -> 2
2 -> 1 -> 3 -> 2
2 -> 1 -> 3 -> 4 -> 2
2 -> 1 -> 4 -> 2
2 -> 1 -> 4 -> 3 -> 2
2 -> 2
2 -> 3 -> 1 -> 2
2 -> 3 -> 1 -> 4 -> 2
2 -> 3 -> 2
2 -> 3 -> 4 -> 1 -> 2
2 -> 3 -> 4 -> 2
2 -> 4 -> 1 -> 2
2 -> 4 -> 1 -> 3 -> 2
2 -> 4 -> 2
2 -> 4 -> 3 -> 1 -> 2
2 -> 4 -> 3 -> 2
3 -> 1 -> 2 -> 3
3 -> 1 -> 2 -> 4 -> 3
3 -> 1 -> 3
3 -> 1 -> 4 -> 2 -> 3
3 -> 1 -> 4 -> 3
3 -> 2 -> 1 -> 3
3 -> 2 -> 1 -> 4 -> 3
3 -> 2 -> 3
3 -> 2 -> 4 -> 1 -> 3
3 -> 2 -> 4 -> 3
3 -> 3
3 -> 4 -> 1 -> 2 -> 3
3 -> 4 -> 1 -> 3
3 -> 4 -> 2 -> 1 -> 3
3 -> 4 -> 2 -> 3
3 -> 4 -> 3
4 -> 1 -> 2 -> 3 -> 4
4 -> 1 -> 2 -> 4
4 -> 1 -> 3 -> 2 -> 4
4 -> 1 -> 3 -> 4
4 -> 1 -> 4
4 -> 2 -> 1 -> 3 -> 4
4 -> 2 -> 1 -> 4
4 -> 2 -> 3 -> 1 -> 4
4 -> 2 -> 3 -> 4
4 -> 2 -> 4
4 -> 3 -> 1 -> 2 -> 4
4 -> 3 -> 1 -> 4
4 -> 3 -> 2 -> 1 -> 4
4 -> 3 -> 2 -> 4
4 -> 3 -> 4
4 -> 4

引数が与えられたらそれをファイル名と見なしてファイルを読み込み，与えられなければ標準入力から読み込む。いわゆるフィルタとしても働くプログラム。こんな感じでいいか？

module Main (main) where

import System

main :: IO ()
main = do args <- getArgs
          contents <- if (not.null) args then readFile $ head args else getContents
          putStr contents

引数にファイル名を指定

D:\>runghc catFile.hs hello.txt
Hello, Haskell.

標準入力から

D:\>runghc catFile.hs < hello.txt
Hello, Haskell.

パイプ経由

D:\>type hello.txt | runghc catFile.hs
Hello, Haskell.

via 毎日Haskell – 2006-12-28 文字列の左詰、右詰
　cf. desumasuの日記 – Rubyの文字列操作関数をHaskellで定義する

length を使わずに書けたけど，短いとは言い難い。
ljust（左詰）と rjust（右詰）が定義されてるとして

center :: Int -> String -> String
center 0 [] = ""
center n xs = f (ljust n xs) (rjust n xs)
  where
    f l r | l == r = l
          | otherwise = g l (tail r ++ " ")
    g l r | l == r = l
          | otherwise = f " " ++ take (n-1) l) r

id:desumasu さんのと引数の順番が違うのは，この方が Haskell っぽいから（気のせい？）。２行目がないと，空文字列を0文字に中央詰めする場合にエラーになる。

実行例。

*Main> center 8 "abc"
"  abc   "
*Main> center 8 "abcd"
"  abcd  "
*Main> center 3 "abcd"
"abcd"
*Main> center 3 ""
"   "
*Main> center 0 ""
""

HUnit を使ったテスト（id:desumasuさんのコードを改変）。

import Test.HUnit

testCenter = test [
  "test1" ~: " hoge " ~=? center 8 "hoge" ,
  "test2" ~: "hoge" ~=? center 1 "hoge" ,
  "test3" ~: " hoge " ~=? center 7 "hoge" ,
  "empty1" ~: "" ~=? center 0 "" ,
  "empty2" ~: " " ~=? center 2 ""
]

*Main> runTestTT testCenter
Cases: 5  Tried: 5  Errors: 0  Failures: 0

1月1日からISBN（国際標準図書番号）が変わったという話題。

　via ぷわぷわのあかしろ – ISBN
　cf. 日本図書コード管理センター – ISBN規格改訂のお知らせ

そういえば昨日買った本のISBNは13桁だった。
そうか，チェックデジットの計算方法も変わってるのか。

で，旧番号から新番号に変換するコードを書いてみた。
入力は，頭の “ISBN” やチェックデジットはあってもなくても良いけど，区切りの “-” は必須。

module Main (main) where

import Data.Char (isAlpha, isDigit)
import System (getArgs)

checkDigit :: [Char] -> String
checkDigit s = show cd
  where
    cd = if l == 0 then 0 else 10 - l
    l = f `mod` 10
    f = sum $ zipWith (*) [1,3,1,3,1,3,1,3,1,3,1,3] $ map (\c -> read [c]) s

stripIsbnOld :: String -> String
stripIsbnOld = take 11 . dropWhile isAlpha

isbnConv :: String -> String -> String
isbnConv flg old = "ISBN" ++ flg ++ stripIsbnOld old ++ "-" ++ checkDigit (filter isDigit (flg ++ old))

isbnConv978 :: String -> String
isbnConv978 = isbnConv "978-"

main :: IO ()
main = do cs <- getArgs >>= return . head
          putStr $ isbnConv978 cs

実行例。

D:\>runghc isbnconv.hs ISBN4-949999-08-7
ISBN978-4-949999-08-3

お題だけ拝借。

　cf. Gaucheクックブック – タブをスペースで展開する

１文字ずつ処理する。正規表現を使ったり日本語を考慮するのはパス。

untabify :: Int -> String -> String
untabify w = f "" 0
  where
    f r _ [] = r
    f r p (c:cs) | '\t' == c = f (r ++ replicate (ts p) ' ') (p + ts p) cs
                 | otherwise = f (r ++ [c]) (p + 1) cs
    ts p = w - p `mod` w

はじめは foldl を使おうと思ったけど f の引数が３つになる（展開後の文字列を位置を蓄積する必要がある）のであきらめた。あと，haskell らしくリストの引数は後ろに。
実行例。

*Main> untabify 8 "012\t012345\t01"
"012     012345  01"

タブ幅は２文字がすき。

*Main> untabify 2 "012\t012345\t01"
"012 012345  01"

あ，そうか。f の引数をタプル（ペア）にしてやれば foldl が使えるんだ。

untabify2 :: Int -> String -> String
untabify2 w = fst . foldl f ("", 0)
  where
    f (r, p) c | '\t' == c = ( r ++ replicate (ts p) ' ' , p + ts p )
               | otherwise = ( r ++ [c] , p + 1 )
    ts p = w - p `mod` w

*Main> untabify2 8 "012\t012345\t01"
"012     012345  01"
*Main> untabify2 2 "012\t012345\t01"
"012 012345  01"

cf. HaHaHa! – ハイフンで区切られた文字をキャピタライズ
cf. 趣味的にっき – ハイフンで区切られた文字をキャピタライズ

↑ここら辺を見て思い出したのが，Ruby on Rails （より正確には ActiveSupport）にある String#underscore。
String#underscore は大文字/小文字/数字からなる文字列を小文字/数字/アンダースコアからなる文字列に変換するメソッドで……つまりこんな感じ。

D:\>irb -rrubygems -ractive_support --simple-prompt
>> [ "Railes",
?> "ActiveSupport",
?> "Active1Support",
?> "Active1support",
?> "ToDoList",
?> "XML",
?> "XML2",
?> "XMLData",
?> "XMLdata",
?> "XML2Data",
?> "Iso2022jpMailer"
>> ].each do |s| p s.underscore end
"railes"
"active_support"
"active1_support"
"active1support"
"to_do_list"
"xml"
"xml2"
"xml_data"
"xm_ldata"
"xml2_data"
"iso2022jp_mailer"
=> ["Railes", "ActiveSupport", "Active1Support", "Active1support", "ToDoList", "
XML", "XML2", "XMLData", "XMLdata", "XML2Data", "Iso2022jpMailer"]

これを Haskell でやってみた。

‘_’ は大文字の直前に入るんだけど，前後の文字によって入ったり入らなかったりで，ちょっと複雑。なので State モナドを使ってみた。

import Control.Monad.State
import Data.Char
import System.Environment

data CharCase = UpperB4Upper | UpperB4Lower | UpperB4Number | UpperAtEnd | Lower | Number | None

cState :: Char -> CharCase
cState c | isUpper c = UpperB4Upper
         | isLower c = Lower
         | otherwise = Number

procChar :: Char -> State CharCase [Char]
procChar c = get >>= p
  where
    p UpperB4Upper = do put $ cState c
                        return [toLower c]
    p UpperB4Lower = do put $ cState c
                        return $ "_" ++ [toLower c]
    p UpperB4Number = do put $ cState c
                         if isUpper c then return [toLower c]
                         else return $ "_" ++ [c]
    p UpperAtEnd = do put $ cState c
                      if isUpper c then return [toLower c]
                      else return $ "_" ++ [c]
    p Lower | isUpper c = do put (UpperB4Lower)
                             return [toLower c]
            | otherwise = do put $ cState c
                             return [c]
    p Number | isUpper c = do put (UpperB4Number)
                              return [toLower c]
             | otherwise = do put $ cState c
                              return [c]
    p None = do put $ if isUpper c then UpperAtEnd else cState c
                return [toLower c]

underScoreR :: String -> State CharCase String
underScoreR s = do strs <- mapM procChar $ reverse s return $ reverse $ concat strs underScore :: String -> String

underScore s = evalState (underScoreR s) None

UpperAtEnd は UpperB4Number と扱いが同じだから無くてもいいかも。

チェック用関数。

samples = [ ( "Rails" , "rails" )
          , ( "ActiveSupport" , "active_support" )
          , ( "Active1Support" , "active1_support" )
          , ( "Active1support" , "active1support" )
          , ( "ToDoList" , "to_do_list" )
          , ( "XML" , "xml" )
          , ( "XML2" , "xml2" )
          , ( "XMLData" , "xml_data" )
          , ( "2XMLdata" , "xm_ldata" )
          , ( "XML2Data" , "xml2_data" )
          , ( "Iso2022jpMailer" , "iso2022jp_mailer" )
          ]

checkSamples = mapM_ (putStrLn . check) samples

check s = (show $ underScore org == uds) ++ " " ++ org ++ " => " ++ uds
  where
    org = fst s
    uds = snd s

実際にやってみると

*Main> checkSamples
Loading package mtl-1.0 ... linking ... done.
True    Rails => rails
True    ActiveSupport => active_support
True    Active1Support => active1_support
True    Active1support => active1support
True    ToDoList => to_do_list
True    XML => xml
True    XML2 => xml2
True    XMLData => xml_data
True    XMLdata => xm_ldata
True    XML2Data => xml2_data
True    Iso2022jpMailer => iso2022jp_mailer

OKみたい。

久しぶりに時間があいたので Haskell をやってみよう，と思ったらこんなのを見つけた。

　haskellのある暮らし　-　頭の体操：３引数flip

f :: a -> b -> c -> d なる関数 f があったとして，

flip31 f a c b = f a b c

みたいに引数の順番を入れ替える関数をポイントフリースタイルで定義せよ，ってのが今回の指令。ただし f は残っても良い。
さっそくやってみるさー。

といってもパッと答えがひらめいたりはしないので地道に変換する。

flip31 f a c b = f a b c
            -->  flip (f a) c b
            -->  (flip.f) a c b

となって，引数を消すと

flip31 f = flip.f

つぎ。

flip32 f b a c = f a b c
            -->  (f a b) c
            -->  (flip f b a) c
            -->  (flip f) b a c

結局

flip32 f = flip f

あー，つまり flip の引数が特殊な場合ってことか。

残りの３つは結果だけ書く。

flip33 f = flip.(flip f)

flip34 f = flip (flip.f)

flip35 f = flip (flip.(flip f))

これでOKのはず。
もと記事にある関数でチェックしてみる。

*Main> check
[True,True,True,True,True]

OKのようだ。

もう少し，見た目にわかりやすいようなチェックをしてみよう。

*Main> let f a b c = a:b:c:[]
*Main> flip31 f 'a' 'c' 'b'
"abc"
*Main> flip32 f 'b' 'a' 'c'
"abc"
*Main> flip33 f 'b' 'c' 'a'
"abc"
*Main> flip34 f 'c' 'a' 'b'
"abc"
*Main> flip35 f 'c' 'b' 'a'
"abc"

OK。
けど，せめて関数の型をちゃんとかいておかないとさっぱりわかんないよな，これ。

追記：
さらに f も無くしてみる。

flip31' :: (a -> b -> c -> d) -> a -> c -> b -> d
flip31' = (flip.)

flip32' :: (a -> b -> c -> d) -> b -> a -> c -> d
flip32' = flip

flip33' :: (a -> b -> c -> d) -> b -> c -> a -> d
flip33' = (flip.).flip

flip34' :: (a -> b -> c -> d) -> c -> a -> b -> d
flip34' = flip.(flip.)

flip35' :: (a -> b -> c -> d) -> c -> b -> a -> d
flip35' = flip.((flip.).flip)