From 33de036d4f068e97d98dbaf55535aadfb77a00e7 Mon Sep 17 00:00:00 2001 From: Guillermo Ramos Date: Thu, 21 Sep 2017 23:27:51 +0200 Subject: First commit --- src/Turing/Examples.hs | 45 ++++++++++++++++ src/Turing/Machine.hs | 137 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 182 insertions(+) create mode 100644 src/Turing/Examples.hs create mode 100644 src/Turing/Machine.hs (limited to 'src') 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 -- cgit v1.2.3