A Turing Machine

Source-code only - please, don't post questions here.
Zamaster
Posts: 1020
Joined: Jun 20, 2005 21:40
Contact:

A Turing Machine

Postby Zamaster » Jun 24, 2007 2:00

Hezad inspired me to make a real Turing machine. Check it out, its pretty cool how you write programs for it!

Code: Select all


Const TapeLength AS UINTEGER = 256


Dim shared as string*1 CharConversion(1 to 3, 1 to 2)
CharConversion(1,1) = "X": CharConversion(1,2) = CHR$(255)
CharConversion(2,1) = "1": CharConversion(2,2) = CHR$(1)
CharConversion(3,1) = "_": CharConversion(3,2) = CHR$(0)


Type TapeT
    as ubyte SYMBOL
End Type
Type TuringProgram
    as string   TName
    as TapeT    Tape(1 to TapeLength)
    as string   Quintuples
    as uinteger HeadStart
End Type

Function CreateProgram(nme      as string, strtw        as uinteger ,_
                       sdat     as string, Instructions as string   ,_
                       HeadStrt as uinteger) as TuringProgram
    Dim as TuringProgram TP
    TP.TName      = nme
    TP.HeadStart  = HeadStrt
    TP.Quintuples = Instructions
    Dim as integer i, xs
    strtw -= 1
    For i = 1 to LEN(sdat)
        For xs = 1 to 3
            If CharConversion(xs,1) = MID$(sdat, i, 1) Then
                TP.Tape(strtw+i).SYMBOL = ASC(CharConversion(xs,2))
                Exit For
            Endif
        Next xs
    Next i
    Return TP
End Function

Sub SetTape(byref TP as TuringProgram, strtw as uinteger, sdat as string)
    Dim as integer i, xs
    For i = 1 to TapeLength
        TP.Tape(i).SYMBOL = 0
    Next i
    strtw -= 1
    For i = 1 to LEN(sdat)
        For xs = 1 to 3
            If CharConversion(xs,1) = MID$(sdat, i, 1) Then
                TP.Tape(strtw+i).SYMBOL = ASC(CharConversion(xs,2))
                Exit For
            Endif
        Next xs
    Next i
End Sub


Sub DrawTape(x as uinteger, y as uinteger, TP as TuringProgram, head as uinteger, spread as uinteger, height as uinteger)
    Dim as integer i, bx, x1, x2, ys, ye, col, cnt
    bx = spread * 2
    ys = y+1
    ye = y + height
    Line (x,y)-(x+bx+8,ye+1), &HFFAFAF, B
    x1 = x+1: x2 = x + spread
    cnt = head - spread
    For i = x1 to x2
        col = TP.Tape(cnt).SYMBOL
        If col = 0 Then
            col = &H404040
        Elseif col = 255 Then
            col = &H7F7F7F
        Else
            col = &HFFFFFF
        Endif
        Line (i,ys)-(i,ye), col
        cnt += 1
    Next i
    Line (x2+1,ys)-(x2+1,ye), &HFFAFAF
    col = TP.Tape(head).SYMBOL
    If col = 0 Then
        col = &H404040
    Elseif col = 255 Then
        col = &H7F7F7F
    Else
        col = &HFFFFFF
    Endif
    Line (x2+2,ys)-(x2+5,ye), col, BF
    Line (x2+6,ys)-(x2+6,ye), &HFFAFAF
    x1 = x+7+spread: x2 = x1 + spread
    cnt = head+1
    For i = x1 to x2
        col = TP.Tape(cnt).SYMBOL
        If col = 0 Then
            col = &H404040
        Elseif col = 255 Then
            col = &H7F7F7F
        Else
            col = &HFFFFFF
        Endif
        Line (i,ys)-(i,ye), col
        cnt += 1
    Next i
End Sub

Type FQ
    as uinteger strt
    as ubyte readt
    as ubyte writet
    as byte dire
    as integer ed
End Type

Sub RunProgram(byref TP as TuringProgram, dw as uinteger = 0, dl as uinteger = 0)
    Dim as uinteger MaxQuints, i, cnt, bse
    For i = 1 to LEN(TP.Quintuples)
        If MID$(TP.Quintuples, i, 1) = ";" Then MaxQuints += 1
    Next i
    MaxQuints += 1
    Dim as FQ     Quints(1 to MaxQuints)
    Dim as string char, tmp
    Dim as ubyte  asci
    bse = 1
    For i = 1 to MaxQuints
        bse += cnt
        cnt  = 0
        tmp  = ""
        Do
            char = MID$(TP.Quintuples, bse+cnt, 1)
            asci = ASC(char)
            If asci >= 48 And asci <= 57 Then
                tmp += char
            Else
                Exit Do
            Endif
            cnt += 1
        Loop
        cnt += 1
        Quints(i).strt = VAL(tmp)
        char = MID$(TP.Quintuples, bse+cnt, 1)
        If char = CharConversion(1,1) Then
            Quints(i).readt = ASC(CharConversion(1,2))
        Elseif char = CharConversion(2,1) Then
            Quints(i).readt = ASC(CharConversion(2,2))
        Else
            Quints(i).readt = ASC(CharConversion(3,2))
        Endif
        cnt += 1
        char = MID$(TP.Quintuples, bse+cnt, 1)
        If char = CharConversion(1,1) Then
            Quints(i).writet = ASC(CharConversion(1,2))
        Elseif char = CharConversion(2,1) Then
            Quints(i).writet = ASC(CharConversion(2,2))
        Else
            Quints(i).writet = ASC(CharConversion(3,2))
        Endif
        cnt += 1
        char = MID$(TP.Quintuples, bse+cnt, 1)
        If char = "R" Then
            Quints(i).dire = 1
        Elseif char = "L" then
            Quints(i).dire = -1
        Else
            Quints(i).dire = 0
        Endif
        cnt += 1
        char = MID$(TP.Quintuples, bse+cnt, 1)
        tmp  = ""
        Do
            char = MID$(TP.Quintuples, bse+cnt, 1)
            If char = "?" Then
                tmp = "-1"
                cnt += 1
                Exit Do
            Endif
            asci = ASC(char)
            If asci >= 48 And asci <= 57 Then
                tmp += char
            Else
                Exit Do
            Endif
            cnt += 1
            If bse+cnt > Len(TP.Quintuples) Then Exit Do
        Loop
        Quints(i).ed = VAL(tmp)
        cnt += 1
    Next i
    Dim as uinteger h, r, s
    h = TP.HeadStart
    s = 0
    Do
        r = TP.Tape(h).SYMBOL
        For i = 1 to MaxQuints
            If Quints(i).strt = s And Quints(i).readt = r Then
                TP.Tape(h).SYMBOL = Quints(i).writet
                h += Quints(i).dire
                s = Quints(i).ed
                If s = -1 Then Goto Finish
                i = 0
                Exit For
            Endif
        Next i
        If i = MaxQuints Then Goto Finish
        If dw <> 0 Then
            DrawTape 50,90,TP,h,100,50
            Locate 9,1: Print "Tape Head:";h
            sleep dl
        Endif
    Loop
    Finish:
    h = TP.HeadStart
    If dw <> 0 Then
        DrawTape 50,90,TP,h,100,50
        sleep dl
    Endif
End Sub

'--------------------------------------MAIN--------------------------------



screenres 320,240,32

Dim as string Prog
Dim as TuringProgram BinaryAdd, IsPrime

Print "1 = White"
Print "X = Grey"
Print "0 = Dark Grey"
Print
Print "Press a key to begin..."
sleep
cls


Prog = "0|__R0;0|11R1;0|XXR2;1|__R1;1|11R3;1|XXR4;2|__R2;2|11R4;2|XXR?;3|__R3;3|11R3;3|X_R?;4|__R4;4|11R4;4|X1R?"

BinaryAdd = CreateProgram("Binary Addition", 121, "1_X_X", Prog, 120) '1 + 0 = 1!

Print "Example Of Binary Addition"
Print
Print "This program overflow Adds together the first two cells to the right of the tapehead. The result is stored" +_
      " in the last  or third cell. This adds 1 + 0 to get 1"
RunProgram BinaryAdd, 1, 50
sleep
cls

Prog = "0|__L1;0|1_L1;0|X_L1;1|_1L2;1|11L2;1|X1L2;2|_1R3;2|11R3;2|X1R3;3|__N4;3|11R3;3|XXR3;4|__R5;4|11R4;"     +_
       "4|XXR4;5|__L6;5|11L7;5|XXR5;6|_XL18;6|11L6;6|X1L6;7|__L8;7|11L7;7|XXL7;8|__R12;8|1XR9;8|XXL8;9|__R10;"  +_
       "9|11R9;9|XXR9;10|__L13;10|1XL11;10|XXR10;11|__L8;11|11L11;11|XXL11;12|__R5;12|11R12;12|X1R12;13|__L14;" +_
       "13|11L13;13|X1L13;14|__R15;14|11L14;14|X1L14;15|__L16;15|11R15;15|X1R15;16|_1R17;16|11L16;16|XXN16;"    +_
       "17|__N4;17|11R17;17|XXN17;18|__R20;18|11L18;18|XXL18;19|__L21;19|11R19;19|XXR19;20|__N20;20|1_R19;"     +_
       "20|XXR22;21|__N21;21|1_L18;21|XXN21;22|__L?;22|11L23;22|XXN22;23|__N23;23|11N23;23|X_N?"         

IsPrime = CreateProgram("Primality Test", 121, "1111111", Prog, 120) 'The number 7!

Print "Example of Primality Testing"
Print
Print "If the number of 1's to the right of thetape head is prime, an X or value of 0  will be placed in the" +_
      "position where the tape head started. This tests the number7. Ending on an X means prime."



RunProgram IsPrime, 1, 10
sleep
end




Like The traveling salesman demo, its pretty.
Hezad
Posts: 469
Joined: Dec 17, 2006 23:37
Contact:

Postby Hezad » Jun 24, 2007 22:34

ouch, nice !

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 0 guests