CPSC 201 -- Introduction to Programming

Solutions to Assignment 5
-------------------------
Written by Paul Hudak
February 20, 2008

> module TM where


Higher-Order Functions
----------------------

> addPairs :: Num a => [a] -> [a] -> [a]
> addPairs = zipWith (+)

> applyAll :: [a->b] -> [a] -> [b]
> applyAll = zipWith ($)

> applyEach :: [a->b] -> a -> [b]
> applyEach fs a = map ($a) fs

> maxList :: Ord a => [a] -> a
> maxList = foldl1 max

> addLists :: Num a => [[a]] -> a
> addLists = foldl (+) 0 . map (foldl (+) 0)


Turing Machine Simulator
------------------------

A Turing Machine's doubly-infinite tape can be represented by:

> data Tape a = Tape [a] a [a]

Operations to move the tape head one position to the left or right:

> moveLeft  (Tape (x:xs) y zs) = Tape xs x (y:zs)
> moveRight (Tape xs y (z:zs)) = Tape (y:xs) z zs

An operation to write a new symbol to the tape:

> write (Tape xs y zs) a = Tape xs a zs

A Turing Machine is a five-tuple:

> data TM a s = TM [a]                                -- alphabet
>                  [s]                                -- set of states
>                  s                                  -- initial state
>                  (Tape a)                           -- initial tape
>                  (s -> Tape a -> Maybe (s, Tape a)) -- transition function

We can "run" a Turing Machine like this:

> runTM :: TM a s -> Tape a
> runTM (TM as ss s0 t0 tf) =
>   case tf s0 t0 of
>     Nothing      -> t0
>     Just (s1,t1) -> runTM (TM as ss s1 t1 tf)

Here is a version of runTM that returns the intermediate state and
tape at each step, which is useful for debugging:

> debugTM :: TM a s -> [(s,Tape a)]
> debugTM (TM as ss s0 t0 tf) =
>   (s0,t0) : case tf s0 t0 of
>               Nothing      -> []
>               Just (s1,t1) -> debugTM (TM as ss s1 t1 tf)

Show the current symbol + 20 symbols to either side on tape:

> showT (Tape xs y zs) =
>   reverse (take 20 xs) ++ ['|',y,'|'] ++ take 20 zs

For debugging TM programs:

> test tm = sequence_ (map (\(s,t)-> putStrLn (show s ++ [' '] ++ showT t))
>                     (debugTM tm))


Multiplication Program
----------------------

This is a transcription of the multiplication program in the Omnibus,
but note that the version in the text has two bugs, which are fixed here:

> mult :: Int -> Tape Char -> Maybe (Int, Tape Char)
> mult s t@(Tape _ a _) =
>   case (s,a) of
>     (0,'1')  -> Just (1, moveLeft t)
>     (1,' ')  -> Just (2, moveRight (write t '*'))
>     (2,' ')  -> Just (3, moveLeft t)
>     (2,'*')  -> Just (2, moveRight t)
>     (2,'1')  -> Just (2, moveRight t)
>     (2,'X')  -> Just (2, moveRight t)
>     (2,'A')  -> Just (2, moveRight t)
>     (3,'1')  -> Just (4, moveLeft (write t ' '))
>     (3,'X')  -> Just (9, moveLeft t)              -- wrong in text
>     (4,'1')  -> Just (4, moveLeft t)
>     (4,'X')  -> Just (5, moveLeft t)
>     (5,'*')  -> Just (8, moveRight t)
>     (5,'1')  -> Just (6, moveLeft (write t 'A'))
>     (5,'A')  -> Just (5, moveLeft t)
>     (6,' ')  -> Just (7, moveRight (write t '1'))
>     (6,'*')  -> Just (6, moveLeft t)
>     (6,'1')  -> Just (6, moveLeft t)
>     (7,'*')  -> Just (7, moveRight t)
>     (7,'1')  -> Just (7, moveRight t)
>     (7,'X')  -> Just (5, moveLeft t)
>     (7,'A')  -> Just (7, moveRight t)
>     (8,' ')  -> Just (3, moveLeft t)
>     (8,'1')  -> Just (8, moveRight t)
>     (8,'X')  -> Just (8, moveRight t)
>     (8,'A')  -> Just (8, moveRight (write t '1'))
>     (9,'*')  -> Just (10,moveRight (write t ' ')) -- wrong in text
>     (9,'1')  -> Just (9, moveLeft t)
>     (10,' ') -> Nothing                           -- halt
>     (10,'1') -> Just (10, moveRight (write t ' '))
>     (10,'X') -> Just (10, moveRight (write t ' '))
>     (10,'A') -> Just (10, moveRight (write t ' '))
>     _        -> error (show s ++ show a)

To multiply 4*3:

> tMult :: Tape Char
> tMult  = Tape blanks '1' ("111X111" ++ blanks)

> blanks = repeat ' '

> tmMult :: TM Char Int
> tmMult = TM " 1XA*" [0..10] 0 tMult mult

showT (runTM tmMult) ==>
"  111111111111      | |                    "


Palindrome Program
------------------

Here is a program to detect palindromes:

> palin :: Int -> Tape Char -> Maybe (Int, Tape Char)
> palin s t@(Tape _ a _) =
>   case (s,a) of
>     (0,'a')  -> Just (10, moveRight (write t ' '))
>     (0,'b')  -> Just (20, moveRight (write t ' '))
>     (0,' ')  -> Just (30, write t 'Y')
>     (10,'a') -> Just (10, moveRight t)
>     (10,'b') -> Just (10, moveRight t)
>     (10,' ') -> Just (11, moveLeft t)
>     (11,'a') -> Just (12, moveLeft (write t ' '))
>     (11,'b') -> Just (30, write t 'N')
>     (11,' ') -> Just (30, write t 'Y')
>     (12,'a') -> Just (12, moveLeft t)
>     (12,'b') -> Just (12, moveLeft t)
>     (12,' ') -> Just (0,  moveRight t)
>     (20,'a') -> Just (20, moveRight t)
>     (20,'b') -> Just (20, moveRight t)
>     (20,' ') -> Just (21, moveLeft t)
>     (21,'b') -> Just (22, moveLeft (write t ' '))
>     (21,'a') -> Just (30, write t 'N')
>     (21,' ') -> Just (30, write t 'Y')
>     (22,'a') -> Just (22, moveLeft t)
>     (22,'b') -> Just (22, moveLeft t)
>     (22,' ') -> Just (0,  moveRight t)
>     (30,'Y') -> Nothing
>     (30,'N') -> Nothing
>     _        -> error (show s ++ show a)

> tPal1, tPal2, tPal3, tPal4 :: Tape Char
> tPal1 = Tape blanks 'a' ("bba" ++ blanks)
> tPal2 = Tape blanks 'b' ("aabaab" ++ blanks)
> tPal3 = Tape blanks ' ' blanks
> tPal4 = Tape blanks 'b' blanks
> tPal5 = Tape blanks 'a' ("bab" ++ blanks)

> tmPal :: Tape Char -> TM Char Int
> tmPal t = TM " abYN" [0,10,11,12,20,21,22,30] 0 t palin

showT (runTM (tmPal tPaln)) ==>
1: "                    |Y|                    "
2: "                    |Y|                    "
3: "                    |Y|                    "
4: "                    |Y|                    "
5: "                  ba|N|                    "