HaskellでBrainf*ck

このソースコード、気がつくとかくれんぼしちゃうので
消してしまう前にここに貼っ付けとく。

・hw.txt

>+++++++++[<++++++++>-]<.>+++++++[<++++>-]<+.+++++++..+++.[-]>++++++++[<++
++>-]<.>+++++++++++[<+++++>-]<.>++++++++[<+++>-]<.+++.------.--------.[-]>
++++++++[<++++>-]<+.

・bf.hs

import Char

data Command = Inc | Dec | Nxt | Prv | Put | Get | Whl [Command] deriving (Show, Eq)

parse :: String -> [Command]
parse []       = []
parse (']':cs) = []

parse ('[':cs) = Whl (parse cs) : parse ( rmWhl cs 0 )
  where
    rmWhl :: String -> Int -> String
    rmWhl (c:cs) nst
      | c == '[' = rmWhl cs (nst+1)
      | c == ']' = if nst==0 then cs
                             else rmWhl cs (nst-1)
      | otherwise = rmWhl cs nst

parse (c:cs)
  | c == '+'  = Inc : parse cs
  | c == '-'  = Dec : parse cs
  | c == '>'  = Nxt : parse cs
  | c == '<'  = Prv : parse cs
  | c == '.'  = Put : parse cs
  | c == ','  = Get : parse cs
  | otherwise =       parse cs

type Record = ( [Int], Int )
type State  = ( [Command], Record, [Char], [Char] )

get :: Record -> Int
get (tape, pnt) = tape !! pnt

put :: Record -> Int -> Record
put (tape, pnt) num = ((take pnt tape) ++ [num] ++ (drop (pnt+1) tape), pnt)

inc, dec, nxt, prv :: Record -> Record
inc rec         = put rec ((get rec)+1)
dec rec         = put rec ((get rec)-1)
nxt (tape, pnt) = (tape, pnt+1)
prv (tape, pnt) = (tape, pnt-1)

alteration :: (Record -> Record) -> State -> State
alteration f ( (c:cs), rec, input, output ) = eval ( cs, f rec, input, output)

eval :: State -> State
eval state@(    [], _, _, _ ) = state
eval state@( Inc:_, _, _, _ ) = alteration inc state
eval state@( Dec:_, _, _, _ ) = alteration dec state
eval state@( Nxt:_, _, _, _ ) = alteration nxt state
eval state@( Prv:_, _, _, _ ) = alteration prv state
eval       ( Put:cs, rec, input, output ) = eval ( cs, rec, input, output ++ [chr (get rec)] )
eval       ( Get:cs, rec,  i:is, output ) = eval ( cs, put rec (ord i), is, output )
eval state@( Whl cmds:cs, _, _, _) = evalCs $ pntChk $ evalCmds state
  where
    evalCs   ( _, w_rec, w_input, w_output) = eval (  cs, w_rec, w_input, w_output)  
    evalCmds ( _, w_rec, w_input, w_output) = eval (cmds, w_rec, w_input, w_output)
    
    pntChk w_state@( _, w_rec, _, _ ) = if (get w_rec) == 0
                                          then w_state
                                          else pntChk $ evalCmds w_state

brainfuck :: String -> String -> String
brainfuck source input = getOutput $ eval ( (parse source), ([0,0..], 0), input, "" )
  where
    getOutput ( _, _, _, output ) = output

main = do file <- readFile "hw.txt"
          print $ brainfuck file ""

コンパイル＆実行。
$ghc bf.hs -o bf
$./bf => "Hello World!"

やったね！