datatype Dir = L | R

datatype Gamma = TS | BLK | A | B | M

datatype State = S | REJ of string | ACC | Q | F
               | CM | CMT | C | CA | CB
               | LM | LMF | LMA | LMB | LMS
               | RM | RMF | RMA | RMB | RMS
               | MA | HA | MB | HB

fun trans S TS = SOME (S,TS,R) (* move to the right *)
  | trans S A = SOME (S,A,R)
  | trans S B = SOME (S,B,R)
  | trans S BLK = SOME (CM,BLK,R) (* a second fresh blank *)
  | trans CM BLK = SOME (C,M,L) (* write right marker, and start shifting *)
  | trans C BLK = SOME (C,BLK,L)
  | trans C A = SOME (CA,BLK,R)
  | trans C B = SOME (CB,BLK,R)
  | trans C TS = SOME (CMT,TS,R)
  | trans CA BLK = SOME (C,A,L)
  | trans CB BLK = SOME (C,B,L)
  | trans CMT BLK = SOME (LM,M,L) (* write left marker, shifting finished *)
  | trans LM TS = SOME (LM,TS,R) (* start moving markers *)
  | trans LM A = SOME (LM,A,L) (* find left marker, from right *)
  | trans LM B = SOME (LM,B,L)
  | trans LM M = SOME (LMF,M,R) (* found left marker, start swap *)
  | trans LMF A = SOME (LMA,M,L)
  | trans LMF B = SOME (LMB,M,L)
  | trans LMF M = SOME (Q,M,L) (* continue: markers reached center, reset to left-most position *)
  | trans LMA M = SOME (LMS,A,R)
  | trans LMB M = SOME (LMS,B,R)
  | trans LMS M = SOME (RM,M,R)
  | trans RM A = SOME (RM,A,R) (* find right marker, from left *)
  | trans RM B = SOME (RM,B,R)
  | trans RM M = SOME (RMF,M,L) (* found right marker, start swap *)
  | trans RMF A = SOME (RMA,M,R)
  | trans RMF B = SOME (RMB,M,R)
  | trans RMF M = SOME (REJ "odd length",M,R) (* reject: odd length word *)
  | trans RMA M = SOME (RMS,A,L)
  | trans RMB M = SOME (RMS,B,L)
  | trans RMS M = SOME (LM,M,L)
  | trans Q M = SOME (Q,M,L) (* resets head to leftmost postion .. *)
  | trans Q A = SOME (Q,A,L)
  | trans Q B = SOME (Q,B,L)
  | trans Q TS = SOME (F,TS,R)
  | trans F M = SOME (F,M,R) (* find an unmarked symbol in left half *)
  | trans F BLK = SOME (ACC,BLK,L) (* everything marked -> accept *)
  | trans F A = SOME (MA,M,R) (* marked an A, looking for right half *)
  | trans F B = SOME (MB,M,R) (* marked a B, looking for right half *)
  | trans MA A = SOME (MA,A,R)
  | trans MA B = SOME (MA,B,R)
  | trans MA M = SOME (HA,M,R) (* the next unmarked char should be A *)
  | trans HA M = SOME (HA,M,R)
  | trans HA A = SOME (Q,M,L) (* hit: mark, reset, rinse repeat *)
  | trans HA B = SOME (REJ "mismatch",B,L) (* reject: mismatch *)
  | trans MB A = SOME (MB,A,R)
  | trans MB B = SOME (MB,B,R)
  | trans MB M = SOME (HB,M,R) (* the next unmarked char should be B *)
  | trans HB M = SOME (HB,M,R)
  | trans HB A = SOME (REJ "mismatch",A,L) (* reject: mismatch *)
  | trans HB B = SOME (Q,M,L) (* hit: mark, reset, rinse repeat *)
  | trans _ _ = NONE

exception Error

fun run ls ACC rs = (ls,ACC,rs)
  | run ls (REJ e) rs = (ls,(REJ e),rs)
  | run ls q nil = run ls q [BLK]
  | run ls q (r :: rs) = case (trans q r)
                         of SOME (t,a,R) => run (a::ls) t rs
                          | SOME (t,a,L) => (case ls
                                             of (m::ms) => run ms t (m :: a :: rs)
                                              | nil => raise Error)
                          | NONE => (ls,q,(r::rs))

fun exec input = case (run nil S (TS::input))
                 of (ls, ACC, rs) => "input accepted"
                  | (ls, REJ e, rs) => "input rejected: "^e
                  | _ => "machine stuck on input"

val test0 = exec nil
val test1 = exec [A,B,B,A,A,B,B,A]
val test2 = exec [A,B,B,A]
val test3 = exec [A,B,A]