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