Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 136 lines (113 sloc) 3.216 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Language.Brainfuck
    ( runProgram
    , Brainfunk (..)
    )
    where

import Data.Word
import Control.Monad
import Control.Monad.State
import Data.Char

import ListZipper
    
type Buffer = ListZipper Word8
type Program = ListZipper Char
type BFContext = (Buffer, Program)

newtype Brainfunk a =
    Brainfunk {
        unFunk :: StateT BFContext IO a
    } deriving
        ( Monad, Functor, MonadIO
        , MonadState BFContext )

runProgram :: BFContext -> IO BFContext
runProgram = runBrainfunk runCode

runBrainfunk :: Brainfunk a -> BFContext -> IO BFContext
runBrainfunk funk =
    execStateT (unFunk funk)

runCode :: Brainfunk ()
runCode = do
    i <- getInstruction
    case i of
      (Just i') -> parseInstruction i' >> nextInstruction >> runCode
      _ -> return ()

parseInstruction :: Char -> Brainfunk ()
parseInstruction '>' = nextByte
parseInstruction '<' = prevByte
parseInstruction '+' = incByte
parseInstruction '-' = decByte
parseInstruction '.' = outputByte
parseInstruction ',' = inputByte
parseInstruction '[' = do
    b <- getByte
    when (b == 0) skipLoop
parseInstruction ']' = do
    b <- getByte
    when (b /= 0) repeatLoop
parseInstruction _ = return ()

nextInstruction :: Brainfunk ()
nextInstruction = do
    (buf, prog) <- get
    case forward prog of
      (Just p) -> put (buf, p)
      _ -> fail "Attempt to get next instruction at end."

prevInstruction :: Brainfunk ()
prevInstruction = do
    (buf, prog) <- get
    case back prog of
      (Just p) -> put (buf, p)
      _ -> fail "Attempt to go back at beginning of instruction buffer."

getInstruction :: Brainfunk (Maybe Char)
getInstruction = do
    s <- get
    case s of
      (_, (_, [])) -> return Nothing
      (_, (_, p:_)) -> return $ Just p

repeatLoop :: Brainfunk ()
repeatLoop = do
    i <- getInstruction
    case i of
      (Just '[') -> return ()
      (Just _ ) -> prevInstruction >> repeatLoop
      Nothing -> fail "Unexpected error."

skipLoop :: Brainfunk ()
skipLoop = do
    i <- getInstruction
    case i of
      (Just ']') -> return ()
      (Just _ ) -> nextInstruction >> skipLoop
      Nothing -> fail "Unexpected error."

nextByte :: Brainfunk ()
nextByte = do
    (buf, prog) <- get
    case forward buf of
      (Just b) -> put (b, prog)
      _ -> fail "Attempt to get next byte at end of buffer."

prevByte :: Brainfunk ()
prevByte = do
    (buf, prog) <- get
    case back buf of
      (Just b) -> put (b, prog)
      _ -> fail "Attempt to go back at beginning of buffer."

getByte :: Brainfunk Word8
getByte = do
    g <- get
    case g of
      ((_, b:_), _) -> return b
      _ -> fail "Out of buffer space."

putByte :: Word8 -> Brainfunk ()
putByte b = do
    ((t, _:bs), p) <- get
    put ((t, b:bs), p)

incByte :: Brainfunk ()
incByte =
    getByte >>= putByte . succ

decByte :: Brainfunk ()
decByte =
    getByte >>= putByte . pred

outputByte :: Brainfunk ()
outputByte = do
    b <- getByte
    liftIO . putChar . chr . fromIntegral $ b

inputByte :: Brainfunk ()
inputByte = do
    c <- liftIO getChar
    putByte . fromIntegral . ord $ c
    
Something went wrong with that request. Please try again.