Brainfuck

gistfile1.hs

module Main where

import Char

type Tape = [Char]
type Machine = (Tape, Tape)
type Operation = Machine →  IO (Machine)
type Operations = [Operation]

raise =
  let step_size = 5 -- should be greater than 0
  in take step_size (repeat '\0')

nop :: Operation
nop machine =
  return machine

inc :: Operation
inc (lt, c : rt) =
  let c' = chr $ 1 + ord c
  in return (lt, c' : rt)

dec :: Operation
dec (lt, c : rt) =
  let c' = chr  $ ord c - 1
  in return (lt, c' : rt)

shr :: Operation
shr (lt, c:[]) =
  return (lt ⊕ [c], raise)
shr (lt, c : rt) =
  return (lt ⊕ [c], rt)

shl :: Operation
shl ([], rt) =
  return (raise, '\0' : rt)
shl (lt, rt) =
  let lt'' = reverse lt'
      c : lt' = reverse lt
  in return (lt'', c : rt)

out :: Operation
out (lt, c : rt) = do
  putChar c
  return (lt,  c : rt)

inp :: Operation
inp (lt, _ : rt) = do
  c ←  getChar
  return (lt, c : rt)

loop_gen :: Operations → Operation
loop_gen opts =
  loop
  where
    loop :: Operation
    loop machine = do
      new_machine ← loop_exec opts machine
      return new_machine
      where
        loop_exec :: Operations → Machine → IO Machine
        loop_exec [] (lt, ('\0':rt)) = return (lt, ('\0':rt))
        loop_exec [] machine' = loop_exec opts machine'
        loop_exec ops' machine' = do
          machine'' ← execute_bf ops' machine'
          loop_exec [] machine''

compile_bf :: String →  Operations
compile_bf code =
  let (operators, []) = parse_bf code []
  in operators

parse_bf :: String →  Operations →  (Operations, String)
parse_bf [] operations =
  (reverse operations, [])

parse_bf (']':cs) operators =
  (reverse operators, cs)

parse_bf ('[':cs) operators =
  let (loop_ops, rest_ops) = parse_bf cs []
  in parse_bf rest_ops ((loop_gen loop_ops):operators)

parse_bf (c:cs) operations =
  let operator = case c of
                  '+' →  inc
                  '-' →  dec
                  '<' →  shl
                  '>' →  shr
                  '.' →  out
                  ',' →  inp
                  _ →  nop
  in parse_bf cs (operator : operations)

execute_bf :: Operations →  Machine →  IO (Machine)
execute_bf [] machine = return machine

execute_bf (op:ops) machine = do
  machine' ←  op machine
  --debug_output_machine machine
  execute_bf ops machine'

debug_output_machine :: Machine →  IO ()
debug_output_machine (lt, rt) = do
  print (map (λx →  ord x) lt)
  print (map (λx →  ord x) rt)
  putStrLn "---"


main :: IO ()
main =
  let codes = compile_bf ">+++++++++[<++++++++>-]<.>+++++++[<++++>-]<+.+++++++..+++.[-]>++++++++[<++++>-] <.>+++++++++++[<++++++++>-]<-.--------.+++.------.--------.[-]>++++++++[<++++>- ]<+.[-]++++++++++."
  in do 
    execute_bf codes (raise, raise)
    return ()