Интерактивные Brainfuck-интерпретатор на Haskell


На прошлой неделе я начал изучать Хаскель, и поскольку у меня есть некоторый опыт с помощью Brainfuck уже, я решил, что это будет отличная идея, чтобы осуществлять интерактивный Brainfuck-интерпретатор на Haskell. Я сначала списка код, а затем добавить некоторые замечания по ней.

Главная.УГ

module Main where

import Lib
import System.Environment

main :: IO ()
main = do
    args <- getArgs
    case args of
        [program]       -> interpret' program
        ["-f", file]    -> do
            contents <- readFile file
            interpret' contents
        _               -> putStrLn "Usage: brainfuck-interpreter-exe <program> or brainfuck-interpret-exe -f <file>"

interpret' :: String -> IO ()
interpret' program = do
    memory <- interpret program
    putChar '\n'
    putStrLn ("Memory: " ++ show memory)

Либ.УГ

module Lib
    ( interpret
    ) where

import Data.Char
import Data.Maybe
import System.IO

data BFInstruction = MemoryRight | MemoryLeft | Increment | Decrement | Output | Input | LoopBegin | LoopEnd | Stop deriving (Enum, Eq, Show)
data BFProgram = BFProgram [BFInstruction] BFInstruction [BFInstruction] deriving Show

newtype BFMemoryCell = BFMemoryCell Int deriving Show
data BFMemory = BFMemory [BFMemoryCell] BFMemoryCell [BFMemoryCell] deriving Show

startProgram :: [BFInstruction] -> BFProgram
startProgram instructions = BFProgram [] (head instructions) (tail instructions ++ [Stop])

advance :: BFProgram -> BFProgram
advance (BFProgram past current next) = BFProgram (past ++ [current]) (head next) (tail next)

decrease :: BFProgram -> BFProgram
decrease (BFProgram past current next) = BFProgram (init past) (last past) (current:next)

jumpAfterMatchingLoopEnd :: BFProgram -> BFProgram
jumpAfterMatchingLoopEnd program = jumpAfterMatchingLoopEnd' 0 (advance program)

jumpAfterMatchingLoopEnd' :: Int -> BFProgram -> BFProgram
jumpAfterMatchingLoopEnd' 0 program@(BFProgram _ LoopEnd _) = advance program
jumpAfterMatchingLoopEnd' nesting program@(BFProgram _ instruction _) = case instruction of
    LoopEnd     -> jumpAfterMatchingLoopEnd' (nesting - 1) (advance program)
    LoopBegin   -> jumpAfterMatchingLoopEnd' (nesting + 1) (advance program)
    _           -> jumpAfterMatchingLoopEnd' nesting (advance program)

jumpToMatchingLoopBegin :: BFProgram -> BFProgram
jumpToMatchingLoopBegin program = jumpToMatchingLoopBegin' 0 (decrease program)

jumpToMatchingLoopBegin' :: Int -> BFProgram -> BFProgram
jumpToMatchingLoopBegin' 0 program@(BFProgram _ LoopBegin _) = program
jumpToMatchingLoopBegin' nesting program@(BFProgram _ instruction _) = case instruction of
    LoopBegin   -> jumpToMatchingLoopBegin' (nesting - 1) (decrease program)
    LoopEnd     -> jumpToMatchingLoopBegin' (nesting + 1) (decrease program)
    _           -> jumpToMatchingLoopBegin' nesting (decrease program)

makeCell :: Int -> BFMemoryCell
makeCell = BFMemoryCell . wrap

incrementCell :: BFMemoryCell -> BFMemoryCell
incrementCell = makeCell . (+1) . getCell

decrementCell :: BFMemoryCell -> BFMemoryCell
decrementCell = makeCell . subtract 1 . getCell

getCell :: BFMemoryCell -> Int
getCell (BFMemoryCell value) = value

wrap :: Int -> Int
wrap input = mod input 256

moveMemoryRight :: BFMemory -> BFMemory
moveMemoryRight (BFMemory previous current []) = BFMemory (previous ++ [current]) (makeCell 0) []
moveMemoryRight (BFMemory previous current next) = BFMemory (previous ++ [current]) (head next) (tail next)

moveMemoryLeft :: BFMemory -> BFMemory
moveMemoryLeft (BFMemory [] current next) = BFMemory [] (makeCell 0) (current:next)
moveMemoryLeft (BFMemory previous current next) = BFMemory (init previous) (last previous) (current:next)

onCurrentCell :: (BFMemoryCell -> BFMemoryCell) -> BFMemory -> BFMemory
onCurrentCell func (BFMemory previous current next) = BFMemory previous (func current) next

setCurrentCell :: BFMemoryCell -> BFMemory -> BFMemory
setCurrentCell cell (BFMemory previous _ next) = BFMemory previous cell next

toInstructions :: String -> [BFInstruction]
toInstructions = mapMaybe toInstruction

toInstruction :: Char -> Maybe BFInstruction
toInstruction instruction = case instruction of
    '>' -> Just MemoryRight
    '<' -> Just MemoryLeft
    '+' -> Just Increment
    '-' -> Just Decrement
    '.' -> Just Output
    ',' -> Just Input
    '[' -> Just LoopBegin
    ']' -> Just LoopEnd
    _   -> Nothing

interpret :: String -> IO BFMemory
interpret program = step (startProgram $ toInstructions program) (BFMemory [] (makeCell 0) [])

step :: BFProgram -> BFMemory -> IO BFMemory
step (BFProgram _ Stop []) memory = return memory
step program@(BFProgram _ instruction _) memory@(BFMemory _ currentMemory _) = case instruction of
    MemoryRight -> step (advance program) (moveMemoryRight memory)
    MemoryLeft  -> step (advance program) (moveMemoryLeft memory)
    Increment   -> step (advance program) (onCurrentCell incrementCell memory)
    Decrement   -> step (advance program) (onCurrentCell decrementCell memory)
    Output      -> do
        putChar . chr . getCell $ currentMemory
        hFlush stdout
        step (advance program) memory
    Input       -> do
        newCurrentChar <- getChar
        let newCurrent = makeCell . ord $ newCurrentChar
        step (advance program) (setCurrentCell newCurrent memory)
    LoopBegin   -> case getCell currentMemory of
        0   -> step (jumpAfterMatchingLoopEnd program) memory
        _   -> step (advance program) memory
    LoopEnd     -> case getCell currentMemory of
        0   -> step (advance program) memory
        _   -> step (jumpToMatchingLoopBegin program) memory

Примечания:

  • Я знаю, что я мог бы использовать абстрактный дерева на основе синтаксиса подход, я считаю, что на следующий Хаскелл Brainfuck-интерпретатор, которую я собираюсь написать.
  • Я очень не люблю искусственные Stop инструкция.
  • Я хочу избавиться от IO часть, но я написал это в предположении, что Хаскелл переводчик является интерактивной, поэтому чтение из стандартного входного потока-это не вариант в этом случае. Однако, я бы не прочь получить перенаправлены на использование какой-то входной поток в качестве входных данных, будучи подкреплены IOстандартных ввода, или что-нибудь еще.


251
15
задан 29 марта 2018 в 08:03 Источник Поделиться
Комментарии
2 ответа

Хорошая работа на работу! Я использовал строку разворот программу , чтобы проверить ваш переводчик и он работает хорошо. Однако, он также использует ~36МБ памяти, которых слишком много.

Лента идет одинаково в обоих направлениях быстро

Вперед, назад. Основные операции на ленту. Будь то видеомагнитофон, кассеты, или ЛТО-8, они все работают одинаково: доступа к следующей и предыдущей части ленты-быстрый доступ дополнительные детали медленно.

Ведь мы движемся ленты под головкой чтения/записи слева и справа:

a picture of a tape

Короткий взгляд на машины Тьюринга

Давайте ностальгировать на некоторое время. Машины Тьюринга были определены Алан Тьюринг в работе на "неограниченную емкость памяти, полученных в виде бесконечной ленты размечен на квадраты"1. Хотя Тьюринг не знал о памяти SDRAM, кэш процессора или аналогичные технологии высокой доступности на сегодняшний день, он сделал одно центральное предположение о памяти: она должна быть быстрой (читай \$\mathcal O(1) по\$), чтобы добраться до предыдущей и следующей ячейки памяти.

На Brainfuck машины менее формально описаны, но их память нам, как правило, описывается как массив, который выполняет одно и то же свойство: легко получить от текущей ячейки к следующей и предыдущей. Они—все-таки определены, как Тьюринга-подобные машины. На C-подобном языке, вы бы просто изменить индекс в памяти:

void advance(memory_state * mem) {
mem->ptr++;
}

void decrease(memory_state * mem) {
mem->ptr--;
}

char * access(memory_state * mem) {
return mem->ptr;
}

Короткий взгляд на неевклидовой\ \$\mathcal o(п^2)$ ленты

Почему же мы должны посмотреть на машины Тьюринга? Потому что ваша лента \$\mathcal o(п)\$:

moveMemoryRight :: BFMemory -> BFMemory
moveMemoryRight (BFMemory previous current []) = BFMemory (previous ++ [current]) (makeCell 0) []
moveMemoryRight (BFMemory previous current next) = BFMemory (previous ++ [current]) (head next) (tail next)

Добавления в список list ++ [element] это \$\mathcal o(п)\$. Это не столько проблема, так как лень-то спасет нас, если мы потребляем после этого списка. Однако, это действительно становится плохо, как только мы используем moveMemoryRight или decrease несколько раз:

((list ++ [element]) ++ [element2]) ++ [element3]

Добавить против минусы

Мы только что построенный алгоритм с квадратным сложность. Еще хуже, лень и обмена Хаскелл не может помочь нам в этой точке. Когда мы

list  = "12345"
alist = 'a' : list
blist = 'b' : list

тогда alist только состоит из символа 'a' и указатель на list. Но то же самое касается blist! Хотя мы использовали list три раза, мы только используем его памяти один раз. Поскольку каждое значение в Haskell является неизменным, нам не нужно копировать list. Это здорово! Но она не держит на следующие:

list  = "12345"
lista = list ++ "a"
listb = list ++ "b"

Мы не можем просто обновить list'ы последний указатель, чтобы указать на "a" или "b". Мы должны создать новый список. Оуч.

Списки Хаскелла, как стеки. Легко что-то навязать сверху, но если вы попытаетесь столкнуть значение до дна, он собирается взять некоторую работу.

Стеки могут построить ленту

Представьте себе кучу тарелки, аккуратно сложены, и справа, и один перед тобой тарелку. Оставьте немного пространства слева. Теперь, чтобы перейти к следующему плиту, вы просто положить ваши нынешние плиты (тот что перед тобой) на верхней части левого стека, а затем получить один на правой стопки. А чтобы получить предыдущее плиту, вы просто сделать обратное: вы поставить тарелку на правой стопки, а затем взять верх левой стопки и положить ее перед вами.

Вот и вся хитрость.

Построении лучшего лента

К счастью, вы никогда не используете BFProgram или BFMemory через своих конструкторов, так что нам нужно всего лишь настроить некоторые функции. Но почему мы должны приспособить их для начала?

Мы вскоре вырваться из ленты обсуждения вам в другую тему. Профайлинг.

Профилирование может показать пространство и утечек времени

Давайте профиля текущим кодом. Мы используем Unihedron обратным программу, как проверить и следующим образом:

Hello world,how are you today?,Well,this seems to work.
Newlines are completely ignored, though. But that was
the intend of the original program, right? ^@

В ^@ трейлинг \0. Это необходимо для того, чтобы выйти из программы, но как-то трудно на вход в Windows. Независимо от того, теперь мы можем профилировать код. Если вы используете stackтогда вы должны использовать

stack build --profile
stack --RTS exec --profile skiwi-bf-exe -- +RTS -s -p -RTS -f unihedron.bf < input.txt

Первый --RTS говорит stack'ы выполнения не интерпретировать любые варианты выполнения, в +RTS -s -p говорит ваш выполнения для печати -statistics и -p № профиля программы.

Приведенные статистические данные будут выглядеть так (без stdout из вашей программы):


1,877,933,288 байтов, выделенных в куче
288,094,168 байтов, скопированных во время GC
20,472,904 байт максимальный ординатуре (27 образца(s))
519,096 байт максимальный помои
50 МБ общий объем памяти будет использоваться (0 МБ, потерянных из-за фрагментации)

Время тот (прошедшее) авг пауза, максимальная пауза
Поколения 0 кольс 1781, 0 номинальная 0.172 сек 0.205 сек 0.0001 с 0.0177 сек
Быт 1 27 кольс, 0 пар 0.000 0.002 0.0001 0.0003 ы ы ы ы

Задачи: 3 (1 предел, 2 пика работников (Итого 2), используя -Н1)

Спаркс: 0 (0 преобразуется, 0 переполнены, 0 дада, 0 ГХ б, 0 выдохлась)

ИНИТ время с 0.000 ( 0.000 сек прошло)
Мут времени 0.422 сек ( 0.391 сек прошло)
ГК время 0.172 сек ( 0.207 сек прошло)
РП время с 0.000 ( 0.000 сек прошло)
Проф время с 0.000 ( 0.000 сек прошло)
Время выхода 0.000 сек ( 0,001 с прошедшее)
Общее время 0.594 сек ( 0.599 сек прошло)

Курс к alloc 4,451,397,423 байт на Мут второй

Производительность 71.1% от общего пользователей, 65.4% от общего затраченного

Кроме того, вы найдете здесь .prof файл в текущей рабочей директории:

 30 марта Пт 09:30 2018 Время и профилирования выделения отчета (заключительный)

skiwi-bf-exe.EXE +РТС -П -С-П -РЦ -Ф reverse.bf.txt

общее время = 0.08 сек (80 тиков @ 1000 долларов, 1 Процессор)
общий запас = 1,194,261,592 байт (за исключением профилирования накладные расходы)

Стоимость модуля-центр ГРЦ %время %запас

moveMemoryLeft Либ в src\Либ.УГ:(64,1)-(65,105) 41.2 16.1
снижение Либ в src\Либ.УГ:22:1-89 21.2 31.8
заранее Либ в src\Либ.УГ:19:1-93 15.0 31.8
moveMemoryRight Либ в src\Либ.УГ:(60,1)-(61,107) 8.8 16.0
шаг Либ в src\Либ.УГ:(92,1)-(111,60) 7.5 1.9
decrementCell Либ в src\Либ.УГ:51:1-47 2.5 0.2
ОСНОВНОЕ 1.2 0.0
jumpToMatchingLoopBegin' Либ в src\Либ.УГ:(38,1)-(42,70) 1.2 1.7
onCurrentCell Либ в src\Либ.УГ:68:1-91 1.2 0.0

Как видите, все ваши функции обработки ленты, которая занимает большую часть времени и распределения. Профиль включает в себя больше информации, как функция иерархии вызовов, индивидуальные и накопленное время и распределение, а также вызовы функций. Например, step вызывается 262993 раз и использует 1,9% общего объема выделяемой памяти как отдельные функции.

Лента по-прежнему идет в обоих направлениях одинаково быстро

Теперь вы, наверное, знаете, что я хочу показать на ленте, дали табличку выше стеки пример. Его ум mindbogglingly простой:
Мы просто нажимаем (лучше: минусы) наши текущие значения на вершине past или previous если мы хотим пойти направо или заранее, и мы просто поп (лучше: uncons) от past или previous если мы хотим идти влево или уменьшаться.

moveMemoryRight :: BFMemory -> BFMemory
moveMemoryRight (BFMemory previous current []) = BFMemory (current : previous) (makeCell 0) []
moveMemoryRight (BFMemory previous current next) = BFMemory (current : previous) (head next) (tail next)

moveMemoryLeft :: BFMemory -> BFMemory
moveMemoryLeft (BFMemory [] current next) = BFMemory [] (makeCell 0) (current:next)
moveMemoryLeft (BFMemory previous current next) = BFMemory (tail previous) (head previous) (current:next)

advance :: BFProgram -> BFProgram
advance (BFProgram past current next) = BFProgram (current : past) (head next) (tail next)

decrease :: BFProgram -> BFProgram
decrease (BFProgram past current next) = BFProgram (tail past) (head past) (current:next)

Обратите внимание на симметрию между decrease и advance. Уверен, past теперь в обратном порядке, но это не важно, если мы печатаем программу. Мы можем просто reverse список, если мы хотим:

instructions :: BFProgram -> [BFInstruction]
instructions (BFProgram l v r) = reverse l ++ [v] ++ r

Это использование ++ хорошо, кстати, т. к. это приведет к reverse l ++ ([v] ++ r). reverse l только посмотрел сразу.

"Это нормально и все, но что я получил?" спросите вы. Ну, вот статистику и профиль:

 91,312,368 байтов, выделенных в куче 
3,183,024 байтов, скопированных во время GC
125,704 байт максимальный ординатура (2 образца(s))
46,120 байт максимальный помои
3 МБ общей памяти (0 МБ, потерянных из-за фрагментации)

Время тот (прошедшее) авг пауза, максимальная пауза
Поколения 0 86 кольс, 0 номинальная 0.016 0.003 0.0003 0.0000 ы ы ы ы
Поколения 1 2 моды, 0 номинальная 0.000 0.000 0.0000 0.0000 ы ы ы ы

Задачи: 3 (1 предел, 2 пика работников (Итого 2), используя -Н1)

Спаркс: 0 (0 преобразуется, 0 переполнены, 0 дада, 0 ГХ б, 0 выдохлась)

Время инициализации 0.000 сек ( 0,001 с прошедшее)
Мут времени 0.047 сек ( 0.055 сек прошло)
ГК время 0.016 сек ( 0.003 сек прошло)
РП время с 0.000 ( 0.000 сек прошло)
Проф время с 0.000 ( 0.000 сек прошло)
Время выход с 0.000 ( 0.000 сек прошло)
Общее время 0.062 сек ( 0.059 сек прошло)

Курс к alloc 1,947,997,184 байт на Мут второй

Производительность 75,0% от общего пользователей, 93,3% от общего затраченного

К сведению, всего 3 МБ использование против 50МБ.

 30 пт Мар 10:01 2018 Время и профилирования выделения отчета (заключительный)

skiwi-bf-exe.EXE +РТС -П -С-П -РЦ -Ф reverse.bf.txt

общее время = 0.00 сек (3 тика @ процессора 1000 долларов, 1)
общий запас = 57,235,776 байт (за исключением профилирования накладные расходы)

Стоимость модуля-центр ГРЦ %время %запас

шаг Либ в src\Либ.УГ:(92,1)-(111,60) 66.7 40.3
заранее Либ в src\Либ.ГС:19:1-90 33.3 0.0
jumpToMatchingLoopBegin Либ в src\Либ.УГ:35:1-79 0.0 5.8
jumpToMatchingLoopBegin' Либ в src\Либ.УГ:(38,1)-(42,70) 0.0 35.6
moveMemoryLeft Либ в src\Либ.УГ:(64,1)-(65,105) 0.0 4.3
moveMemoryRight Либ в src\Либ.УГ:(60,1)-(61,104) 0.0 4.3
decrementCell Либ в src\Либ.УГ:51:1-47 0.0 3.4
incrementCell Либ в src\Либ.ГС:48:1-41 0.0 3.0
обертывание Либ в src\Либ.ГС:57:1-26 0.0 2.5

Похоже jumpToMatchingLoopBegin' является хорошим кандидатом, чтобы искать дальнейшие оптимизации. advance разве это не медленно, кстати, это просто называют практически любую функцию, например, каждый цикл обучения в step звонки advance.

Поэтому ТЛ;ДР этого целый раздел есть: не добавлять в списки, тем более не рекурсивно!

Сделать неправильные государства, невозможно представить

На данный момент, мы можем написать ][ или [ и наша программа будет счастливо принять его и в конечном итоге с ошибкой. Ведь BFProgram это позволяет. Ничего в это типа мешает BFProgram [] LoopBegin []. Это печально, потому что типы могут помочь нам поймать этих ошибок, прежде чем они могут произойти.

А data BFFragment = Increment | Decrement | .... | Loop BFProgram без LoopBegin и LoopEnd может очень помочь, но вы уже знаете. Для остальных читателей я указываю в моем предыдущем комментарии, но вот тебе на закуску, что можно сделать с АСТ:

possible parser and printer combinations

Замечание Stop: это не тривиально, чтобы избавиться от Stop в этой точке. Я бы не заморачивался, если честно, поскольку вы будете использовать в следующем. Он может предоставить вам с запинками точки для отладки программ на Brainfuck, так как теперь вы можете произвольно остановить их.

Абстракции, абстракции, абстракции

Теперь, когда мы заново посмотреть на свой BFProgram и BFMemoryмы сразу увидим, что оба имеют одинаковую структуру и мы, по сути, дублирующего кода. Это легко исправить:

data Tape a = Tape [a] a [a] deriving (Eq, Show)

type BFMemory = Tape BFMemoryCell
type BFProgram = Tape BFInstruction

forwardTape :: a -> Tape a -> Tape a
forwardTape def (Tape previous current []) = Tape (current : previous) def []
forwardTape _ (Tape previous current next) = Tape (current : previous) (head next) (tail next)

rewindTape :: a -> Tape a -> Tape a
rewindTape def (Tape [] current next) = Tape [] def (current:next)
rewindTape _ (Tape previous current next) = Tape (tail previous) (head previous) (current:next)

advance, decrease :: BFProgram -> BFProgram
advance = forwardTape Stop
decrease = forwardTape Stop

moveMemoryRight, moveMemoryLeft :: BFMemory -> BFMemory
moveMemoryRight = forwardTape (makeCell 0)
moveMemoryLeft = rewindTape (makeCell 0)

В def расшифровывается как "по умолчанию" в этом случае и используется, если у нас не кончатся элементы на обоих концах.

Если вы будете следовать АСТ подход, вам не понадобится гибкость для вашего BFProgramхотя.

Привязки друзья2

Ваш step функция весьма обрастает step (advance program), который приносит мне использовать привязки. Это единственная функция, которая может хотя прибыли из одного,, так как все остальные функции либо pointfree или использовать сопоставление с образцом:

step :: BFProgram -> BFMemory -> IO BFMemory
step (BFProgram _ Stop []) memory = return memory
step program@(BFProgram _ instruction _) memory@(BFMemory _ currentMemory _) = case instruction of
MemoryRight -> continue (moveMemoryRight memory)
MemoryLeft -> continue (moveMemoryLeft memory)
Increment -> continue (onCurrentCell incrementCell memory)
Decrement -> continue (onCurrentCell decrementCell memory)
Output -> do
putChar . chr . getCell $ currentMemory
hFlush stdout
continue memory
Input -> do
newCurrentChar <- getChar
let newCurrent = makeCell . ord $ newCurrentChar
continue (setCurrentCell newCurrent memory)
LoopBegin -> case getCell currentMemory of
0 -> step (jumpAfterMatchingLoopEnd program) memory
_ -> continue memory
LoopEnd -> case getCell currentMemory of
0 -> continue memory
_ -> step (jumpToMatchingLoopBegin program) memory
where
continue = step (advance program)

Немного легче читать, но это ваш выбор.

Используйте сравнение с образцом, если это возможно

В последний раз, давайте вернемся к нашей Tape. Наш forwardTape и rewindTape где производная по вашему moveMemoryRight и *Left и поэтому использовать tail и head. Однако, это может привести к ошибкам. Конечно, мы знаем, что next разве есть голова и хвост, так как мы справились с пустого списка, но что, если мы случайно поменять местами строки?

forwardTape :: a -> Tape a -> Tape a
forwardTape _ (Tape previous current next) = Tape (current : previous) (head next) (tail next)
forwardTape def (Tape previous current []) = Tape (current : previous) def []

Это ошибка, если next пуст. Так давайте вместо того, чтобы использовать сопоставление с образцом:

forwardTape :: a -> Tape a -> Tape a
forwardTape _ (Tape ls v (r:rs)) = Tape (v:ls) r rs
forwardTape d (Tape ls v []) = Tape (v:ls) d []

rewindTape :: a -> Tape a -> Tape a
rewindTape _ (Tape (l:ls) v rs) = Tape ls l (v:rs)
rewindTape d (Tape [] v rs) = Tape [] d (v:rs)

Это также использует более общую схему именования в Haskell. ls это левый список, первый элемент lаналогично для r и rs на правом список.

Избавление от IO

Теперь, когда мы зашли так далеко, мы имеем правильную ленту, локальной привязки и шаблоны для безопасности. Теперь мы можем решить ваши беспокоило


Я хочу избавиться от IO часть, но я написал это в предположении, что Хаскелл переводчик является интерактивной, поэтому чтение из стандартного входного потока-это не вариант в этом случае. Однако, я бы не прочь получить перенаправлены на использование какой-то входной поток в качестве входных данных, будучи подкреплены IOстандартных ввода, или что-нибудь еще.

Ну, это не так сложно, если честно. Все, что вам нужно сделать, чтобы избавиться от тех функций, которые используют IO, верно? Так что давайте решать step в последний раз:

stepM :: Monad m => m Char -> (Char -> m ()) -> BFProgram -> BFMemory -> m BFMemory
stepM get put = go
where
go program@(Tape _ instruction _) memory@(Tape _ currentMemory _) = case instruction of
Stop -> return memory
MemoryRight -> continue (moveMemoryRight memory)
MemoryLeft -> continue (moveMemoryLeft memory)
Increment -> continue (onCurrentCell incrementCell memory)
Decrement -> continue (onCurrentCell decrementCell memory)
Output -> do
put . chr . getCell $ currentMemory
continue memory
Input -> do
newCurrentChar <- get
let newCurrent = makeCell . ord $ newCurrentChar
continue (setCurrentCell newCurrent memory)
LoopBegin -> case getCell currentMemory of
0 -> go (jumpAfterMatchingLoopEnd program) memory
_ -> continue memory
LoopEnd -> case getCell currentMemory of
0 -> continue memory
_ -> go (jumpToMatchingLoopBegin program) memory
where
continue = go (advance program)

stepIO :: BFProgram -> BFMemory -> IO BFMemory
stepIO = stepM getChar (\c -> putChar c >> hFlush stdout)

Ну, это, конечно, удален IO от stepM, верно? Все что нам нужно это сейчас право Monad экземпляр. Мы могли бы использовать State с (String, String) или StateT с Writer. Однако это как (средний, не легкий!) упражнения.

Кстати, вместо hFlush stdoutвы можете также отключить буферизацию в main с hSetBuffering stdout hSetBuffering.

Альтернативой является создание на выходе и потреблять входной, как мы идем вместе:

step :: BFProgram -> BFMemory -> String -> String
step program@(Tape _ instruction _) memory@(Tape _ currentMemory _) input = case instruction of
Stop -> ""
MemoryRight -> continue (moveMemoryRight memory) input
MemoryLeft -> continue (moveMemoryLeft memory) input
Increment -> continue (onCurrentCell incrementCell memory) input
Decrement -> continue (onCurrentCell decrementCell memory) input
Output -> chr (getCell currentMemory) : continue memory input
Input -> continue (setCurrentCell (makeCell . ord $ i) memory) is
LoopBegin -> case getCell currentMemory of
0 -> step (jumpAfterMatchingLoopEnd program) memory input
_ -> continue memory input
LoopEnd -> case getCell currentMemory of
0 -> continue memory input
_ -> step (jumpToMatchingLoopBegin program) memory input
where
continue = step (advance program)
(i:is) = input

Это, конечно, ошибкой, если мы пытаемся использовать Input при отсутствии входного влево, но это также верно и для текущей реализации, так что я бы не беспокоиться слишком много об этом.

Обратите внимание, что все эти continue линии выглядят почти одинаково? Помните привязки друзья? Это еще одно упражнение, хотя это проще как обычай монадой один.


1: А. М. Тьюринга (1948). "Умными машинами (рукопись)". В Архиве Тьюринга. С. 3.
2: как рыбы.

15
ответ дан 30 марта 2018 в 08:03 Источник Поделиться

Рекурсия может отслеживать скобках вместо номера.

jumpAfterMatchingLoopEnd :: BFProgram -> BFProgram
jumpAfterMatchingLoopEnd program@(BFProgram _ instruction _) = (case instruction of
LoopEnd -> id
LoopBegin -> jumpAfterMatchingLoopEnd . jumpAfterMatchingLoopEnd
_ -> jumpAfterMatchingLoopEnd
) advance program

jumpToMatchingLoopBegin :: BFProgram -> BFProgram
jumpToMatchingLoopBegin program@(BFProgram _ LoopBegin _) = program
jumpToMatchingLoopBegin program@(BFProgram _ instruction _) = (case instruction of
LoopBegin -> id
LoopEnd -> jumpToMatchingLoopBegin . jumpToMatchingLoopBegin
_ -> jumpToMatchingLoopBegin
) decrease program

interact захватывает ваше использование IO в простой интерфейс, кроме вас нужен способ, чтобы получить BFMemoryТак давайте настроить его.

interact' :: (String -> (a, String)) -> IO a
interact' f = do
sin <- getContents
let (a, sout) = f sin
sequence_ [putChar c >> hFlush stdout | c <- sout]
return a

interpret :: String -> IO BFMemory
interpret program = interact' $ step (startProgram $ toInstructions program) (BFMemory [] (makeCell 0) [])

step :: BFProgram -> BFMemory -> String -> (BFMemory, String)
step (BFProgram _ Stop []) memory input = (memory, [])
step program@(BFProgram _ instruction _) memory@(BFMemory _ currentMemory _) input = let
memorize f = step (advance program) (f memory) input
in case instruction of
MemoryRight -> memorize moveMemoryRight
MemoryLeft -> memorize moveMemoryLeft
Increment -> memorize $ onCurrentCell incrementCell
Decrement -> memorize $ onCurrentCell decrementCell
Output -> (currentMemory:) <$> memorize id
Input -> let
newCurrentChar : rest = input
newCurrent = makeCell $ ord newCurrentChar
in step (advance program) (setCurrentCell newCurrent memory) rest
LoopBegin -> case getCell currentMemory of
0 -> step (jumpAfterMatchingLoopEnd program) memory input
_ -> memorize id
LoopEnd -> case getCell currentMemory of
0 -> memorize id
_ -> step (jumpToMatchingLoopBegin program) memory input

3
ответ дан 30 марта 2018 в 10:03 Источник Поделиться