Skip to content

Instantly share code, notes, and snippets.

@fizbin fizbin/RunTM.hs
Last active May 22, 2017

Embed
What would you like to do?
The first Haskell I have evidence of having written
# 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
-- 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"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.