01_turing_machine_in_haskell.hs

-- instruction
tm_i s c w m n a | a == "state" = s    
		 | a == "char"  = c
		 | a == "write" = w
		 | a == "move"  = m
		 | a == "next"  = n


-- TM instruction set, gives correct instruction if state and char given

tm_is (x:xs) s c tape = if (x "state") == s && (x "char") == c then x
                   else tm_is xs s c tape
tm_is [] s c tape = error ("State " ++ (show s) ++ " does not recognize char " ++ (show c)++" on tape: "++(show (clean_tape tape)))
				   


clean_tape (x:xs) = clean_tape2 xs []
clean_tape2 (x:xs) xy
	| xs == []  = reverse xy
	| otherwise = clean_tape2 xs (x:xy)

-- turing machine

tm instructions tape = tm2 instructions [(-1)] (tape ++ [(-1)]) 0 1

tm2 instructions head (t:tail) (-1) direction = clean_tape (head ++ [t] ++ tail)

tm2 instructions head (t:tail) state direction =
    let instruction = (instructions state t (head ++ [t] ++ tail))
	in if (instruction "move") == direction then (tm2 instructions (head ++ [(instruction "write")]) tail (instruction "next")) (instruction "move")
	   else if (instruction "move") == 0 then tm2 instructions head ((instruction "write"):tail) (instruction "next") (instruction "move")
	   	else tm2 instructions ([(instruction "write")] ++ tail) (reverse head) (instruction "next") (instruction "move")



-- eraserhead = make all 1 into 0 and then go back and make 0 into 2

eraserhead = 
	(tm (tm_is [
		(tm_i 0 1 0 1 0),
		(tm_i 0 0 0 1 0),
		(tm_i 0 (-1) (-1) (-1) 1),
		(tm_i 1 (0) (2) (-1) 1),
		(tm_i 1 (-1) (-1) 1 (-1))
		]
	))




second shot at th

02_second_try_tm.hs

-- Second machine was written from scratch
-- new feature: prints out the progress


turing_machine instructions initial last stop_char tape =
    pom (tm_instructions instructions) [stop_char] (tape++[stop_char]) last initial 'R' [tape]
    where pom project head (ch:tail) last state direction progress =
            if state == last
                then reverse progress
                else
                    let instruction = project state ch
                        move = tm_i_move instruction
                        next =  tm_i_next instruction
                        write = tm_i_write instruction
                    in if move == 'Z'
                            then pom project head (write:tail) last next direction ((tm_state (head ++ (write:tail)) direction):progress)
                            else if move == direction 
                                    then pom project (write:head) (tail) last next move ((tm_state ((reverse head) ++ (write:tail)) direction):progress)
                                    else pom project (write:tail) (head) last next move ((tm_state ((reverse head) ++ (write:tail)) direction):progress)
                     


clean_tape (x:xs) = 
    pom xs []
    where pom (x:xs) xy
	    | xs == []  = reverse xy
	    | otherwise = pom xs (x:xy)

                     
tm_state xs direction
    | direction == 'L' = clean_tape(reverse xs)
    | otherwise = clean_tape(xs)                      


-- tm_project instructions state char = 

tm_instruction_matches i state char = 
    (tm_i_state i) == state && (tm_i_char i) == char


tm_i_state (a, b, c, d, e) = a
tm_i_char  (a, b, c, d, e) = b
tm_i_write (a, b, c, d, e) = c
tm_i_move  (a, b, c, d, e) = d
tm_i_next  (a, b, c, d, e) = e


tm_instructions [] state char = error("No instruction for state: "++(show state)++" char: "++(show char)++".") 

tm_instructions (i:is) state char
        | tm_instruction_matches i state char = i
        | otherwise                           = tm_instructions is state char 


eraser = turing_machine [
            (0, 1, 0, 'R', 0),
            (0, -1, -1, 'L', 1),
            (1, 0, 2, 'L', 1),
            (1, -1, -1, 'R', -1)
        ] 0 (-1) (-1)


-- Hugs> eraser [1,1]
-- [[1,1],[0,1],[0,0],[0,0],[0,2],[2,2],[2,2]]