Haskell
ネタ
brainfuck

[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 が書きたくなったときはご活用ください。