[SPOILER] Solution to QOTW #24 in Haskell

Daniel Martin <martin-+m399P62/[email protected]> Tue, 21 Sep 2004 01:51:40 -0400

Newsgroups	gmane.comp.lang.perl.qotw.discuss
Message-ID	<[email protected]>

I hope that whoever is writing up the summary hasn't closed the book yet.

I've been trying to learn Haskell, and so I did this problem in Haskell.
(Figuring that Turing Machine simulation is about as iterative a 
process as you
can get, and therefore exactly the wrong sort of thing to do in Haskell)  The
solution is attached.  When compiled with ghc and -O2, this is about three
times as fast as the various perl implementations.

It's fairly long, at just over 100 lines, and surely some Haskell expert could
shorten it productively.  Almost all of the code is taken up with parsing the
.tm file - the core of actually running the Turing Machine is just:

runTM :: TuringMachine -> String -> Tape -> Tape
runTM tm st tp =
   case lookupFM tm (st,headTM tp) of
     Nothing          -> tp
     Just (st', actn) -> runTM tm st' $ actn tp

I didn't use any regular expression library nor did I use the standard parser
libraries, so that might account for some of the length.  However, I 
think that
the end result is readable, even if it could use more commenting.

Although Haskell has very nice facilities for defining infinite strings that
would seem to be ideal for defining the initial tape, I was uncertain how to
display the infinite strings after the machine halted without getting into
trouble.  Therefore, my tape uses two Haskell String values - see the mvLeft,
mvRight, headTM, and write functions for the details of how those two Strings
are being used.

To compile this, assuming that you have ghc available, do:

    ghc -O2 -o tm tm.hs

It can then be run as in:

   ./tm parens.tm 4 | perl -pe 'tr/xo_/()\n/'

--
@/=map{[/./g]}qw/.h_nJ Xapou cets krht ele_ r_ra/;
map{y/X_/\n /;print}map{pop@$_}@/for@/

tm.hs (text/x-haskell, 3.5 KB)

import Char
import System
import Data.FiniteMap

-- 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

type TuringMachine = FiniteMap (String,Char) (String,(Tape -> Tape))

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

write :: Char -> Tape -> Tape
write c t = case right t of
              []       -> Tape (left t) (c:[])
              (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 = catch (parseTMLine' s) (\e -> 
                        fail $ "Bad Line '" ++ s ++ "'")
  where
   parseTMLine' s =
    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

buildTM :: String -> IO (TuringMachine, String)
buildTM s = do listVersion <- parseTMFile s
               ((st1,_), _) <- return $ head listVersion
               return ((listToFM listVersion), st1)

runTM :: TuringMachine -> String -> Tape -> Tape
runTM tm st tp =
  case lookupFM tm (st,headTM tp) of
    Nothing          -> tp
    Just (st', actn) -> runTM tm st' $ actn tp

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"
          (tm, st1) <- buildTM file
          tape <- return $ shiftTape pos (Tape [] tp)
          putStr . showTape . runTM tm st1 $ tape
          putStr "\n"