-- simple, almost normalized Turing machine in Haskell
-- (C) Stephan Beyer, 20060724

-- M = (Q,Sigma,Gamma,Blank,q0,F,delta)
-- Q = 0,1,2,3,4,...
-- Sigma and Gamma is flexible ;)
-- Blank = ??
-- q0 = 0
-- F = 1
-- delta has to be specified.

blank = 2

-- aliases for states
q0 = 0
qa = 1
qu = 2
qf = 3
qh = 4

-- aliases for moves
l=0
r=1
n=2

-- aliases for the state functions
sq0 = [(0,q0,0,r),
       (1,q0,1,r),
       (2,qa,2,l)]
sqa = [(0,qf,1,l),
       (1,qu,0,l)]
squ = [(0,qf,1,l),
       (1,qu,0,l),
       (2,qh,1,n)]
sqf = [(0,qf,0,l),
       (1,qf,1,l),
       (2,qh,2,r)]

-- delta is a list. Each element is a list of all (a,q',a',D) tuples with
--   a = read from cell
--   q' = new state
--   a' = write to cell
--   D \in { 0, 1, 2}, 0 = left, 1= right, 2 = no move
-- That's it.
delta0 = [sq0,sqa,squ,sqf]

------------------------------------------------
-- now the Turing machine functions:

-- a helper:
nth []           _ = []
nth (first:rest) 0 = first
nth (first:rest) n = nth rest (n-1)
mth (first:rest) 0 = first
mth (first:rest) n = mth rest (n-1)

dummy = (-1,undefined,undefined)

-- move left
move (tape,pos) 0
 | pos == 0  = (blank:tape,0)
 | otherwise = (tape,pos-1)
-- move right
move (tape,pos) 1
 | pos==length tape-1 = (tape++[blank],pos+1)
 | otherwise            = (tape,pos+1)
-- don't move
move (tape,pos) 2 = (tape,pos)

-- read
--rcell (tape,pos) = tape !! pos 
-- doesn't work because of Haskell's crappy type inference and intolerance
rcell (tape,pos) = mth tape pos
-- write
wcell (tape,pos) new = (replace tape pos,pos)
  where replace (ft:rt) 0   = new:rt
        replace (ft:rt) pos = ft:(replace rt (pos-1))

matchfirst []               x = dummy
matchfirst ((y,a,b,c):rest) x
 | y == x    = (a,b,c)
 | otherwise = matchfirst rest x

getaction d state x = matchfirst (nth d state) x

tmtick delta input state 
  | q == -1   = input
  | otherwise = tmtick delta (move (wcell input a) d) q
 where (q,a,d) = (getaction delta state (rcell input))

tm delta x = tmtick delta x 0

start x = tm delta0 x

-- > start ([1,0,1,1],0)
-- ([2,1,1,0,0,2],1)
-- 1011 is incremented to 1100