RunTM.hs

## parens.tm
# See the comments at the top of RunTM.hs for how to run this

# Initialize things by making a "xo" string as long as
# the decimal input says

# scan to end-of-number
ste 1 ste 1 R
ste 2 ste 2 R
ste 3 ste 3 R
ste 4 ste 4 R
ste 5 ste 5 R
ste 6 ste 6 R
ste 7 ste 7 R
ste 8 ste 8 R
ste 9 ste 9 R
ste 0 ste 0 R
ste _ dec _ L

# find something to decrement
dec 1 addinitxo1 0 R
dec 2 addinitxo1 1 R
dec 3 addinitxo1 2 R
dec 4 addinitxo1 3 R
dec 5 addinitxo1 4 R
dec 6 addinitxo1 5 R
dec 7 addinitxo1 6 R
dec 8 addinitxo1 7 R
dec 9 addinitxo1 8 R
dec 0 dec 0 L
dec _ cleartobegin _ R

addinitxo1 0 addinitxo1 9 R
addinitxo1 _ addinitxo2 _ R

addinitxo2 x addinitxo2 x R
addinitxo2 o addinitxo2 o R
addinitxo2 _ addinitxo3 x R
addinitxo3 _ backtonum o L

backtonum x backtonum x L
backtonum o backtonum o L
backtonum _ dec _ L

cleartobegin 0 cleartobegin _ R
cleartobegin _ fsxs1 _ R

# done initialization - now we get to the meat of it

# Find second x string
fsxs1 x fsxs1  x R
fsxs1 o fsxs2  o R
fsxs2 o fsxs2  o R
fsxs2 x capend X R

# Capitalize until end-of-string
capend x capend X R
capend o capend O R
capend _ match1 _ L

#Match
#ignore O,X,Q,Y (L)
match1 O match1 O L
match1 X match1 X L
match1 Q match1 Q L
match1 Y match1 Y L

match1 o match2 Q L
match1 _ deqy   _ R
match1 x addx1  Y R

#ignore o,Y (L)
match2 o match2 o L
match2 Y match2 Y L

match2 x addxo1 Y R

#addx
#ignore Y,Q,X,O (R)
addx1 Y addx1 Y R
addx1 Q addx1 Q R
addx1 X addx1 X R
addx1 O addx1 O R

addx1 _ addx2 _ R

#ignore x,o,Q (R)
addx2 x addx2 x R
addx2 o addx2 o R
addx2 Q addx2 Q R

addx2 _ backm1 x L

#addxo
#ignore o,Y,Q,X,O (R)
addxo1 o addxo1 o R
addxo1 Y addxo1 Y R
addxo1 Q addxo1 Q R
addxo1 X addxo1 X R
addxo1 O addxo1 O R
addxo1 _ addxo2 _ R

#ignore x,o
addxo2 x addxo2 x R
addxo2 o addxo2 o R

addxo2 Q addxo2 o R
addxo2 _ addxo3 x R

addxo3 _ backm1 Q L

#backm1 - back to state match1
#ignore x,o,Q
backm1 x backm1 x L
backm1 o backm1 o L
backm1 Q backm1 Q L
backm1 _ match1 _ L

#deqy - Remove Q,Y
deqy Q deqy o R
deqy Y deqy x R
deqy X cpfind X L

#cpfind - find stuff to copy
cpfind x cpfind x R
cpfind o cpfind o R
cpfind X copyx1 x R
cpfind O copyo1 o R
cpfind _ fsxs1  _ R

#copyx
copyx1 X copyx1 X R
copyx1 O copyx1 O R
copyx1 _ copyx2 _ R

copyx2 x copyx2 x R
copyx2 o copyx2 o R
copyx2 Q copyo2 x R
copyx2 _ backcpfind x L

#copyo
copyo1 X copyo1 X R
copyo1 O copyo1 O R
copyo1 _ copyo2 _ R

copyo2 x copyo2 x R
copyo2 o copyo2 o R
copyo2 _ backcpfind o L

#backcpfind - back to cpfind
backcpfind x backcpfind x L
backcpfind o backcpfind o L
backcpfind _ backcpfind2 _ L

backcpfind2 X backcpfind2 X L
backcpfind2 O backcpfind2 O L
backcpfind2 x cpfind x R
backcpfind2 o cpfind o R

## RunTM.hs
-- This is the first Haskell program of any complexity that I ever wrote, back in October 2005,
-- updated (with newer imports and one changed function name) to run on modern (c. 2017)
-- GHC. It was designed to solve a perl quiz of the week problem to write a Turing
-- Machine emulator. Unfortunately, that mailing list has been defunct for so long that
-- all archives seem to have vanished from the web so I can't point to documentation of
-- the format. I can however point to one program I wrote in the Turing Machine language
-- that solved the prior quiz-of-the-week: given a number N, print out all strings
-- consisting of N '(' characters and N ')' characters such that the parens in the
-- resulting string are balanced.
--
-- This sample program can be run with:
--     runhaskell RunTM.hs parens.tm 4 | tr xo_ '()\n'
-- (Assuming a tr sufficiently like gnu tr)
-- the 'tr' step is needed because as spec.ed the format allows only word characters
-- on the turing machine tape.

import Data.Char
import System.IO.Error
import System.Environment

-- The head is located at the first character of "right"

data Tape = Tape {left::String, right::String}

instance Show Tape where
    showsPrec _ t s = "{" ++ left t ++ "," ++ right t ++ "}" ++ s

headTM :: Tape -> Char
headTM tape = case right tape of
                []     -> '_'
                (c:_)  -> c

write :: Char -> Tape -> Tape
write c t = case right t of
              []       -> Tape (left t) (c:[])
              (_:cs)   -> Tape (left t) (c:cs)

mvLeft :: Tape -> Tape
mvLeft t = case left t of
            []     -> Tape [] ('_':right t)
            (d:ds) -> Tape ds (d:right t)

mvRight :: Tape -> Tape
mvRight t = case right t of
            []     -> Tape ('_':left t) []
            (d:ds) -> Tape (d:left t) ds

isWord :: Char -> Bool
isWord c = (c == '_') || isAlphaNum c

-- returns empty list on empty line; fails on bad line
-- note the use of several <- lines with tight patterns on the
-- left as a sort of "assert" construct
--
-- Basically parses by doing a "split", but Haskell spells "split"
-- as "words"

parseTMLine :: String ->
      IO [(String,Char,String,(Tape -> Tape))]
parseTMLine s = catchIOError (parseTMLine') (\_ ->
                                               fail $ "Bad Line '" ++ s ++ "'")
  where
   parseTMLine' =
    do s' <- return $ dropWhile isSpace $ takeWhile (/= '#') s
       wrds <- return $ words s'
       case wrds of
        [] -> return []
        ws -> do [st1, c1:[], st2, c2:[], [dir]] <- return ws
                 []   <- return $ dropWhile isWord st1
                 True <- return $ isWord c1
                 []   <- return $ dropWhile isWord st2
                 True <- return $ isWord c2
                 case dir of
                  'L' -> return [(st1,c1,st2, mvLeft . write c2)]
                  'R' -> return [(st1,c1,st2, mvRight . write c2)]
                  'N' -> return [(st1,c1,st2, write c2)]
                  _   -> fail ""

parseTMFile :: String ->
      IO [(String,Char,String,(Tape -> Tape))]
parseTMFile f =
  do contents <- readFile f
     l <- sequence $ map parseTMLine $ lines contents
     return $ foldr1 (++) l

foff :: (a, b, c, d) -> a
foff (a, _, _, _) = a

compileTM :: [(String,Char,String,(Tape -> Tape))] -> String -> Tape -> Tape
compileTM rows = retval
  where
    retval = compileTMbit rows
    compileTMbit [] = \ _ -> id
    compileTMbit rws@((st,_,_,_):_) =
      \state -> if (st == state)
                then compiledstate
                else compiledrest state
      where
        compiledstate = compileTMstate $ filter (\s -> st == foff s) rws
        compiledrest  = compileTMbit $ filter (\s -> st /= foff s) rws
    compileTMstate [] = id
    compileTMstate ((_,c,nst,f):rws) =
      \tp -> if (c == headTM tp)
             then fulltapef tp
             else compilerest tp
      where
        fulltapef = (retval nst) . f
        compilerest = compileTMstate rws

showTape :: Tape -> String
showTape (Tape [] r) = showTape' $ dropWhile (== '_') r
 where showTape' r' = case r' of
                      []     -> []
                      '_':cs -> case showTape' cs of
                                  [] -> []
                                  s  -> '_':s
                      c:cs   -> c:showTape' cs
showTape t = showTape $ mvLeft t

shiftTape :: Int -> Tape -> Tape
shiftTape 0 = id
shiftTape i = mvRight . shiftTape (i - 1)

main :: IO ()
main = do args <- getArgs
          (file, tp, pos) <-
            case args of
              []      -> fail "Need a filename"
              [f]     -> return (f, [], 0)
              [f,t]   -> return (f, t, 0)
              [f,t,p] -> return (f, t, (read p))
              _       -> fail "Too many arguments"
          tmspec <- parseTMFile file
          initialState <- return $ foff (head tmspec)
          tm <- return (compileTM tmspec initialState)
          tape <- return $ shiftTape pos (Tape [] tp)
          putStr . showTape . tm $ tape
          putStr "\n"