西尾泰和のブログ

書いちゃった。

Brainf*ckは、テープを破壊的に書き換えまくったり、 特定のコマンドが来たときには入出力を行ったり、と Haskellで書きにくそうな問題だ。 基本的にWorldという「ポインタの位置」「テープ」「実行すべきコード」「スタック」 の4つがセットになった型のオブジェクトを iterateのようなもので何度も何度も呼ぶ設計にしていたのだけど、 IOをする段になって悩む。

結局(IO World)というIOモナドで包んだ世界にしてやって、 いままで単純にWorldを返していた部分はreturn Worldに置き換える必要があった。 入出力をする部分は、getCharやputStrのような入出力をする命令とreturn Worldをbindして やる。

入出力周りは理解するまでが大変だったけども、 書いてみると行数的にさほど手続き型言語より面倒かというとそうでもないような。

7行割いている下のコードはライブラリにありそう。デフォルト値付き連想配列。

data VPair = V {pos::Integer, val::Integer} deriving Show
type Tape = [VPair]

getHead [] = 0
getHead (x:xs) = val x
getV tape p = getHead $ filter ((p ==).pos) tape
setV tape p v = modV (\x -> byte v) tape p
modV f tape p = (V p (byte (f (getV tape p)))):(filter ((p /=).pos) tape)

---

=

ループの処理は、
　開きかっこが実行されたときに
　　ポインタの指す値が0だったら、
　　　閉じかっこの次までソースコードを捨てる
　　非0だったら
　　　「残りのソースコード」をスタックに積み、
　閉じかっこが実行されたときに
　　スタックの先頭のコードを戻す

cond_exec w@(World p t c s) =
  if getV t p == 0 then
    w{commands = skipCommands c}
  else
    w{stack = c:s, commands = tail c}

jump_back w@(World _ _ _ (s:ss)) =
  w{commands = s, stack = ss}

skipCommands (']':cs) = cs
skipCommands (_:cs) = skipCommands cs

読みやすい。

---

= ところで「仕様を記述するだけでプログラムになる」 とかいうけども、その仕様を決めるところが一番難しいんじゃないかと思う。 余談。

---

= 繰り返し実行する部分は、iterateMが存在しなかったのでfoldMのソースコードを見ながら実装。 1つめの処理に次の処理をbindして…とやっていく。Pythonの

w = newWorld
while True:
    w = step(w)
    if w.commands == "": break

に相当するコードが

iterateM f w =
  if (commands w == "") then
    return ()
  else
    f w >>= \nextW -> iterateM f nextW 

main = iterateM step newWorld

になる。

iterateMは終了条件をくくりだせば汎用の関数になるなぁ。 iterateM step ((== "").commands) newWorldの1行で済むようになる。

---

= 機械語にコンパイルできる言語で、静的な型チェックもあるのに、 これだけ楽に書けるというのは、確かにすごいことだとは思う。 でもプロトタイピングに役に立つかというと微妙。 プロトタイピングにはPythonの方が楽な気がするし(僕が慣れているというだけかも)、 仮にHaskellでプロトタイプを作ったとして、 それをCやJavaに移植するのはかなり面倒だろう。

KEMURIがPythonの半分の行数で書けて萌えたのだけど、 あれはIOがないから簡単に書けたのだ。

仕様がすでに明確に決まっていて(パズルとか)、 IOやユーザとのインタラクションがなければ(インタラクティブでないプログラムなら)楽。 というか、HaskellでGUIを作ったとしたら、メインループでモナドを使う必要があるから、 既存のGUIライブラリのほとんどは使えないわけだなぁ。

---

=

---

=

import Data.Char

data World = World {
  data_p::Integer, tape::Tape,
  commands::String, stack::[String]
} deriving Show

data VPair = V {pos::Integer, val::Integer} deriving Show
type Tape = [VPair]

test1 = "+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++."
test2 = "++++++++[>++++++++<-]>+."
test3 = "++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>."

newWorld = World 0 [] test3 []

getHead [] = 0
getHead (x:xs) = val x
getV tape p = getHead $ filter ((p ==).pos) tape
setV tape p v = modV (\x -> byte v) tape p
modV f tape p = (V p (byte (f (getV tape p)))):(filter ((p /=).pos) tape)

inc = (+ 1)
dec = (subtract 1)
byte n
  | n < 0 = n + 256
  | 255 < n = n - 256
  | otherwise = n

mod_data f w@(World p t _ _) = w{tape = modV f t p}
inc_data = mod_data inc
dec_data = mod_data dec

mod_ptr f w@(World p _ _ _) = w{data_p = f p}
inc_ptr = mod_ptr inc
dec_ptr = mod_ptr dec

cond_exec w@(World p t c s) =
  if getV t p == 0 then
    w{commands = skipCommands c}
  else
    w{stack = c:s, commands = tail c}

jump_back w@(World _ _ _ (s:ss)) =
  w{commands = s, stack = ss}

skipCommands (']':cs) = cs
skipCommands (_:cs) = skipCommands cs

step w@(World p t (c:cs) s) = case c of
  '+' -> dump (inc_data w){commands = cs}
  '-' -> dump (dec_data w){commands = cs}
  '>' -> dump (inc_ptr w){commands = cs}
  '<' -> dump (dec_ptr w){commands = cs}
  '[' -> dump (cond_exec w)
  ']' -> dump (jump_back w)
  ',' -> input_data w
  '.' -> print_data w

dump :: World -> IO World
dump w = return w
{-
dump w =
  do print w
     return w
-}


print_data :: World -> IO World
print_data w@(World p t cs _) =
  do putStr [chr $ fromInteger $ getV t p]
     dump w{commands = tail cs}

input_data :: World -> IO World
input_data w@(World p t cs _) =
  do c <- getChar
     dump w{tape = setV t p (toInteger (ord c)),
            commands = tail cs}

iterateM f w =
  if (commands w == "") then
    return ()
  else
    f w >>= \nextW -> iterateM f nextW 

main = iterateM step newWorld