■ - fortran66のブログ

Ｒ・ペンローズ著『皇帝の新しい心』第二章より。万能チューリング機械。

入力ファイル turing2.lst からチューリング機械の定義とそれが作用する対象の、二つが書かれている 0,1 の文字列（テープ）を読み込んで実行する。チューリング機械の定義とそれが作用する対象の区切りは 111110 としている。（前後に付いている 0 は今は意味を持たない。）

チューリング機械の定義の詳細は『皇帝の新しい心』を読んでください(^^;

実行例１

1を足すチューリング機械 UN+1 の定義の後、区切り文字 111110、そして３を表す 111 を書いた turing2.lst が入力の場合。出力は４すなわち 1111 となる。

101011010111101010
111110
111

実行例２

万能チューリング機械の定義のあと、実行例１のチューリング機械を入力として与える。
つまり Fortran で書かれた万能チューリング機械上で、万能チューリング機械のプログラムが動作して、実行例１と同じく３＋１を計算する。

100000000101110100110100010010101011010001101000101000001101010011010001010100
101101000011010001010010101101001001110100101001001011101010001110101010010010
101110101010011010001010001010110100000110100100000101011010001001110100101000
010101110100100011101001010100001011101001010011010000100001110101000011101010
000100100111010001010101101010010101101000001101010100101101001001000110100000
000110100000011101010010101010111010000100111010010101010101010111010000101010
111010000101000101110100010100110100100001010011010010100100110100100010110101
000101110100100101011101001010001110101001010010011101010101000011010010101010
111010100100010110101000010110101000100110101010101000101101001010100100101101
010010010111010101001010111010100101001101010100001110100010010010101110101010
010101110101010000011101010010000011010101010010111010100101011010001001000111
010000000111010010100101010101110100101001001010111010000010101110100001000111
010000010101001110100001010011101000001000101110100010000111010000100101001110
100010000101101000101001011101000101001011010010000010110100010101001001101000
101010101110100100000111010010010101010111010101010011010010001010110100100100
101101000000010110100000100011010000010010110100000000011010010100010111010010
101000110100101001010110100000100111010010101001011010010011101010000001010111
010100000011010101000101010110100101010110101000010101110101001001010111010100
010010110101001000010111010000001110101001000101101010010100110101010001011101
010010100101110101010000010111010101000001011101000000111010101000010101110100
101010110101010000101110101000101010111010101001001011101010101000011101010000
000111010010010000110100100100010110101010101001110100000000101101001000011010
101010100101110100100001101001000101010111010000100011101000100001110100001101
000000010110100000100101110101010010101011010001000100101110100000100111010101
001101000001010101101000010000111010010000100011101010101010100111010000100100
111010001001000011101000010100101101000010100001110101010101010111010001001001
101000100100110101001010010111010001000101011101000000011101000100100101110100
110100100100001011010101010011010001010001011101000011010100001000101101010011
010101001010010110101010011010010010101110100110100100000101101000101010100011
101001000010101101000000100110100100010010111010010000110101000001001011101001
001010011010010010101011010011010010010100101101001101001010000010110100100000
111010100100110101010100001011101001010000101110100101010101110101000100101101
001001110100101010001011101000100111010100001011010010011101001010101010111010
010001110100101010100101110100100011101010000010101011100110101000001011010010
011101010000001011101001011010100000101011010010100101110101000010010111010000
110101000100001011010100110101000100010110101010100101110101000101001011010001
010101011101001000010101101010001011101010010010101011101010100100101110101000
111010100011101010010010010111010100011101010010100010111010100010111010100001
001011101010001110100010100010111010010100101110101001010100101110100101010101
010110101000010101010110100001001110100001010101010111010101000101011101010100
010101110100000011101010100010010111010000001110101010010001011101010000001101
010000101101000000111010010000001011101010001110101001000101011101010011010101
010001010110100000110101010100101010110100000010011010101010010011101010011010
101010010010110101001101001001001110100000110101010101001010110101000100110100
010100101010111010000011010101010101001011010001000111010001010101010101101000
100011101000010101110100010010000111010011010000000100111010000001001011101000
100010100111010000001001011101001010101010010110100001010101011101000100101001
011101000001000101110101010010110100010001001110100000100101011101000000101010
110100001000111001111010000100000111010000100100111010000010100101110100000101
001011010000100010101110100001000100110100010000111010111101000010010010111010
000100100101110100000001010111010000101010001101000100101110100001000001110100
001001110100010000010111010101001011010001000001011101000010101010111010000001
010101110100010000101011101000100001010111010010000011101010010010011010000001
010111010001000100101110101010000111010100101011010010101010000110100000101001
101000000011101000001001001110100101101001000101001011010101001101000101001001
011010101001101000101010001011001101010010010111010101001101000101010101011001
101010001010101100110100100010101010111010001000111010010010101010101101001010
010100011010010000001011101000001101010100101010101101001010101101001000100010
111010001010101101010000010101101000100000110100100010101101000010011101010010
101010101110100101101001001000101011001101001001001010101110100110100100100101
011010010110100100100100101101001011010010010100010110011010010010100101011101
000101011101001001011100110100100101010010111001101001010001010101110100010001
110100001010010110100101000101110100101000101011010001001110100101000100101110
100010011101001010010001011100110100100010001110100010011101001010010101011100
110100101000001110011010101010101101000000011101001010100101010111010010001110
100101010010101110011010000101001001100110101000001101000000011101001010101001
010111001101010001000011010000000111010001001010101011101000100011101010101010
101010110100001001110100100010010101110100101010001001101010000000101101001001
110101000010101110100100001101010000000101101001000111010100100101110100001101
010000101010110101000101110101000010100101110101000101110101000101010101110011
01010001010110100001101010001001010
111110
101011010111101010
111110
111

MODULE m_op
IMPLICIT NONE
TYPE :: t_instruction
 INTEGER :: new_state, new_mark, idirection
END TYPE
INTEGER :: ipos = 1, iops = 0
TYPE (t_instruction), ALLOCATABLE :: ops(:)
CONTAINS
!----------------------------------------
SUBROUTINE push_op(new_state, new_mark, idirection)
IMPLICIT NONE
INTEGER, INTENT(IN) :: new_state, new_mark, idirection
iops = iops + 1
ops(iops) = t_instruction(new_state, new_mark, idirection)
RETURN
END SUBROUTINE push_op
!----------------------------------------
SUBROUTINE alloc_ops(n)
IMPLICIT NONE
INTEGER, INTENT(IN) :: n
ALLOCATE(ops(n))
RETURN
END SUBROUTINE alloc_ops
!----------------------------------------
SUBROUTINE decode_op(text, istate, itape, idirec, eop)
IMPLICIT NONE
CHARACTER (LEN = *), INTENT(IN) :: text
INTEGER            , INTENT(OUT):: istate, itape, idirec
LOGICAL            , INTENT(OUT):: eop
INTEGER :: k
k = 0
eop = .FALSE.
DO
 IF       (TEXT(ipos:ipos)    == '0') THEN ! 0
  k = 2 * k
  ipos = ipos + 1
  CYCLE
 ELSE IF (TEXT(ipos:ipos + 1) == '10') THEN ! 1
  k = 2 * k + 1
  ipos = ipos + 2
  CYCLE
 ELSE IF (TEXT(ipos:ipos + 2) == '110') THEN ! R
  idirec = +1
  ipos = ipos + 3
 ELSE IF (TEXT(ipos:ipos + 3) == '1110') THEN ! L
  idirec = -1
  ipos = ipos + 4
 ELSE IF (TEXT(ipos:ipos + 4) == '11110') THEN ! STOP
  idirec = 0
  ipos = ipos + 5
 ELSE IF (TEXT(ipos:ipos + 5) == '111110') THEN ! R + end of ops.
  eop = .TRUE.
  idirec = 1
  ipos = ipos + 6
 ELSE IF (TEXT(ipos:ipos + 6) == '1111110') THEN ! L + end of ops.
  eop = .TRUE.
  idirec = -1
  ipos = ipos + 7
 ELSE IF (TEXT(ipos:ipos + 6) == '11111110') THEN ! STOP + end of ops.
  idirec = 0
  ipos = ipos + 8
 ELSE
  STOP 'ERROR: cannot decode ops!'
 END IF
 EXIT
END DO
istate = k / 2
itape  = MOD(k, 2)
RETURN
END SUBROUTINE decode_op
!----------------------------------------
INTEGER FUNCTION iget_pos()
IMPLICIT NONE
iget_pos = ipos
RETURN
END FUNCTION iget_pos
!----------------------------------------
SUBROUTINE decode_ops(tape)
IMPLICIT NONE
CHARACTER (LEN = *), INTENT(IN) :: tape
INTEGER, PARAMETER :: maxop = 1000
INTEGER :: istate, itape, idirection
LOGICAL :: qend
CALL alloc_ops(maxop)
CALL push_op(B'00', 0, +1) ! 00R
DO
 CALL decode_op(tape, istate, itape, idirection, qend)
 CALL push_op(istate, itape, idirection)
 IF (qend) EXIT
END DO
RETURN
END SUBROUTINE decode_ops
!----------------------------------------
END MODULE m_op
!==============================================
MODULE m_turing
USE m_op
IMPLICIT NONE
PRIVATE
PUBLIC :: alloc_ops, push_op, decode_ops, iget_pos
PUBLIC :: turing, punch_tape, dump_tape, load_tape
INTEGER, PARAMETER :: max_t = 25000
INTEGER :: itape(-max_t:max_t)
CONTAINS
!----------------------------------------
SUBROUTINE turing()
IMPLICIT NONE
TYPE :: t_turingmachine
 INTEGER :: ipos, istate
END TYPE
TYPE (t_turingmachine) :: tm
INTEGER :: iop
tm = t_turingmachine(0, 0)
DO
 iop = 2 * tm%istate + itape(tm%ipos) + 1
 itape(tm%ipos)    = ops(iop)%new_mark
 tm%istate         = ops(iop)%new_state
 tm%ipos = tm%ipos + ops(iop)%idirection
 IF (ops(iop)%idirection == 0) EXIT
 IF (ABS(tm%ipos) > max_t) STOP 'Out of Tape!'
END DO
WRITE(*, *) 'Normal STOP!'
CALL dump_tape(isearch(), tm%ipos)
RETURN
CONTAINS
!-----------------------------
 INTEGER FUNCTION isearch
 INTEGER :: k
 isearch = tm%ipos
 DO k = -max_t, tm%ipos
 IF (itape(k) /= 1) CYCLE
 isearch = k - 3
 EXIT
 END DO
 RETURN
 END FUNCTION isearch
!-----------------------------
END SUBROUTINE turing
!----------------------------------------
SUBROUTINE punch_tape(text)
IMPLICIT NONE
CHARACTER (LEN = *), INTENT(IN) :: text
INTEGER :: i
CHARACTER :: ch
itape = 0
DO i = 1, LEN_TRIM(text)
 ch = text(i:i)
 IF (ch /= '0' .AND. ch /= '1') THEN
 WRITE(*, *) 'tape error'
 STOP
 END IF
 READ(ch, '(i1)') itape(i)
END DO
RETURN
END SUBROUTINE punch_tape
!----------------------------------------
SUBROUTINE dump_tape(n0, n1)
IMPLICIT NONE
INTEGER, INTENT(IN) :: n0, n1
WRITE(*, '(79I1.1:)') itape(n0:n1)
RETURN
END SUBROUTINE dump_tape
!--------------------------------------------
SUBROUTINE load_tape(text)
CHARACTER (LEN = *), INTENT(INOUT) :: text
CHARACTER (LEN = 132) :: buff
INTEGER :: i, io
OPEN(10, file = 'turing2.lst')
DO
 buff = ''
 READ(10, '(a)',IOSTAT = io) buff
 text = TRIM(text) // TRIM(buff)
 IF (io == -1) EXIT
END DO
RETURN
END SUBROUTINE load_tape
!--------------------------------------------
END MODULE m_turing
!========================================================
PROGRAM Universal_turing_machine
USE m_turing
IMPLICIT NONE
CHARACTER (LEN = 20000) :: text = ''
CALL load_tape(text)
CALL decode_ops(text)
CALL punch_tape(text(iget_pos():))
CALL dump_tape(1, 40)
!
CALL turing()
!
STOP
END PROGRAM Universal_turing_machine

あまり考えてない、無駄を省いていない。