Sync

Task/Universal-Turing-machine/C++/universal-turing-machine.cpp

@@ -0,0 +1,134 @@
+#include <vector>
+#include <string>
+#include <iostream>
+#include <algorithm>
+#include <fstream>
+#include <iomanip>
+//--------------------------------------------------------------------------------------------------
+typedef unsigned int uint;
+using namespace std;
+const uint TAPE_MAX_LEN = 49152;
+//--------------------------------------------------------------------------------------------------
+struct action { char write, direction; };
+//--------------------------------------------------------------------------------------------------
+class tape
+{
+public:
+    tape( uint startPos = TAPE_MAX_LEN >> 1 ) : MAX_LEN( TAPE_MAX_LEN ) { _sp = startPos; reset(); }
+    void reset() { clear( '0' ); headPos = _sp; }
+    char read(){ return _t[headPos]; }
+    void input( string a ){ if( a == "" ) return; for( uint s = 0; s < a.length(); s++ ) _t[headPos + s] = a[s]; }
+    void clear( char c ) {  _t.clear(); blk = c; _t.resize( MAX_LEN, blk ); }
+    void action( const action* a ) { write( a->write ); move( a->direction ); }
+    void print( int c = 10 )
+    {
+	int ml = static_cast<int>( MAX_LEN ), st = static_cast<int>( headPos ) - c, ed = static_cast<int>( headPos ) + c + 1, tx;
+	for( int x = st; x < ed; x++ )
+	{ tx = x; if( tx < 0 ) tx += ml; if( tx >= ml ) tx -= ml; cout << _t[tx]; }
+	cout << endl << setw( c + 1 ) << "^" << endl;
+    }
+private:
+    void move( char d ) { if( d == 'N' ) return; headPos += d == 'R' ? 1 : -1; if( headPos >= MAX_LEN ) headPos = d == 'R' ? 0 : MAX_LEN - 1; }
+    void write( char a ) { if( a != 'N' ) { if( a == 'B' ) _t[headPos] = blk; else _t[headPos] = a; } }
+    string _t; uint headPos, _sp; char blk; const uint MAX_LEN;
+};
+//--------------------------------------------------------------------------------------------------
+class state
+{
+public:
+    bool operator ==( const string o ) { return o == name; }
+    string name, next; char symbol, write, direction;
+};
+//--------------------------------------------------------------------------------------------------
+class actionTable
+{
+public:
+    bool loadTable( string file )
+    {
+	reset();
+	ifstream mf; mf.open( file.c_str() ); if( mf.is_open() )
+	{
+	    string str; state stt;
+	    while( mf.good() )
+	    {
+		getline( mf, str ); if( str[0] == '\'' ) break;
+		parseState( str, stt ); states.push_back( stt );
+	    }
+	    while( mf.good() )
+	    {
+		getline( mf, str ); if( str == "" ) continue;
+		if( str[0] == '!' ) blank = str.erase( 0, 1 )[0];
+		if( str[0] == '^' ) curState = str.erase( 0, 1 );
+		if( str[0] == '>' ) input = str.erase( 0, 1 );
+	    }
+	    mf.close(); return true;
+	}
+	cout << "Could not open " << file << endl; return false;
+    }
+
+    bool action( char symbol, action& a )
+    {
+	vector<state>::iterator f = states.begin();
+	while( true )
+	{
+	    f = find( f, states.end(), curState );
+	    if( f == states.end() ) return false;
+	    if( ( *f ).symbol == '*' || ( *f ).symbol == symbol || ( ( *f ).symbol == 'B' && blank == symbol ) )
+	    { a.direction = ( *f ).direction; a.write = ( *f ).write; curState = ( *f ).next; break; }
+	    f++;
+	}
+	return true;
+    }
+    void reset() { states.clear(); blank = '0'; curState = input = ""; }
+    string getInput() { return input; }
+    char getBlank() { return blank; }
+private:
+    void parseState( string str, state& stt )
+    {
+	string a[5]; int idx = 0;
+	for( string::iterator si = str.begin(); si != str.end(); si++ )
+	{ if( ( *si ) == ';' ) idx++; else a[idx].append( &( *si ), 1 ); }
+	stt.name = a[0]; stt.symbol = a[1][0]; stt.write = a[2][0]; stt.direction = a[3][0]; stt.next = a[4];
+    }
+    vector<state> states; char blank; string curState, input;
+};
+//--------------------------------------------------------------------------------------------------
+class utm
+{
+public:
+    utm() { files[0] = "incrementer.utm"; files[1] = "busy_beaver.utm"; files[2] = "sort.utm"; }
+    void start()
+    {
+	while( true )
+	{
+	    reset(); int t = showMenu(); if( t == 0 ) return;
+	    if( !at.loadTable( files[t - 1] ) ) return; startMachine();
+	}
+    }
+private:
+    void simulate()
+    {
+	char r; action a;
+	while( true ) { tp.print(); r = tp.read(); if( !( at.action( r, a ) ) ) break; tp.action( &a ); }
+	cout << endl << endl; system( "pause" );
+    }
+
+    int showMenu()
+    {
+	int t = -1;
+	while( t < 0 || t > 3 )
+	{
+	    system( "cls" ); cout << "1. Incrementer\n2. Busy beaver\n3. Sort\n\n0. Quit";
+	    cout << endl << endl << "Choose an action "; cin >> t;
+	}
+	return t;
+    }
+
+    void reset() { tp.reset(); at.reset(); }
+    void startMachine() { system( "cls" ); tp.clear( at.getBlank() ); tp.input( at.getInput() ); simulate(); }
+
+    tape tp; actionTable at; string files[7];
+};
+//--------------------------------------------------------------------------------------------------
+int main( int a, char* args[] ){ utm mm; mm.start(); return 0; }
+//--------------------------------------------------------------------------------------------------

Task/Universal-Turing-machine/Haskell/universal-turing-machine.hs

@@ -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 }

Task/Universal-Turing-machine/Icon/universal-turing-machine.icon

@@ -0,0 +1,118 @@
+record TM(start,final,delta,tape,blank)
+record delta(old_state, input_symbol, new_state, output_symbol, direction)
+
+global start_tape
+global show_count, full_display, trace_list  # trace flags
+
+procedure main(args)
+    init(args)
+    runTuringMachine(get_tm())
+end
+
+procedure init(args)
+    trace_list := ":"
+    while arg := get(args) do {
+        if arg == "-f" then full_display := "yes"
+        else if match("-t",arg) then trace_list ||:= arg[3:0]||":"
+        else show_count := integer(arg)
+        }
+end
+
+procedure get_tm()
+    D := table()
+
+    writes("What is the start state? ")
+    start := !&input
+    writes("What are the final states (colon separated)? ")
+    finals := !&input
+    (finals||":") ? every insert(fStates := set(), 1(tab(upto(':')),move(1)))
+    writes("What is the tape blank symbol?")
+    blank := !&input
+
+    write("Enter the delta mappings, using the following format:")
+    write("\tenter delta(curState,tapeSymbol) = (newState,newSymbol,direct) as")
+    write("\t   curState:tapeSymbol:newState:newSymbol:direct");
+    write("\t\twhere direct is left, right, stay, or halt")
+    write("End with a blank line.")
+    write("")
+    every line := !&input do {
+        if *line = 0 then break
+        line ?
+             if (os := tab(upto(':')), move(1), ic := tab(upto(':')), move(1),
+                 ns := tab(upto(':')), move(1), oc := tab(upto(':')), move(1),
+                 d  := map(tab(0))) then D[os||":"||ic] := delta(os,ic,ns,oc,d)
+             else write(line, " is in bad form, correct it")
+        }
+    if /start_tape then {
+        write("Enter the input tape")
+        start_tape := !&input
+        }
+    return TM(start,fStates,D,start_tape,blank)
+end
+
+procedure runTuringMachine(tm)
+    trans := tm.delta
+    rightside := tm.tape
+    if /rightside | (*rightside = 0) then rightside := tm.blank
+    leftside := ""
+
+    cur_state := tm.start
+    write("Machine starts in ",cur_state," with tape:")
+    show_tape(tm,leftside,rightside)
+    while mapping := \trans[cur_state||":"||rightside[1]] do {
+        rightside[1] := mapping.output_symbol
+        case mapping.direction of {
+            "left" : {
+                 if *leftside = 0 then leftside := tm.blank
+                 rightside := leftside[-1] || rightside
+                 leftside[-1] := ""
+                 }
+            "right" : {
+                 leftside ||:= rightside[1]
+                 rightside[1] := ""
+                 if *rightside = 0 then rightside := tm.blank
+                 }
+            "halt" : break
+            }
+        cur_state := mapping.new_state
+        if member(tm.final,cur_state) then break
+        trace(tm,cur_state,leftside,rightside)
+        }
+    write()
+    write("Machine halts in ",cur_state," with tape:")
+    show_tape(tm,leftside,rightside)
+end
+
+procedure trace(tm,cs,ls,rs)
+    static count, last_state
+    initial {
+       count := 0
+       last_state := ""
+       }
+
+    count +:= 1
+    if \show_count & (count % show_count = 0) then show_tape(tm,ls,rs)
+    if find(":"||cs||":",trace_list) & (last_state ~== cs) then {
+        writes("\tnow in state: ",cs," ")
+        if \full_display then show_delta(tm.delta[cs||":"||rs[1]])
+        else write()
+        }
+    last_state := cs
+    return
+end
+
+procedure show_delta(m)
+    if /m then write("NO MOVE!")
+    else {
+        writes("\tnext move is ")
+        writes("delta(",m.old_state,",",m.input_symbol,") ::= ")
+        write("(",m.new_state,",",m.output_symbol,",",m.direction,")")
+        }
+end
+
+procedure show_tape(tm,l,r)
+    l := reverse(trim(reverse(l),tm.blank))
+    r := trim(r,tm.blank)
+    write(l,r)
+    write(repl(" ",*l),"^")
+end

Task/Universal-Turing-machine/J/universal-turing-machine-1.j

@@ -0,0 +1,16 @@
+   ".@(('utm=. '),,)@(];._2)@(noun=. ".@('(0 : 0)'"_))_ NB. Fixed tacit universal Turing machine code...
+
+(((":@:(]&:>)@:(6&({::)) ,: (":@] 9&({::))) ,. ':'"_) ,. 2&({::) >@:(((
+48 + ]) { a."_)@[ ; (] $ ' '"_) , '^'"_) 3&({::))@:([ (0 0 $ 1!:2&2)@:(
+'A changeless cycle was detected!'"_)^:(-.@:(_1"_ = 1&({::))))@:((((3&(
+{::) + 8&({::)) ; 1 + 9&({::)) 3 9} ])@:(<@:((0: 0&({::)@]`(<@(1&({::))
+@])`(2&({::)@])} ])@:(7 3 2&{)) 2} ])@:(<"0@:(6&({::) (<@[ { ]) 0&({::)
+) 7 8 1} ])@:([ (0 0 $ 1!:2&2)@:(((":@:(]&:>)@:(6&({::)) ,: (":@] 9&({:
+:))) ,. ':'"_) ,. 2&({::) >@:(((48 + ]) { a."_)@[ ; (] $ ' '"_) , '^'"_
+) 3&({::))^:(0 = 4&({::) | 9&({::)))@:(<@:(1&({::) ; 3&({::) { 2&({::))
+ 6} ])@:(<@:(3&({::) + _1 = 3&({::)) 3} ])@:(<@:(((_1 = 3&({::)) {:: 5&
+({::)) , 2&({::) , (3&({::) = #@:(2&({::))) {:: 5&({::)) 2} ])^:(-.@:(_
+1"_ = 1&({::)))^:_)@:((0 ; (({. , ({: % 3:) , 3:)@:$ $ ,)@:(}."1)@:(".;
+._2)@:(0&({::))) 9 0} ])@:(<@:('' ; 0"_) 5} ])@:(5&(] , a: $~ [))@:(,~)
+
+)

Task/Universal-Turing-machine/J/universal-turing-machine-2.j

@@ -0,0 +1,19 @@
+   NB. Simple Incrementer...
+   NB.        0         1     Tape Symbol Scan
+   NB. S   p  m  g   p  m  g  (p,m,g) → (print,move,goto)
+   QS=. (noun _) ; 0          NB. Reading the transition table and setting the initial state
+       0   1  0 _1   1  1  0
+)
+   TPF=. 1 1 1 ; 0 ; 1        NB. Setting the tape, its pointer and the display frequency
+
+   TPF utm QS                 NB. Running the Turing machine...
+0 1:111
+0  :^
+0 1:111
+1  : ^
+0 1:111
+2  :  ^
+0 0:1110
+3  :   ^
+0 0:1111
+4  :   ^

Task/Universal-Turing-machine/J/universal-turing-machine-3.j

@@ -0,0 +1,39 @@
+   NB. Three-state busy beaver..
+   NB.        0         1     Tape Symbol Scan
+   NB. S   p  m  g   p  m  g  (p,m,g) → (print,move,goto)
+   QS=. (noun _) ; 0          NB. Reading the transition table and setting the initial state
+       0   1  1  1   1 _1  2
+       1   1 _1  0   1  1  1
+       2   1 _1  1   1  0 _1
+)
+   TPF=. 0 ; 0 ; 1            NB. Setting the tape, its pointer and the display frequency
+
+   TPF utm QS                 NB. Running the Turing machine...
+0 0:0
+0  :^
+1 0:10
+1  : ^
+0 1:11
+2  :^
+2 0:011
+3  :^
+1 0:0111
+4  :^
+0 0:01111
+5  :^
+1 1:11111
+6  : ^
+1 1:11111
+7  :  ^
+1 1:11111
+8  :   ^
+1 1:11111
+9  :    ^
+1 0:111110
+10 :     ^
+0 1:111111
+11 :    ^
+2 1:111111
+12 :   ^
+2 1:111111
+13 :   ^

Task/Universal-Turing-machine/J/universal-turing-machine-4.j

@@ -0,0 +1,21 @@
+   NB. Sorting stress test...
+   NB.        0         1         2         3     Tape Symbol Scan
+   NB. S   p  m  g   p  m  g   p  m  g   p  m  g  (p,m,g) ➜ (print,move,goto)
+   QS=. (noun _) ; 0          NB. Reading the transition table and setting the initial state
+       0   0 _1  4   1  1  0   3  1  1   _  _  _
+       1   0 _1  2   1  1  1   2  1  1   _  _  _
+       2   _  _  _   2 _1  3   2 _1  2   2 _1  4
+       3   _  _  _   1 _1  3   2 _1  3   1  1  0
+       4   0  1 _1   1 _1  4   _  _  _   _  _  _
+)
+   TPF=. 1 2 2 1 2 2 1 2 1 2 1 2 1 2 ; 0 ; 50   NB. Setting the tape, its pointer and the display frequency
+
+   TPF utm QS                 NB. Running the Turing machine...
+0 1:12212212121212
+0  :^
+3 2:113122121222220
+50 :    ^
+1 2:111111322222220
+100:            ^
+4 0:0111111222222220
+118: ^

Task/Universal-Turing-machine/J/universal-turing-machine-5.j

@@ -0,0 +1,70 @@
+   NB. Structured derivation of the universal Turing machine...
+
+   o=. @:        NB. Composition of verbs (functions)
+   c=. "_        NB. Constant verb (function)
+   f=. &{::      NB. fetch
+   e=. <@:       NB. enclose
+
+   NB. utm (dyadic verb)...
+
+   'Q S T P F B M PRINT MOVE C'=. i.10 NB. Using 10 boxes
+     NB. Left:  Q     - Instruction table,  S - Turing machine state
+     NB. Right: T     - Data tape,          P - Head position pointer,       F     - Display frequency
+     NB. Local: B     - Blank defaults,     M - State and tape symbol read,  PRINT - Printing symbol
+     NB.        MOVE  - Tape head moving instruction,                        C     - Step Counter
+
+   DisplayTape=. > o (((48 + ]) { a.c)@[ ; ((] $ ' 'c) , '^'c))
+   display=. ((((": o (]&:>) o (M f)) ,: (":@] C f)) ,. ':'c ) ,. (T f DisplayTape P f))
+     NB. Displaying state, symbol, tape / step and pointer
+   amend=. 0: (0 f)@]`(<@(1 f)@])`(2 f@])} ]
+
+   NB. execute (monadic verb)...
+
+   FillLeft=.  (_1   = P f      ) {:: B f      NB. Expanding and filling the tape
+   FillRight=. ( P f = # o (T f)) {:: B f      NB. with 0's (if necessary)
+   ia=. <@[ { ]                                NB. Selecting by the indices of an array
+
+   e0=. (FillLeft , T f , FillRight)e T}]      NB. Adjusting the tape
+   e1=. (P f + _1 = P f)e P}]                  NB. and the pointer (if necessary)
+   e2=. (S f ; P f { T f)e M}]                 NB. Updating the state and reading the tape symbol
+   e3=. [(smoutput o display)^:(0 = F f | C f) NB. Displaying intermediate cycles		       	
+   e4=. (<"0 o (M f ia Q f)) (PRINT,MOVE,S)}]  NB. Performing the printing, moving and state actions
+   e5=. (amend o ((PRINT,P,T)&{))e T}]         NB. Printing symbol on tape at the pointer position
+   e6=. ((P f + MOVE f) ; 1 + C f) (P,C)}]     NB. Updating the pointer (and the counter)
+
+   execute=. e6 o e5 o e4 o e3 o e2 o e1 o e0
+
+   al=. &(] , (a: $~ [))                       NB. Appending local boxes
+   cc=. 'A changeless cycle was detected!'c
+   halt=. _1 c = S f                           NB. Halting when the current state is _1
+   rt=. ((({. , ({: % 3:) , 3:) o $) $ ,) o (}."1) o (". ;. _2)
+     NB. Reshaping the transition table as a 3D array (state,symbol,action)
+
+   m0=. ,~                                     NB. Dyadic form (e.g., TPF f TuringMachine QS f )
+   m1=. 5 al                                   NB. Appending 5 local boxes (B,M,PRINT,MOVE,C)
+   m2=. ('' ; 0 c)e B}]                        NB. Initializing local B (empty defaults as 0)
+   m3=. (0 ; rt o (Q f)) (C,Q)}]               NB. Setting (the counter and) the transition table
+   m4=. execute^:(-. o halt)^:_                NB. Executing until a halt instruction is issued
+   m5=. [smoutput o cc ^: (-. o halt)          NB. or a changeless single cycle is detected
+   m6=. display                                NB. Displaying (returning) the final status
+
+   utm=. m6 o m5 o m4 o m3 o m2 o m1 o m0 f.   NB. Fixing the universal Turing machine code
+
+   lr=. 5!:5@< NB. Linear representation
+
+   q: o $      o lr'utm'                       NB. The fixed tacit code length factors
+2 2 3 71
+
+   (12 71 $ ]) o lr'utm'                       NB. The fixed tacit code...
+(((":@:(]&:>)@:(6&({::)) ,: (":@] 9&({::))) ,. ':'"_) ,. 2&({::) >@:(((
+48 + ]) { a."_)@[ ; (] $ ' '"_) , '^'"_) 3&({::))@:([ (0 0 $ 1!:2&2)@:(
+'A changeless cycle was detected!'"_)^:(-.@:(_1"_ = 1&({::))))@:((((3&(
+{::) + 8&({::)) ; 1 + 9&({::)) 3 9} ])@:(<@:((0: 0&({::)@]`(<@(1&({::))
+@])`(2&({::)@])} ])@:(7 3 2&{)) 2} ])@:(<"0@:(6&({::) (<@[ { ]) 0&({::)
+) 7 8 1} ])@:([ (0 0 $ 1!:2&2)@:(((":@:(]&:>)@:(6&({::)) ,: (":@] 9&({:
+:))) ,. ':'"_) ,. 2&({::) >@:(((48 + ]) { a."_)@[ ; (] $ ' '"_) , '^'"_
+) 3&({::))^:(0 = 4&({::) | 9&({::)))@:(<@:(1&({::) ; 3&({::) { 2&({::))
+ 6} ])@:(<@:(3&({::) + _1 = 3&({::)) 3} ])@:(<@:(((_1 = 3&({::)) {:: 5&
+({::)) , 2&({::) , (3&({::) = #@:(2&({::))) {:: 5&({::)) 2} ])^:(-.@:(_
+1"_ = 1&({::)))^:_)@:((0 ; (({. , ({: % 3:) , 3:)@:$ $ ,)@:(}."1)@:(".;
+._2)@:(0&({::))) 9 0} ])@:(<@:('' ; 0"_) 5} ])@:(5&(] , a: $~ [))@:(,~)

Task/Universal-Turing-machine/Racket/universal-turing-machine-1.rkt

@@ -0,0 +1,96 @@
+#lang racket
+;;;=============================================================
+;;; Due to heavy use of pattern matching we define few macros
+;;;=============================================================
+
+(define-syntax-rule (define-m f m ...)
+  (define f (match-lambda m ... (x x))))
+
+(define-syntax-rule (define-m* f m ...)
+  (define f (match-lambda** m ...)))
+
+;;;=============================================================
+;;; The definition of a functional type Tape,
+;;; representing infinite tape with O(1) operations:
+;;; put, get, shift-right and shift-left.
+;;;=============================================================
+(struct Tape (the-left-part      ; i-1 i-2 i-3 ...
+              the-current-record ; i
+              the-right-part))   ; i+1 i+2 i+3 ...
+
+;; the initial record on the tape
+(define-m initial-tape
+  [(cons h t) (Tape '() h t)])
+
+;; shifts caret to the right
+(define (snoc a b) (cons b a))
+(define-m shift-right
+  [(Tape '() '() (cons h t)) (Tape '() h t)]      ; left end
+  [(Tape  l x '()) (Tape (snoc l x) '() '())]     ; right end
+  [(Tape  l x (cons h t)) (Tape (snoc l x) h t)]) ; general case
+
+;; shifts caret to the left
+(define-m flip-tape [(Tape l x r) (Tape r x l)])
+
+(define shift-left
+  (compose flip-tape shift-right flip-tape))
+
+;; returns the current record on the tape
+(define-m get [(Tape _ v _) v])
+
+;; writes to the current position on the tape
+(define-m* put
+  [('() t) t]
+  [(v (Tape l _ r)) (Tape l v r)])
+
+;; Shows the list representation of the tape (≤ O(n)).
+;; A tape is shown as (... a b c (d) e f g ...)
+;; where (d) marks the current position of the caret.
+
+(define (revappend a b) (foldl cons b a))
+
+(define-m show-tape
+  [(Tape '() '() '()) '()]
+  [(Tape l '() r) (revappend l (cons '() r))]
+  [(Tape l v r) (revappend l (cons (list v) r))])
+
+;;;-------------------------------------------------------------------
+;;; The Turing Machine interpreter
+;;;
+
+;; interpretation of output triple for a given tape
+(define-m* interprete
+  [((list v 'right S) tape) (list S (shift-right (put v tape)))]
+  [((list v 'left S) tape) (list S (shift-left (put v tape)))]
+  [((list v 'stay S) tape) (list S (put v tape))]
+  [((list S _) tape) (list S tape)])
+
+;; Runs the program.
+;; The initial state is set to start.
+;; The initial tape is given as a list of records.
+;; The initial position is the leftmost symbol of initial record.
+(define (run-turing prog t0 start)
+  ((fixed-point
+    (match-lambda
+      [`(,S ,T) (begin
+                  (printf "~a\t~a\n" S (show-tape T))
+                  (interprete (prog `(,S ,(get T))) T))]))
+   (list start (initial-tape t0))))
+
+;; a general fixed point operator
+(define ((fixed-point f) x)
+  (let F ([x x] [fx (f x)])
+    (if (equal? x fx)
+        fx
+        (F fx (f fx)))))
+
+;; A macro for definition of a Turing-Machines.
+;; Transforms to a function which accepts a list of initial
+;; tape records as input and returns the tape after stopping.
+(define-syntax-rule (Turing-Machine #:start start (a b c d e) ...)
+  (λ (l)
+    (displayln "STATE\tTAPE")
+    ((match-lambda [(list _ t) (flatten (show-tape t))])
+     (run-turing
+      (match-lambda ['(a b) '(c d e)] ... [x x])
+      l start))))

Task/Universal-Turing-machine/Racket/universal-turing-machine-2.rkt

@@ -0,0 +1,4 @@
+(define INC
+  (Turing-Machine #:start 'q0
+    [q0 1 1 right q0]
+    [q0 () 1 stay qf]))

Task/Universal-Turing-machine/Racket/universal-turing-machine-3.rkt

@@ -0,0 +1,8 @@
+(define ADD1
+  (Turing-Machine #:start 'Start
+   [Start 1  1  right Start]
+   [Start 0  0  right Start]
+   [Start () () left  Add]
+   [Add   0  1  stay  End]
+   [Add   1  0  left  Add]
+   [Add   () 1  stay  End]))

Task/Universal-Turing-machine/Racket/universal-turing-machine-4.rkt

@@ -0,0 +1,8 @@
+(define BEAVER
+  (Turing-Machine #:start 'a
+   [a () 1 right b]
+   [a  1 1 left  c]
+   [b () 1 left  a]
+   [b  1 1 right b]
+   [c () 1 left  b]
+   [c  1 1 stay  halt]))

Task/Universal-Turing-machine/Racket/universal-turing-machine-5.rkt

@@ -0,0 +1,16 @@
+(define SORT
+  (Turing-Machine #:start 'A
+   [A 1  1  right A]
+   [A 2  3  right B]
+   [A () () left  E]
+   [B 1  1  right B]
+   [B 2  2  right B]
+   [B () () left  C]
+   [C 1  2  left  D]
+   [C 2  2  left  C]
+   [C 3  2  left  E]
+   [D 1  1  left  D]
+   [D 2  2  left  D]
+   [D 3  1  right A]
+   [E 1  1  left  E]
+   [E () () right STOP]))