First commit

2 files changed, 182 insertions, 0 deletions

diff --git a/src/Turing/Examples.hs b/src/Turing/Examples.hs
new file mode 100644
index 0000000..3b113fd
--- /dev/null
+++ b/src/Turing/Examples.hs
@@ -0,0 +1,45 @@
+module Turing.Examples where
+
+import Data.List (intersperse)
+import Data.Monoid
+
+import Turing.Machine
+
+mR1, mL1, mInit :: Machine
+mR1 = mkMachine [(0, SymWild, R, 1)]
+mL1 = mkMachine [(0, SymWild, L, 1)]
+mInit = mL SymInit <> mR1
+
+mR, mL, mR', mL', mW :: Symbol -> Machine
+mR sy = mkMachine [(0, sy, W sy, 1), (0, SymWild, R, 0)]
+mL sy = mkMachine [(0, sy, W sy, 1), (0, SymWild, L, 0)]
+mR' sy = mkMachine [(0, sy, R, 0), (0, SymWild, W SymWild, 1)]
+mL' sy = mkMachine [(0, sy, L, 0), (0, SymWild, W SymWild, 1)]
+mW sy = mkMachine [(0, SymWild, W sy, 1)]
+
+mWriteStr :: String -> Machine
+mWriteStr = mconcat . intersperse mR1 . map (mW . charToSym)
+
+mSub :: Machine
+mSub = mkMachine [ (0, SymSpace,   R          , 1)
+                 , (1, Symbol 'a', R          , 1)
+                 , (1, SymSpace,   R          , 2)
+                 , (2, SymSpace,   R          , 2)
+                 , (2, Symbol 'a', R          , 3)
+                 , (3, SymSpace,   L          , 9)
+                 , (3, Symbol 'a', R          , 5)
+                 , (9, Symbol 'a', W SymSpace , 9)
+                 , (9, SymSpace,   L          , 4)
+                 , (4, SymInit,    R          , 10)
+                 , (4, SymWild,    L          , 4)
+                 , (5, Symbol 'a', R          , 5)
+                 , (5, SymSpace,   L          , 6)
+                 , (6, Symbol 'a', W SymSpace , 6)
+                 , (6, SymSpace,   L          , 7)
+                 , (7, Symbol 'a', L          , 7)
+                 , (7, SymSpace,   L          , 8)
+                 , (8, SymSpace,   L          , 8)
+                 , (8, Symbol 'a', W SymSpace , 2) ]
+
+mDecr :: Machine
+mDecr = mconcat [mR1, mR SymSpace, mL1, mW SymSpace, mL1, mL SymSpace]
diff --git a/src/Turing/Machine.hs b/src/Turing/Machine.hs
new file mode 100644
index 0000000..0a1002e
--- /dev/null
+++ b/src/Turing/Machine.hs
@@ -0,0 +1,137 @@
+module Turing.Machine where
+
+import qualified Data.Map.Strict as Map
+
+import Data.List
+import Data.Monoid
+import Control.Monad
+
+data Symbol = SymInit | SymWild | SymSpace | Symbol Char deriving (Eq, Ord)
+instance Show Symbol where
+    show (Symbol c) = [c]
+    show SymInit    = ">"
+    show SymWild    = "*"
+    show SymSpace   = "_"
+
+special :: Symbol -> Bool
+special (Symbol _) = False
+special _          = True
+
+charToSym :: Char -> Symbol
+charToSym '_' = SymSpace
+charToSym c = Symbol c
+
+data Action = W Symbol | L | R
+instance Show Action where
+    show (W sym) = show sym
+    show L       = "←"
+    show R       = "→"
+
+type State = Int
+type TransF = State -> Symbol -> Maybe (Action, State) -- TODO delete
+type Trans = Map.Map (State,Symbol) (Action,State)
+
+-- Turing Machine
+data Machine = Machine { states  :: [State]
+                       , s0      :: State
+                       , finals  :: [State]
+                       , symbols :: [Symbol]
+                       , delta   :: TransF
+                       , trans   :: Trans }
+instance Show Machine where
+    show (Machine sts ini fins syms _ trs) =
+        intercalate "\n\n"
+          [ "--- Turing Machine ---"
+          , " States: [" ++ show (head sts) ++ ".." ++ show (last sts) ++ "]"
+          , " Initial state: " ++ show ini
+          , " Final states: " ++ show fins
+          , " Symbols: " ++ show syms
+          , " Transition table:\n" ++ showTrans trs ]
+instance Monoid Machine where
+    mempty  = nop
+    mappend = comp
+
+showTrans :: Trans -> String
+showTrans trs = separator ++ intercalate' "\n" table ++ separator
+    where separator = " +" ++ concatMap (\s -> replicate s '-' ++ "--+") lengths
+          table = map (intercalate' " | "
+                       . map (\ (ml, f) -> replicate (ml - length f) ' ' ++ f)
+                       . zip lengths) fields
+          lengths = map (maximum . map length) (transpose fields)
+          fields = map (\ ((a, b), (c, d)) -> [show a, show b, show c, show d])
+                   (Map.toList trs)
+          intercalate' x xs = x ++ intercalate x xs ++ x
+
+mkDelta :: Trans -> TransF
+mkDelta trs st sym =
+    msum $ map (`Map.lookup` trs) [(st, sym), (st, SymWild)]
+
+mkMachine :: [(State, Symbol, Action, State)] -> Machine
+mkMachine trs = Machine sts ini fins syms (mkDelta trns) trns
+    where sts = sort $ union stsFrom stsTo
+          ini = minimum sts
+          fins = sort $ stsTo \\ stsFrom
+          syms = nub . filter (not . special) . map (\(_,sy,_,_) -> sy) $ trs
+          trns = Map.fromList (map (\(s1,sy,a,s2) -> ((s1,sy),(a,s2))) trs)
+          stsTo = nub $ map (\(_,_,_,s) -> s) trs
+          stsFrom = nub $ map (\(s,_,_,_) -> s) trs
+
+nop :: Machine
+nop = mkMachine [(0, SymWild, W SymWild, 1)]
+
+freshen :: Machine -> Machine -> Machine
+freshen m1 m2 = Machine sts ini fins syms d trns
+    where sts = map (+ offset) (states m2)
+          ini = s0 m2 + offset
+          fins = map (+ offset) (finals m2)
+          syms = symbols m2
+          d = mkDelta trns
+          trns = Map.map (\(a,s2) -> (a,s2+offset)) $
+                    Map.mapKeys (\(s1,sy) -> (s1+offset,sy)) (trans m2)
+          offset = maximum (states m1) + 1
+
+comp :: Machine -> Machine -> Machine
+comp m1 m2 = Machine sts ini fins syms d trns
+    where sts = sort $ states m1 `union` states m2'
+          ini = s0 m1
+          fins = finals m2'
+          syms = symbols m1 `union` symbols m2'
+          d st sym = msum $ map (\ s -> Map.lookup (st,s) trns) [sym, SymWild]
+          trns = Map.union connect $ Map.union (trans m1) (trans m2')
+          connect = Map.fromList $
+                    map (\ s1 -> ((s1,SymWild),(W SymWild, s0 m2'))) (finals m1)
+          m2' = freshen m1 m2
+
+-- Configuration
+type Tape = [Symbol]
+
+showTape :: Tape -> String
+showTape = concatMap show
+
+type Position = Int
+data Config = Config { tape  :: Tape
+                     , pos   :: Position
+                     , state :: State }
+instance Show Config where
+    show (Config t p s) = concat [roof, "\n|", showTape t, "\n", pointer, "\n"]
+        where roof = ' ' : replicate (length t) '_'
+              pointer = replicate (p+1) ' ' ++ "▲" ++ show s
+
+mkConfig :: Tape -> Config
+mkConfig t = Config (SymInit:t) 1 0
+
+step :: Config -> TransF -> Maybe Config
+step (Config t p s) d = fmap doAction (d s (t !! p))
+    where doAction (L, s') = Config (adjust t (p-1)) (p-1) s'
+          doAction (R, s') = Config (adjust t (p+1)) (p+1) s'
+          doAction (W sy, s')
+              | sy == SymWild = Config t p s'
+              | otherwise  = Config (adjust (replace t p sy) p) p s'
+          adjust l newpos
+              | diff > 0 = l ++ replicate diff SymSpace
+              | diff < 0 && last l == SymSpace = init l
+              | otherwise = l
+              where diff = newpos - (length l - 1)
+          replace [] _ _ = []
+          replace (_:xs) 0 e = e : xs
+          replace (x:xs) n e = x : replace xs (n-1) e