投稿者: takatoh

久しぶりに時間があいたので 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)

また間があいてしまった。たまには触らないと鈍る――ってほどなれてるわけでもないけど――ので，練習問題をやってみる。

「ふつうのHaskellプログラミング ふつうのプログラマのための関数型言語入門」，p.191 から。

標準入力から読み込んだ各行を幅60バイトに納まるように折り返すコマンド，
foldを書きなさい。単語境界やマルチバイト文字は考えなくて構いません。

問題は60バイトだけど30バイトでやってみた。

module Main (main) where

import System

fold :: Int -> String -> String
fold n cs = let (h, t) = splitAt n cs
            in if null t then h else h ++ "\n" ++ fold n t

main :: IO ()
main = do cs <- getContents
          putStr $ unlines $ map (fold 30) $ lines cs

結果

>runghc fold.hs < fold.hs
module Main (main) where

import System


fold :: Int -> String -> Strin
g
fold n cs = let (h, t) = split
At n cs
            in  if null t  the
n h  else h ++ "\n" ++ fold n
t

main :: IO ()
main = do cs <- getContents
          putStr $ unlines $ m
ap (fold 30) $ lines cs

下のエントリの fold，「ふつケル」の解答例を見たら concatMap を使っていた。なるほど。

Prelude> :t concatMap
concatMap :: (a -> [b]) -> [a] -> [b]
Prelude> concatMap (replicate 3) "abc"
"aaabbbccc"

今日で最後だ。のこりの命令「[」と「]」を実装した。

「[」と「]」を実装するには命令の列を行ったり来たりできなきゃいけない。はじめに考えたのは BrainF_ck と同じように，命令のリストと現在位置を示すポインタを持ったデータ型を定義することだった。
けど，考え直して文字列のペアで代用することにした。これを次のように操作する。

• 初期状態では，１番目の文字列は空。全て２番目に入っている。
• １つ命令を実行するごとに，２番目の文字列から１番目の文字列へ１文字移動する。スキップするには必要な数だけ移動。
• ２番目の文字列が空になったらプログラム終了。
• ループで戻るときには，２番目から１番目へ文字を移動する。

で，実装はこのとおり。

type Program = ([Char], [Char])

progNew :: String -> Program
progNew str = ([], str)

progFetch :: Program -> [Char]
progFetch prog = snd prog

progShift :: Program -> Program
progShift (l, (r:rs)) = (l ++ [r], rs)

progUnshift :: Program -> Program
progUnshift (l, r) = (take ((length l) -1) l, (last l):r)

progSkip :: BrainF_ck -> Program -> Program
progSkip bf prog = if bfValue bf == 0 then skip prog else progShift prog
  where skip p = if (head $ progFetch next) == ']' then next else skip next
          where next = progShift p

progBack :: BrainF_ck -> Program -> Program
progBack bf prog = if bfValue bf == 0 then progShift prog else back prog
  where back p = if (head $ progFetch prev) == '[' then prev else back prev
          where prev = progUnshift p

でもって，プログラムを走らせる関数 bfRun を導入（前回までは foldM を使っていた）して，main も書き換えた。

bfRun :: BrainF_ck -> Program -> IO BrainF_ck
bfRun bf prog = run $ progFetch prog
  where run [] = return bf
        run (c:cs) | c == '[' = bfRun bf (progSkip bf prog)
                   | c == ']' = bfRun bf (progBack bf prog)
                   | otherwise = do next <- bfEvaluate bf c
bfRun next (progShift prog)

main :: IO BrainF_ck
main = do filename <- getArgs >>= return . head
          prog <- readFile filename >>= ((return . progNew) . concat) . lines
          bfRun bfInitial prog

さらに。いままで入出力を整数でやっていたけど，これを文字に変更する。まぁ文字<->整数（文字コード）の変換だけだけど。

import Data.Char

bfInput :: BrainF_ck -> IO BrainF_ck
bfInput bf = do let p = bfPointer bf
                let r = bfRegister bf
                putStr "\ninput? ";
                c <- getChar
                return $ BF p ((take p r) ++ [ord c] ++ (tail $ drop p r))

bfPrint :: BrainF_ck -> IO BrainF_ck
bfPrint bf = do putChar $ chr $ bfValue bf
                return bf

これでできあがりのはずだ。さっそく試してみよう。
実行するプログラムは当初の目標，HelloWorld。

>type hello.bf
++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<
+++++++++++++++.>.+++.------.--------.>+.>.
>runghc hbf.hs hello.bf
Hello World!

OK!!!!!!!!!!!!!!!!

いろいろと制限もあるけど，とにかく目標は達成。これ以上はまた気が向いたらってことで。
以下，全体を示しておく。

module Main where

import System
import Monad
import Data.Char

data BrainF_ck = BF { bfPointer :: Int, bfRegister :: [Int] } deriving (Show)

type Program = ([Char], [Char])

bfInitial :: BrainF_ck
bfInitial = BF { bfPointer = 0, bfRegister = [0,0,0,0,0,0,0,0,0,0] }

bfValue :: BrainF_ck -> Int
bfValue bf = (bfRegister bf) !! (bfPointer bf)

bfIncrement :: BrainF_ck -> BrainF_ck
bfIncrement (BF p v) = BF p ((take p v) ++ [(v !! p) + 1] ++ (tail $ drop p v))

bfDecrement :: BrainF_ck -> BrainF_ck
bfDecrement (BF p v) = BF p ((take p v) ++ [(v !! p) - 1] ++ (tail $ drop p v))

bfShift :: BrainF_ck -> BrainF_ck
bfShift (BF p v) = BF (p+1) v

bfUnshift :: BrainF_ck -> BrainF_ck
bfUnshift (BF p v) = BF (p-1) v

bfInput :: BrainF_ck -> IO BrainF_ck
bfInput bf = do let p = bfPointer bf
                let r = bfRegister bf
                putStr "\ninput? "
                c <- getChar
                return $ BF p ((take p r) ++ [ord c] ++ (tail $ drop p r))

bfPrint :: BrainF_ck -> IO BrainF_ck
bfPrint bf = do putChar $ chr $ bfValue bf
                return bf

bfEvaluate :: BrainF_ck -> Char -> IO BrainF_ck
bfEvaluate bf '+' = return $ bfIncrement bf
bfEvaluate bf '-' = return $ bfDecrement bf
bfEvaluate bf '>' = return $ bfShift bf
bfEvaluate bf '<' = return $ bfUnshift bf
bfEvaluate bf '.' = bfPrint bf
bfEvaluate bf ',' = bfInput bf

progNew :: String -> Program
progNew str = ([], str)

progFetch :: Program -> [Char]
progFetch prog = snd prog

progShift :: Program -> Program
progShift (l, (r:rs)) = (l ++ [r], rs)

progUnshift :: Program -> Program
progUnshift (l, r) = (take ((length l) -1) l, (last l):r)

progSkip :: BrainF_ck -> Program -> Program
progSkip bf prog = if bfValue bf == 0 then skip prog else progShift prog
  where skip p = if (head $ progFetch next) == ']' then next else skip next
          where next = progShift p

progBack :: BrainF_ck -> Program -> Program
progBack bf prog = if bfValue bf == 0 then progShift prog else back prog
  where back p = if (head $ progFetch prev) == '[' then prev else back prev
          where prev = progUnshift p

bfRun :: BrainF_ck -> Program -> IO BrainF_ck
bfRun bf prog = run $ progFetch prog
  where run [] = return bf
        run (c:cs) | c == '[' = bfRun bf (progSkip bf prog)
                   | c == ']' = bfRun bf (progBack bf prog)
                   | otherwise = do next <- bfEvaluate bf c
                                    bfRun next (progShift prog)

main :: IO BrainF_ck
main = do filename <- getArgs >>= return . head
          prog <- readFile filename >>= ((return . progNew) . concat) . lines
          bfRun bfInitial prog

入出力の命令「.」と「,」を実装した。

最初，よく考えもせずに出力する関数 bfPrint をこうした。

bfPrint bf = print $ bfValue bf

確かにこれでこの関数自体はちゃんと動く。つまり１文字出力される。

*Main> bfPrint $ bfIncrement bfInitial
Loading package haskell98-1.0 ... linking ... done.
1

けど，返り値が IO () なのであとが続かない。出力命令が来たらそこで終わり，では話しにならないよな。
ここでしばらく行き詰まってしまった。
次の命令の処理につなげるには BrainF_ck を返さないといけないけど，どうやったらいいのか。
一部の命令だけ IO モナドになってしまうのを，他の命令と型を合わせるにはどうしたらいいのか。

結局「入門Haskell―はじめて学ぶ関数型言語」のモナドの章を読み直して，何とかできたのがこれ。

• 命令をつなげるのには IO BrainF_ck をつかう。
• 値を返すには return をつかう。

bfEvaluate は１つの命令を評価するようにして，次々に処理するのは main に移した。モナドを扱うので foldM を使った。

bfInput :: BrainF_ck -> IO BrainF_ck
bfInput bf = do let p = bfPointer bf
                let r = bfRegister bf
                putStr "\ninput? "
                v <- getChar return $ BF p ((take p r) ++ [read [v]] ++ (tail $ drop p r))

bfPrint :: BrainF_ck -> IO BrainF_ck
bfPrint bf = do putStr $ show $ bfValue bf
                return bf

bfEvaluate :: BrainF_ck -> Char -> IO BrainF_ck
bfEvaluate bf c = case c of
                  '+' -> return $ bfIncrement bf
                  '-' -> return $ bfDecrement bf
                  '>' -> return $ bfShift bf
                  '<' -> return $ bfUnshift bf
                  '.' -> bfPrint bf
                  ',' -> bfInput bf

main :: IO ()
main = do args <- getArgs
          prog <- readFile $ head args
          result <- foldM bfEvaluate bfInitial prog
          print result

あ，foldM を使うには import Monad が必要。 さて，試してみよう。入力するプログラムはこれ。

 ++.>++.>++.<-.>>,.

結果。

>runghc hbf.hs sample.bf
2221
input? 7
7BF {bfPointer = 3, bfRegister = [2,1,2,7,0,0,0,0,0,0]}

一番最後に状態を出力してるから見にくいけどそれはおいといて。
input? のあとの 7 が入力。で，そのすぐあとに入力されたばかりの 7 を出力している。最後の状態を見てもちゃんと 7 が入力されている（左から４番目）。

というわけで，何とかできたけど入出力は難しい。これで良いのかなぁ。もっとスマートにいかないものか。

Wkikipediaの記事を読んだり，ダウンロードしたインタプリタをいじってるうちに，なんかちょっとできそうな気がしてきた。
目標は Hello world プログラムの実行だ。

まず，データを格納する配列（レジスタと呼ぶことにしよう）とポインタが必要だな。

data BrainF_ck = BF { bfPointer :: Int, bfRegister :: [Int] }

操作する命令をそれぞれ関数にする。こんな感じか。

命令	関数名
+	bfIncrement
-	bfDencrement
>	bfShift
<	bfUnshift
.	bfPrint
,	bfInput
[	bfGoto
]	bfBack

とりあえず簡単そうな「+」，「-」，「>」，「<」だけにしよう。
それから，BrainF_ck の初期値を設定する関数も要るな。レジスタがいくつ要るかわからないけど，10個あればいいか。

data BrainF_ck = BF { bfPointer :: Int, bfRegister :: [Int] } deriving (Show)

bfInitial :: BrainF_ck
bfInitial = BF { bfPointer = 0, bfRegister = [0,0,0,0,0,0,0,0,0,0] }

bfValue :: BrainF_ck -> Int
bfValue bf = (bfRegister bf) !! (bfPointer bf)

bfIncrement :: BrainF_ck -> BrainF_ck
bfIncrement (BF p v) = BF p ((take p v) ++ [(v !! p) + 1] ++ (tail $ drop p v))

bfDecrement :: BrainF_ck -> BrainF_ck
bfDecrement (BF p v) = BF p ((take p v) ++ [(v !! p) - 1] ++ (tail $ drop p v))

bfShift :: BrainF_ck -> BrainF_ck
bfShift (BF p v) = BF (p+1) v

bfUnshift :: BrainF_ck -> BrainF_ck
bfUnshift (BF p v) = BF (p-1) v

まずはここまででどうだ。

Prelude> :load hbf.hs
Compiling Main             ( hbf.hs, interpreted )
Ok, modules loaded: Main.
*Main> bfInitial
Loading package haskell98-1.0 ... linking ... done.
BF {bfPointer = 0, bfRegister = [0,0,0,0,0,0,0,0,0,0]}
*Main> bfIncrement $ bfInitial
BF {bfPointer = 0, bfRegister = [1,0,0,0,0,0,0,0,0,0]}
*Main> bfIncrement $ bfShift $ bfInitial
BF {bfPointer = 1, bfRegister = [0,1,0,0,0,0,0,0,0,0]}
*Main> bfUnshift $ bfIncrement $ bfShift $ bfInitial
BF {bfPointer = 0, bfRegister = [0,1,0,0,0,0,0,0,0,0]}

おお，なんだかうまくいってるみたい。

今のままじゃテストするもの面倒なので，外部のファイルからプログラムを読み込めるようにした。
といっても手抜きで，命令列を頭から一直線に実行して無くなったら終わり。で，最後の状態を表示する。今のところはジャンプしたりはできないんだからこれでいいさ。

module Main where

import System

(snip)

bfEvaluate :: BrainF_ck -> [Char] -> BrainF_ck
bfEvaluate = foldl eval
  where eval bf c = case c of
                    '+' -> bfIncrement bf
                    '-' -> bfDecrement bf
                    '>' -> bfShift bf
                    '<' -> bfUnshift bf

main :: IO ()
main = do args <- getArgs
          prog <- readFile $ head args
          print $ bfEvaluate bfInitial prog

サンプルのプログラムはこれ。

++>++>++<-

最初のレジスタを２回インクリメントして右にシフト，同じく２回インクリメントして右にシフト，また２回インクリメントしたら今度は左に１つシフト，１回デクリメントして終わり。 結局，レジスタの値が左から 2,1,2 になって，ポインタは 1 （左から２番目を指している）になる。やってみよう。

>type sample.bf
++>++>++<-
>runghc hbf.hs sample.bf
BF {bfPointer = 1, bfRegister = [2,1,2,0,0,0,0,0,0,0]}

OK。