takatoh's blog – Learning programming languages.
週をまたいでしまった。解答例もでてるけど。
問題３。これも内包表記で。
boxing :: [[a]] -> [[a]]
boxing m = [[m!!x!!y| x <- [0..l1], y <- [0..l1], x`div`l2 == i, y`div`l2 == j] | i <- [0..l3], j <- [0..l3]]
where
l1 = length m - 1
l2 = (floor . sqrt . fromIntegral . length) m
l3 = l2 -1
行列のサイズから n を求めるとこで型が合わずにはまった（sqrt は (Floating a) => a -> a，必要なのは Int）。結局 floor を使った。
問題１。
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 をやってみよう，と思ったらこんなのを見つけた。
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)