TM.hs

module TM where

import Debug.Trace (trace)


import qualified Data.Set as Set
import qualified Data.Stream as Stream
import Data.List (drop, dropWhile, head, iterate)

data TMAnswer = Accept | Reject deriving (Show)
data Shift = LeftShift | RightShift deriving (Show)
data State = State String deriving (Show, Eq, Ord)
data TMChar = TMChar Char | Empty deriving (Show, Eq, Ord)
data Tape = Tape {left, right :: Stream.Stream TMChar , cell :: TMChar} deriving (Show)
-- a single configuration of a turing machine at a certain point in it's run
data Configuration = Configuration { machine :: TM
                                   , tape :: Tape
                                   , curState :: State
                                   } deriving (Show)
type TM = TuringMachine         -- for easier usage of TMs
data TuringMachine = TuringMachine { states :: Set.Set State
                                   , alphabet :: Set.Set TMChar
                                   , inpAlphabet :: Set.Set TMChar
                                   , start :: State
                                   , accepters :: Set.Set State
                                   , halters :: Set.Set State
                                   , transFunction :: State -> TMChar -> (State, TMChar, Shift)
                                   }

instance Show TuringMachine where
  show (TuringMachine stts ab iab s acc hs _) = let
    sttsStr = show stts
    abStr = show ab
    iabStr = show iab
    sStr = show s
    accStr = show acc
    hsStr = show hs
    in concat ["States: ", sttsStr, "\n",
               "ABC: ", abStr, "\n",
               "IABC: ", iabStr, "\n",
               "Start: ", sStr, "\n",
               "Accs: ", accStr, "\n",
               "Halts: ", hsStr, "\n"]

applyTransition :: Tape -> TMChar -> Shift -> Tape
applyTransition tp ch dir = case dir of
  LeftShift -> let
    oldLeft = left tp
    newCell = Stream.head oldLeft
    newLeft = Stream.drop 1 oldLeft
    newRight = Stream.Cons ch (right tp)
    in Tape { left = newLeft, right = newRight, cell = newCell }
  RightShift -> let
    oldRight = right tp
    newCell = Stream.head oldRight
    newRight = Stream.drop 1 oldRight
    newLeft = Stream.Cons ch (left tp)
    in Tape { left = newLeft, right = newRight, cell = newCell }


step :: Configuration -> Configuration
step cfg = let
  m = machine cfg
  delta = transFunction m
  oldTape = tape cfg
  (newState, ch, dir) = delta (curState cfg) (cell oldTape)
  newTape = applyTransition oldTape ch dir
  nextConf = Configuration {machine = m, tape = newTape, curState = newState}
  in trace ("nextConf: " ++ (show nextConf)) nextConf

listToTMCharList :: [Char] -> [TMChar]
listToTMCharList l = map (\a -> TMChar a) l

-- create an infinite stream of the empty char and then prepend the string
listToStream :: [TMChar] -> Stream.Stream TMChar
listToStream l = Stream.prefix l (Stream.repeat Empty)

initTM :: TM -> [TMChar] -> Configuration
initTM m word = let
  tp = Tape {left = Stream.repeat Empty, right = listToStream $ drop 1 word, cell = head word}
  in
  Configuration { machine = m
                , tape = tp
                , curState = start m
                }

isRunning :: Configuration -> Bool
isRunning conf = let
  isrunningans = not $ Set.member (curState conf) (halters $ machine conf)
  curs = (curState conf)
  hlts = (halters $ machine conf)
  in trace ("isrunans = " ++ (show isrunningans) ++ "\n" ++
            "curstate = " ++ (show (curs)) ++ "\n" ++
            "hlts     = " ++ (show hlts) ++ "\n") isrunningans

isAccept :: Configuration -> Bool
isAccept conf = Set.member (curState conf) (accepters $ machine conf)

getAnswer :: Configuration -> TMAnswer
getAnswer conf = case Set.member (curState conf) (accepters $ machine conf) of
                   True -> Accept
                   False -> Reject


machineRun :: TM -> [TMChar] -> [Configuration]
machineRun m word = let
  conf0 = initTM m word
  in iterate step conf0

machineResult :: TM -> [Char] -> TMAnswer
machineResult m word = getAnswer $ head $ dropWhile isRunning (machineRun m tmword)
                           where tmword = listToTMCharList word




-- a definition of a turing machine that recognizes the word "Niv"
nivStates = Set.fromList [State "start", State "n", State "ni", State "niv", State "end"]
ab = Set.fromList (listToTMCharList (['a'..'z'] ++ ['A'..'Z']))
iab = ab
st = State "start"
acc = Set.fromList [State "niv"]
halts = Set.fromList [State "niv", State "end"]
delta (State s) (TMChar ch) = let
  next = trace ("got state, ch: " ++ (show (s,ch))) (case (s, ch) of
                                                    ("start", 'n') -> (State "n", TMChar 'n', RightShift)
                                                    ("n", 'i') -> (State "ni", TMChar 'i', RightShift)
                                                    ("ni", 'v') -> (State "niv", TMChar 'v', RightShift)
                                                    (_, _) -> (State "end", TMChar 'x', RightShift))
  bla = trace ("next State: " ++ (show next)) next
  in next



main :: IO ()
main = let
  nivTM = TuringMachine nivStates ab iab st acc halts delta
  in do
    -- print nivTM
    print (machineResult nivTM "niv")