Data commit
This commit is contained in:
Ingy döt Net
parent
7387c8f97b
commit
cb5bb5e222
199093 changed files with 3378972 additions and 0 deletions
|
|
@ -0,0 +1,28 @@
|
|||
-- Some elementary types for Turing Machine
|
||||
data Move = MLeft | MRight | Stay deriving (Show, Eq)
|
||||
data Tape a = Tape a [a] [a]
|
||||
data Action state val = Action val Move state deriving (Show)
|
||||
|
||||
instance (Show a) => Show (Tape a) where
|
||||
show (Tape x lts rts) = concat $ left ++ [hd] ++ right
|
||||
where hd = "[" ++ show x ++ "]"
|
||||
left = map show $ reverse $ take 10 lts
|
||||
right = map show $ take 10 rts
|
||||
|
||||
-- new tape
|
||||
tape blank lts rts | null rts = Tape blank left blanks
|
||||
| otherwise = Tape (head rts) left right
|
||||
where blanks = repeat blank
|
||||
left = reverse lts ++ blanks
|
||||
right = tail rts ++ blanks
|
||||
|
||||
-- Turing Machine
|
||||
step rules (state, Tape x (lh:lts) (rh:rts)) = (state', tape')
|
||||
where Action x' dir state' = rules state x
|
||||
tape' = move dir
|
||||
move Stay = Tape x' (lh:lts) (rh:rts)
|
||||
move MLeft = Tape lh lts (x':rh:rts)
|
||||
move MRight = Tape rh (x':lh:lts) rts
|
||||
|
||||
runUTM rules stop start tape = steps ++ [final]
|
||||
where (steps, final:_) = break ((== stop) . fst) $ iterate (step rules) (start, tape)
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
incr "q0" 1 = Action 1 MRight "q0"
|
||||
incr "q0" 0 = Action 1 Stay "qf"
|
||||
|
||||
tape1 = tape 0 [] [1,1, 1]
|
||||
machine1 = runUTM incr "qf" "q0" tape1
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
*Main> mapM_ print machine1
|
||||
("q0",0000000000[1]1100000000)
|
||||
("q0",0000000001[1]1000000000)
|
||||
("q0",0000000011[1]0000000000)
|
||||
("q0",0000000111[0]0000000000)
|
||||
("qf",0000000111[1]0000000000)
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
beaver "a" 0 = Action 1 MRight "b"
|
||||
beaver "a" 1 = Action 1 MLeft "c"
|
||||
beaver "b" 0 = Action 1 MLeft "a"
|
||||
beaver "b" 1 = Action 1 MRight "b"
|
||||
beaver "c" 0 = Action 1 MLeft "b"
|
||||
beaver "c" 1 = Action 1 Stay "halt"
|
||||
|
||||
tape2 = tape 0 [] []
|
||||
machine2 = runUTM beaver "halt" "a" tape2
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
sorting "A" 1 = Action 1 MRight "A"
|
||||
sorting "A" 2 = Action 3 MRight "B"
|
||||
sorting "A" 0 = Action 0 MLeft "E"
|
||||
sorting "B" 1 = Action 1 MRight "B"
|
||||
sorting "B" 2 = Action 2 MRight "B"
|
||||
sorting "B" 0 = Action 0 MLeft "C"
|
||||
sorting "C" 1 = Action 2 MLeft "D"
|
||||
sorting "C" 2 = Action 2 MLeft "C"
|
||||
sorting "C" 3 = Action 2 MLeft "E"
|
||||
sorting "D" 1 = Action 1 MLeft "D"
|
||||
sorting "D" 2 = Action 2 MLeft "D"
|
||||
sorting "D" 3 = Action 1 MRight "A"
|
||||
sorting "E" 1 = Action 1 MLeft "E"
|
||||
sorting "E" 0 = Action 0 MRight "STOP"
|
||||
|
||||
tape3 = tape 0 [] [2,2,2,1,2,2,1,2,1,2,1,2,1,2]
|
||||
machine3 = runUTM sorting "STOP" "A" tape3
|
||||
|
|
@ -0,0 +1,152 @@
|
|||
import Control.Monad.State
|
||||
import Data.List (intersperse, nub, find)
|
||||
|
||||
data TapeMovement = MoveLeft | MoveRight | Stay deriving (Show, Eq)
|
||||
-- Rule = (state 1, input, output, movement, state 2)
|
||||
type Rule a = (a, a, a, TapeMovement, a)
|
||||
-- Execution = (tape position, current machine state, tape)
|
||||
type Execution a = (Int, a, [a])
|
||||
type Log a = [Execution a]
|
||||
type UTM a b = State (Machine a) b
|
||||
|
||||
-- can work with data of any type
|
||||
data Machine a = Machine
|
||||
{ allStates :: [a] -- not used actually
|
||||
, initialState :: a -- not used actually, initial state in "current"
|
||||
, finalStates :: [a]
|
||||
, symbols :: [a] -- not used actually
|
||||
, blank :: a
|
||||
, noOpSymbol :: a -- means: don't change input / don't shift tape
|
||||
, rules :: [Rule a]
|
||||
, current :: Execution a
|
||||
, machineLog :: Log a -- stores state changes from last to first
|
||||
, machineLogActive :: Bool -- if true, intermediate steps are stored
|
||||
, noRuleMsg :: a -- error symbol if no rule matches
|
||||
, stopMsg :: a } -- symbol to append to the end result
|
||||
deriving (Show)
|
||||
|
||||
-- it is not checked whether the input and output symbols are valid
|
||||
apply :: Eq a => Rule a -> UTM a a
|
||||
apply (_, _, output, direction, stateUpdate) = do
|
||||
m <- get
|
||||
let (pos, currentState, tape) = current m
|
||||
tapeUpdate = if output == noOpSymbol m
|
||||
then tape
|
||||
else take pos tape ++ [output] ++ drop (pos + 1) tape
|
||||
newTape
|
||||
| pos == 0 && direction == MoveLeft = blank m : tapeUpdate
|
||||
| succ pos == length tape && direction == MoveRight = tapeUpdate ++ [blank m]
|
||||
| otherwise = tapeUpdate
|
||||
newPosition = case direction of
|
||||
MoveLeft -> if pos == 0 then 0 else pred pos
|
||||
MoveRight -> succ pos
|
||||
Stay -> pos
|
||||
newState = if stateUpdate == noOpSymbol m
|
||||
then currentState
|
||||
else stateUpdate
|
||||
put $! m { current = (newPosition, newState, newTape) }
|
||||
return newState
|
||||
|
||||
-- rules with no-operation symbols and states must be underneath
|
||||
-- rules with defined symbols and states
|
||||
lookupRule :: Eq a => UTM a (Maybe (Rule a))
|
||||
lookupRule = do
|
||||
m <- get
|
||||
let (pos, currentState, tape) = current m
|
||||
item = tape !! pos
|
||||
isValid (e, i, _, _, _) = e == currentState &&
|
||||
(i == item || i == noOpSymbol m)
|
||||
return $! find isValid (rules m)
|
||||
|
||||
msgToLog :: a -> UTM a ()
|
||||
msgToLog e = do
|
||||
m <- get
|
||||
let (pos, currentState, tape) = current m
|
||||
put $! m { machineLog = (pos, currentState, tape ++ [e]) : machineLog m }
|
||||
|
||||
toLog :: UTM a ()
|
||||
toLog = do
|
||||
m <- get
|
||||
put $! m { machineLog = current m : machineLog m }
|
||||
|
||||
-- execute the machine's program
|
||||
execute :: Eq a => UTM a ()
|
||||
execute = do
|
||||
toLog -- log the initial state
|
||||
loop
|
||||
where
|
||||
loop = do
|
||||
m <- get
|
||||
r <- lookupRule -- look for a matching rule
|
||||
case r of
|
||||
Nothing -> msgToLog (noRuleMsg m)
|
||||
Just rule -> do
|
||||
stateUpdate <- apply rule
|
||||
if stateUpdate `elem` finalStates m
|
||||
then msgToLog (stopMsg m)
|
||||
else do
|
||||
when (machineLogActive m) toLog
|
||||
loop
|
||||
|
||||
---------------------------
|
||||
-- convenient functions
|
||||
---------------------------
|
||||
|
||||
-- run execute, format and print the output
|
||||
runMachine :: Machine String -> IO ()
|
||||
runMachine m@(Machine { current = (_, _, tape) }) =
|
||||
if null tape
|
||||
then putStrLn "NO TAPE"
|
||||
else case machineLog $ execState execute m of
|
||||
[] -> putStrLn "NO OUTPUT"
|
||||
xs -> do
|
||||
mapM_ (\(pos, _, output) -> do
|
||||
let formatOutput = concat output
|
||||
putStrLn formatOutput
|
||||
putStrLn (replicate pos ' ' ++ "^")) $ reverse xs
|
||||
putStrLn $ show (length xs) ++ " STEPS. FINAL STATE: " ++
|
||||
let (_, finalState, _) = head xs in show finalState
|
||||
|
||||
-- convert a string with format state+space+input+space+output+space+
|
||||
-- direction+space+new state to a rule
|
||||
toRule :: String -> Rule String
|
||||
toRule xs =
|
||||
let [a, b, c, d, e] = take 5 $ words xs
|
||||
dir = case d of
|
||||
"l" -> MoveLeft
|
||||
"r" -> MoveRight
|
||||
"*" -> Stay
|
||||
in (a, b, c, dir, e)
|
||||
|
||||
-- load a text file and parse it to a machine.
|
||||
-- see comments and examples
|
||||
-- lines in the file starting with ';' are header lines or comments
|
||||
-- header and input lines must contain a ':' and after that the content to be parsed
|
||||
-- so there can be comments between ';' and ':' in those lines
|
||||
loadMachine :: FilePath -> IO (Machine String)
|
||||
loadMachine n = do
|
||||
f <- readFile n
|
||||
|
||||
let ls = lines f
|
||||
-- header: first 4 lines
|
||||
([e1, e2, e3, e4], rest) = splitAt 4 ls
|
||||
-- rules and input: rest of the file
|
||||
re = map toRule . filter (not . null) $ map (takeWhile (/= ';')) rest
|
||||
ei = head . words . tail . snd $ break (== ':') e1
|
||||
va = head . words . tail . snd $ break (== ':') e3
|
||||
ci = words . intersperse ' ' . tail . snd $ break (== ':') $ last rest
|
||||
|
||||
return Machine
|
||||
{ rules = re
|
||||
, initialState = ei
|
||||
, finalStates = words . tail . snd $ break (== ':') e2
|
||||
, blank = va
|
||||
, noOpSymbol = head . words . tail . snd $ break (== ':') e4
|
||||
, allStates = nub $ concatMap (\(a, _, _, _, e) -> [a, e]) re
|
||||
, symbols = nub $ concatMap (\(_, b, c, _, _) -> [b, c]) re
|
||||
, current = (0, ei, if null ci then [va] else ci)
|
||||
-- we assume
|
||||
, noRuleMsg = "\tNO RULE." -- error: no matching rule found
|
||||
, stopMsg = "\tHALT." -- message: machine reached a final state
|
||||
, machineLog = []
|
||||
, machineLogActive = True }
|
||||
Loading…
Add table
Add a link
Reference in a new issue