[Haskell]BrainFuckモナド

Haskell 内で DSL として Brainfuck を書きたくなる機会があったためモナドとして実装しました。

BrainFuck.hs

BrainFuck.hs

{-# LANGUAGE GADTs #-}
module BrainFuck where
import Control.Monad.Operational
import Data.Word

data BFInst a where
    Forward :: BFInst ()
    Backward :: BFInst ()
    Incr :: BFInst ()
    Decr :: BFInst ()
    Print :: BFInst ()
    Get :: BFInst ()
    Repeat :: BrainFuck () -> BFInst ()

type BrainFuck a = Program BFInst a
data Memory = Memory {left :: [Word8], point :: Word8, right :: [Word8]}

forward_ :: Memory -> Memory
forward_ (Memory l p (r:rs)) = Memory (p:l) r rs

backward_ :: Memory -> Memory
backward_ (Memory (l:ls) p r) = Memory ls l (p:r)

incr_ :: Memory -> Memory
incr_ m = m{point = point m + 1}

decr_ :: Memory -> Memory
decr_ m = m{point = point m - 1}

runBF :: BrainFuck a -> Memory -> IO (a, Memory)
runBF m = case view m of
    Return a -> (\st -> return (a, st))
    Forward :>>= k -> \st -> runBF (k ()) $ forward_ st
    Backward :>>= k -> \st -> runBF (k ()) $ backward_ st
    Incr :>>= k -> \st -> runBF (k ()) $ incr_ st
    Decr :>>= k -> \st -> runBF (k ()) $ decr_ st
    Print :>>= k -> \st -> putWord8 (point st) >> runBF (k ()) st
    Get :>>= k -> \st -> do
        w <- getWord8
        runBF (k ()) st{point = w}
    Repeat bf :>>= k -> \st -> do
        let loop st' = do
                if point st' == 0 then
                    return st'
                else do
                    (_, st'') <- runBF bf st'
                    loop st''
        st' <- loop st
        runBF (k ()) st'

executeBF :: BrainFuck a -> IO (a, Memory)
executeBF bf = runBF bf emptyMemory

emptyMemory :: Memory
emptyMemory = Memory (repeat 0) 0 (repeat 0)

putWord8 :: Word8 -> IO ()
putWord8 = putChar . toEnum . fromEnum

getWord8 :: IO Word8
getWord8 = fmap (toEnum . fromEnum) getChar


fwd :: BrainFuck ()
fwd = singleton Forward

bwd :: BrainFuck ()
bwd = singleton Backward

inc :: BrainFuck ()
inc = singleton Incr

dec :: BrainFuck ()
dec = singleton Decr

prt :: BrainFuck ()
prt = singleton Print

get :: BrainFuck ()
get = singleton Get

rpt :: BrainFuck () -> BrainFuck ()
rpt bf = singleton $ Repeat bf

サンプルコード

Brainfuck	BrainFuckモナド
+	inc
-	dec
>	fwd
<	bwd
.	prt
,	get
[]	rpt

元のコード

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

Main.hs

module Main where

import BrainFuck

main :: IO ()
main = do
    executeBF hello
    return ()

hello :: BrainFuck ()
hello = do
    inc
    inc
    inc
    inc
    inc
    inc
    inc
    inc
    inc
    rpt $ do
        fwd
        inc
        inc
        inc
        inc
        inc
        inc
        inc
        inc
        fwd
        inc
        inc
        inc
        inc
        inc
        inc
        inc
        inc
        inc
        inc
        inc
        fwd
        inc
        inc
        inc
        inc
        inc
        bwd
        bwd
        bwd
        dec
    fwd
    prt
    fwd
    inc
    inc
    prt
    inc
    inc
    inc
    inc
    inc
    inc
    inc
    prt
    prt
    inc
    inc
    inc
    prt
    fwd
    dec
    prt
    dec
    dec
    dec
    dec
    dec
    dec
    dec
    dec
    dec
    dec
    dec
    dec
    prt
    bwd
    inc
    inc
    inc
    inc
    inc
    inc
    inc
    inc
    prt
    dec
    dec
    dec
    dec
    dec
    dec
    dec
    dec
    prt
    inc
    inc
    inc
    prt
    dec
    dec
    dec
    dec
    dec
    dec
    prt
    dec
    dec
    dec
    dec
    dec
    dec
    dec
    dec
    prt
    fwd
    inc
    prt

出力

Hello, world!

やはり、元のコードに比べてインデントのおかげで内容が見やすくなっていますね。

Brainfuck でありながら Haskell の厳格な型チェックが得られるという点も非常に大きな魅力なのではないでしょうか。

皆様も Haskell 内で Brainfuck が書きたくなったときはご活用ください。