-- -------------------------------------------------------------
-- Simulation von deterministischen 1-Band Turingmaschinen 
-- in Haskell
-- (c) D. Sabel 2010
-- -------------------------------------------------------------

-- Importe:
import Data.List
import Data.Maybe
-- -------------------------------------------------------------

-- Datentypen

-- Der Move-Typ stellt dar, wohin der Lese/Schreib-Kopf bewegt
-- werden soll (Links, Rechts, Stehenbleiben)

data Move = MLeft | MRight | MNothing
 deriving (Eq, Show)

-- Der TM-Typ dient zur Darstellung einer Turingmaschine,
-- Eingabe- und Bandalphabet sowie die gesamte Zustandsmenge
-- werden nur implizit dargestellt,
-- daher verbleiben 3 Komponenten:
--  start: Der Startzustand der Turingmaschine
--  accepting: Menge der akzeptierenden Zust"ande
--  delta: "Ubergangsfunktion
-- Der Datentyp ist polymorph "uber dem Bandalphabet und den 
-- Zust"anden definiert. Beachte, dass "Leer"-Symbol auf dem 
-- Band wird dargestellt, indem anstelle von alphabet der Typ
-- (Maybe alphabet) verwendet wird, wobei
--  - Nothing ist der Inhalt eines uninitialisierten 
--    (d.h. leeren) Eintrags
--  - Just x ist der Inhalt eines Bandeintrags mit 
--    Symbol x aus dem Alphabet

 
data TM alphabet state = 
 TM {
  start     :: state,
  accepting :: [state],
  -- delta erh"alt den Zustand und das aktuelle Symbol
  -- und liefert den Nachfolgezustand, das neue Symbol, 
  -- und die Bewegung des Lese/Schreibe-Kopfs:
  delta     :: (state,Maybe alphabet) -> (state,Maybe alphabet,Move)
  }
 
-- Datentyp f"ur eine Turingmaschinenkonfiguration:
-- Das aktuelle Band ist before ++ [current] ++ after,
-- wobei der Kopf auf current steht
-- currState ist der aktuelle Zustand der Maschine 
 
data TMConfig alphabet state = 
 TMConfig {
  before    :: [Maybe alphabet],
  current   :: Maybe alphabet,
  after     :: [Maybe alphabet],
  currState :: state
 }
 
-- Show-Instanz f"ur TMConfig zum sch"onen Anzeigen
instance (Show a,Show b) => (Show (TMConfig a b)) where
 show tc = 
   let 
      b' = (if null (before tc) then "" else "|") 
            ++ (concat $ intersperse "|" $  map sM (before tc))
      bl = length b'
      a' = (concat $ intersperse "|" $  map sM (after tc)) 
            ++ if null (after tc) then "" else "|"
      l1 = b' ++ "|" ++ sM (current tc) ++ "|" ++ a'
      l2 = (replicate (1+bl) ' ') ++ "^"
   in l1 ++ "\n" ++ l2 
  where sM Nothing = "*"
        sM (Just e) = show e 

-- -------------------------------------------------------------
-- Funktionen                 
             
-- oneStep berechnet einen Schritt der Turingmaschine
-- oneStep erwartet als Eingaben eine Turingmaschine und eine 
-- Konfiguration
-- Falls die Maschine bereits in einem akzeptierenden Zustand ist,
-- liefert oneStep Nothing, anderenfalls liefert oneStep Just c, 
-- wobei c die Konfiguration nach Ausf"uhren eines Schrittes ist.
                 
oneStep :: Eq s => TM a s -> (TMConfig a s) -> Maybe (TMConfig a s)
oneStep tm tc
 -- akzeptierender Zustand schon erreicht?
 | (currState tc) `elem` (accepting tm) = Nothing
 -- sonst:
 | otherwise = 
    case (delta tm) (currState tc, current tc) of
    (s',a',m) -> -- Nachfolgezustand, Symbol, Kopfbewegung 
      case m of
       MNothing -> Just $ tc {currState = s', current = a'}
       MRight ->   
        if null (after tc) then
          Just $ tc {currState = s', 
                     current = Nothing, 
                     before = (before tc)++[a'], 
                     after = []}
        else Just $ tc {currState = s', 
                        current = head (after tc), 
                        before = (before tc) ++ [a'], 
                        after = tail (after tc)}
       MLeft -> 
        if null (before tc) then 
           error "move left on start position" 
         else if (null (after tc)) && (isNothing a') then
                 Just $ tc {currState = s', 
                            current = last (before tc), 
                            before = withoutLast (before tc), 
                            after = []}
              else
                 Just $ tc {currState = s', 
                            current = last (before tc), 
                            before = withoutLast (before tc), 
                            after = a':(after tc)}

    where 
     -- Hilfsfunktion: alle Elemente einer Liste ohne Letztes:
     withoutLast xs = reverse (tail (reverse xs)) 

-- runMachine erwartet eine Turingmaschine und die Eingabe auf 
-- auf dem Band, und simuliert die Turingmaschine.
-- Sie liefert die Endkonfiguration, falls die Maschine in einem
-- akzeptierenden Zustand landet

runMachine tm inputtape =
 let startconfig = TMConfig {current = head inputtape, 
                             before = [], 
                             after = tail inputtape, 
                             currState = (start tm)}
     go tc = case oneStep tm tc of 
             Nothing -> tc
             Just tc' -> go tc'
 in go startconfig

-- tmEncode erwartet eine Turingmaschine und die Eingabe auf dem
-- Band und liefert True, falls die Turingmaschine die Eingabe
-- akzeptiert.
tmEncode tm input = case runMachine tm input of
                   (TMConfig _ _ _ _) -> True


-- traceMachine arbeitet analog zu runMachine, liefert jedoch
-- die Liste alle Zwischenschritte (die Konfigurationen)
traceMachine tm inputtape =
 let startconfig = TMConfig {current = head inputtape, 
                             before = [], 
                             after = tail inputtape, 
                             currState = (start tm)}
     go tc = case oneStep tm tc of 
             Nothing -> [tc]
             Just tc' -> tc:(go tc')
 in go startconfig

-- -------------------------------------------------------------
-- Beispiele

-- ex1 TM die letztes Symbol der Eingabe sucht
ex1 =  
 let 
  d (1,Just 0) = (1,Just 0, MRight)
  d (1,Just 1) = (1,Just 1,  MRight)
  d (1,Nothing) = (2,Nothing, MLeft)
  d (2,_) = undefined
  input = [Just 0,Just 1,Just 0, Nothing]
  tm =
   TM {
    delta = d, --(state,alphabet) -> (state,Maybe alphabet,Move),
    accepting = [2],
    start = 1
   }
 in putStrLn $ unlines $ map show $ traceMachine tm input
                           
-- ex2 TM die un"are Zahl verdoppelt
ex2 = 
 let 
  d (0,Just 1) = (1,Nothing, MRight)
  d (0,Nothing) = (0,Nothing, MRight)
  d (1,Just 1) = (1,Just 1, MRight)
  d (1,Nothing) = (2,Nothing, MRight)
  d (2,Just 1) = (2,Just 1, MRight)
  d (2,Nothing) = (3,Just 1, MLeft)
  d (3,Just 1) = (3,Just 1, MLeft)
  d (3,Nothing) = (4,Nothing, MLeft)
  d (4,Just 1) = (4,Just 1, MLeft)
  d (4,Nothing) = (5,Just 1, MRight)
  d (5,Just 1) = (1,Nothing, MRight)
  d (5,Nothing) = (6,Just 1, MRight)
  d (6,Just 1) = (6,Just 1, MRight)
  d (6,Nothing) = (7,Nothing, MLeft)
  d (7,Just 1) = (8,Nothing, MLeft)
  d (7,Nothing) = (8,Nothing, MNothing)
  d (8,_) = undefined
  input = [Just 1,Just 1,Just 1]
  tm =
   TM {
    delta = d,
    accepting = [8],
    start = 0
   }
 in putStrLn $ unlines $ map show $ traceMachine tm input

-- tm addiert eins zur Bin"ardarstellung, 
-- Zahl muss f"uhrende 0 enthalten
ex3 = 
 let 
  d (0,Just 1) = (0,Just 1, MRight)
  d (0,Just 0) = (0,Just 0, MRight)
  d (0,Nothing) = (1,Nothing, MLeft)
  d (1,Just 1) = (1,Just 0, MLeft)
  d (1,Just 0) = (2,Just 1, MNothing)
  d (1,Nothing) = undefined
  d (2,_) = undefined

  input = [Just 0,Just 1]
  tm =
   TM {
    delta = d, 
    accepting = [2],
    start = 0
   }
 in putStrLn $ unlines $ map show $ traceMachine tm input