Haskell Turing machine with datatypes.hs

module TuringMachine where

-- Tape ------------------------------------------------------------------------

-- constructor
tape symbols = Tapes EOT (load_tape symbols) R

load_tape [] = EOT
load_tape (symbol:symbols) =
    (Symbol (Char symbol)) (load_tape symbols)


data Symbol a = Char a | Blank
        deriving (Show, Eq)

data Tape a = Symbol a (Tape a) | EOT
        deriving (Show, Eq)

data Direction = L | R | Accept | Halt
        deriving (Show, Eq)

data WholeTape a = Tapes (Tape a) (Tape a) Direction
        deriving (Show, Eq)


-- read, write

read_tape (Tapes a (Symbol read (b)) d) = read
read_tape (Tapes a (EOT) d) = Blank


move_tape n tape
    | n == 0    = tape
    | n >  0    = move_tape (n-1) (next tape)

next (Tapes a (Symbol move (b)) d) =
         Tapes ((Symbol move) (a)) b d


write (Tapes a (Symbol move (b)) d) write direction
      | direction == d = Tapes ((Symbol write) (a)) b d
      | otherwise      = flip_tape (Tapes a (Symbol write (b)) d)

write (Tapes a (EOT) d) Blank direction
      | direction == d = error "Cannot go any further to blank tape"
      | otherwise      = flip_tape (Tapes a (EOT) d)

flip_tape (Tapes a b L) = Tapes b a R
flip_tape (Tapes a b R) = Tapes b a L


-- tape extraction out of WholeTape

join_tapes (Tapes a b L) = join_tapes (Tapes b a R)
join_tapes (Tapes EOT b d) = b
join_tapes (Tapes (Symbol move (a)) b d) =
      join_tapes (Tapes a ((Symbol move) (b)) d)

extract_tape (Symbol (Char a) (b)) = a:extract_tape(b)
extract_tape (Symbol Blank (b)) = '_':extract_tape(b)
extract_tape (EOT) = ""

extract_tapes (t:tapes) = (extract_tape (join_tapes t)):extract_tapes(tapes)
extract_tapes [] = []


-- Machine ---------------------------------------------------------------------

data Instruction a = Move Int (Symbol a) (Symbol a) Direction Int
        deriving (Show, Eq)

r_continue (a, _, _, _) = a
r_state    (_, b, _, _) = b
r_tape     (_, _, c, _) = c
r_accept   (_, _, _, d) = d

machine head tape state [] = machine head tape state [tape]
machine head tape state progress = let r = (head state tape)
    in if (r_continue r)
       then machine head (r_tape r) (r_state r) ((r_tape r):progress)
       else ((r_accept r), reverse (extract_tapes progress))



-- Head ------------------------------------------------------------------------

instructed_head instructions state tape =
    tranform_tape tape (
        instruction_for instructions state (read_tape tape) tape
    )

tranform_tape tape (Move state read w direction state2)
    | direction == Halt   = (False, state2, (write tape w direction), False)
    | direction == Accept = (False, state2, (write tape w direction), True)
    | otherwise           = (True,  state2, (write tape w direction), True)


instruction_for [] s ch tape = (Move s ch ch Halt s)
--    error (
--        "No instruction for state: " ++ (show s) ++ " symbol " ++
--        (show ch) ++ " tape: " ++ (show (extract_tape (join_tapes tape)))
--    )

instruction_for ((Move state read write direction state2):instructions) s char tape =
    if state == s && read == char then (Move state read write direction state2)
    else instruction_for (instructions) s char tape



-- Examples --------------------------------------------------------------------

-- for each example do pp (progress example_name)

pp = putStr . concat . map (++"\n")
progress (a, b) = b

replace_a_with_b =
    machine (
        instructed_head [
            (Move 0 (Char 'a') (Char 'b') R 0),
            (Move 0 (Blank) (Blank) Accept 0)
          ]) (
            tape "aaaaa"
          ) 0 []

replace_a_with_b2 =
    machine (
        instructed_head [
            (Move 0 (Char 'a') (Char 'a') R 0),
            (Move 0 (Blank) (Blank) L 1),
            (Move 1 (Char 'a') (Char 'b') L 1),
            (Move 1 (Blank) (Blank) Accept 1)
          ]) (
            tape "aaaa"
          ) 0 []


-- 4 state BUSY BEAVER (http://mathworld.wolfram.com/BusyBeaver.html)
busy_beaver =
    machine (
        instructed_head [
            -- 0 / A
			(Move 0 (Char ' ') (Char '#') R 1),
			(Move 0 (Char '#') (Char '#') L 1),

			-- 1 / B
			(Move 1 (Char ' ') (Char '#') L 0),
			(Move 1 (Char '#') (Char ' ') L 2),

			-- 2 / C
			(Move 2 (Char ' ') (Char '#') L 3),
			(Move 2 (Char '#') (Char '#') L 3),

			-- 3 / D
			(Move 3 (Char ' ') (Char '#') R 3),
			(Move 3 (Char '#') (Char ' ') R 0)

          ]) (
            move_tape 25 (tape "                                            ")
          ) 0 []