program Tic_Tac_Toe_4x4x4

  implicit NONE

  integer :: A, B, I, K1, K2, K3, M1, M2, M3, N

  integer :: R(304) = (/ &
    22,43,64, 1,23,42,61, 4,26,39,52,13,27,38,49,16,22,42,62, 2, & ! 001:020
    23,43,63, 3,23,38,53, 8,27,42,57,12,26,38,50,14,27,39,51,15, & ! 021:040
    22,39,56, 5,26,43,60, 9,22,38,54, 6,23,39,55, 7,26,42,58,10, & ! 041:060
    27,43,59,11,22,23,24,21,26,27,28,25,22,26,30,18,23,27,31,19, & ! 061:080
    22,27,32,17,23,26,29,20,38,39,40,37,42,43,44,41,38,42,46,34, & ! 081:100
    39,43,47,35,38,43,48,33,39,42,45,36,61, 1,21,41,64, 4,24,44, & ! 101:120
    49, 4,19,34,61,16,31,46,49,13,25,37,52,16,28,40,52, 1,18,35, & ! 121:140
    64,13,30,47,49, 1,17,33,52, 4,20,36,61,13,29,45,64,16,32,48, & ! 141:160
     4, 1, 2, 3,16,13,14,15,13, 1, 5, 9,16, 4, 8,12,16, 1, 6,11, & ! 161:180
    13, 4, 7,10,52,49,50,51,64,61,62,63,61,49,53,57,64,52,56,60, & ! 181:200
    64,49,54,59,61,52,55,58,18,34,50, 2,19,35,51, 3,21,37,53, 5, & ! 201:220
    24,40,56, 8,25,41,57, 9,28,44,60,12,30,46,62,14,31,47,63,15, & ! 221:240
     6, 7, 8, 5,10,11,12, 9, 6,10,14, 2, 7,11,15, 3,18,19,20,17, & ! 241:260
    30,31,32,29,21,25,29,17,24,28,32,20,34,35,36,33,46,47,48,45, & ! 261:280
    37,41,45,33,40,44,48,36,54,55,56,53,58,59,60,57,54,58,62,50, & ! 281:300
    55,59,63,51 /) ! 301:304
  integer :: T(3,14) = reshape( &
    (/ 4,-1,-1,15,-1,-1,3,-1,-1,10,10,-1,10,5,10,2,2,-1,2,1,2, &
     & 2,1,1,2,0,2,5,5,10,5,5,5,5,0,10,5,0,5,-1,-1,-1 /), (/3,14/) )
  integer :: W(20) = &
    (/ 22,43,23,42,26,39,27,38,1,64,13,52,4,61,16,49,22,43,23,42 /)

  integer :: M(64),L(4),S(76)

  character(80) :: Answer, Name

1 format ( a )
  print 1, 'This is the game of three-dimensional tic-tac-toe.'
  print 1, 'My board consists of 4 levels, 4 rows and 4 columns.'
  if ( yes_or_no ( 'Would you like instructions? ' ) ) then
    print 1, 'The object of the game is to get 4 squares in either'
    print 1, 'a vertical, horizontal or diagonal line.  To select a '
    print 1, 'square, give its location.'
    print 1, 'Example-- 243 would be for the second level, 4th row, 3rd '
    print 1, 'column.  To have me move first, type 000 for your first move.'
    print 1, 'To restart a game in the middle of another, type a negative'
    print 1, 'number in for your move.  To get off the computer, type 999.'
  end if

2 print 1, 'What is your name? '
  read ( *, 1, end=9 ) name

3 continue ! new game
  ! K1 indicates the wait list, initialize K1 = 1
  k1 = 1
  ! Clear the board
  M = 0
4 print 1
  print 1, 'Type in your move ' // trim(name)
  read ( *, *, end=9 ) n
  print '( a, i0 )', 'Your move is ', n

  if ( n<0 ) then
    print 1, 'Restarting new game'
    go to 3
  end if

  if ( n >= 999 ) go to 8

  if ( n /= 0 ) then

  ! Convert move to code (1-64) and check range
    k3 = mod(n,10)
    k2 = mod(n/10,10)
    k1 = n / 100
    if ( k1<=0 .or. k1>4 .or. k2<=0 .or. k2>4 .or. k3<=0 .or. k3>4 ) then
      print 1, 'Stop trying to cheat, put in a legitimate move!'
      go to 4
    end if

    n = 16*(k1-1)+4*(k2-1)+k3
    if ( m(n) > 0 ) then
      print 1, 'Hey, that square is already taken, jerk!'
      go to 4
    end if

    m(n)=1
  end if

! Call sub. for situation analysis, m1=best move, m2=alternate
! m3 is the situation level
  call situation_analysis

  if ( m3 <= 2 ) then
    k3 = 4*(m1-1)
    do i = 1, 4
      k2 = i + k3
      a = r(k2)
      b = l(i)
      call encode
      r(k2) = a
      l(i) = b
    end do

    if ( m3 <= 1 ) then
      print '(a,4i0)', 'You just won on ', l
      print 1, 'You must have cheated'
      go to 8
    end if

    print' (a,(i4))', "You had to try, didn't you?  I just won on ", l
    go to 8
  end if
! Test for no situation level, if so use a waiting move
  if ( m1 <= 0 ) then
    do i = k1, 20
      m1 = w(i)
      if ( m(m1) <= 0 ) go to 7
    end do
    print 1, 'Tie game, restarting'
    go to 2
  end if

7 continue
  ! We have a situation level, so computer's move equals 5
  m(m1) = 5
  a = m1
  b = m1
  call encode
  m1 = b
  a = m2
  b = m2
  call encode
  m2 = b
  print '(a,i0,a,i0,1x,i0)', 'My move is ', m1, ' on strategy ', m2, m3
  go to 4

8 if ( yes_or_no ( 'Would anyone else to play? ' ) ) go to 3

9 continue

contains

  subroutine Encode
  ! This subroutine changes move code to the external player code
    integer :: L1, L2, L3
    if ( a<=0 ) then
      b=a
    else
      ! Encode (1-64) to (111-444) a -> b
      l3 = mod(a-1,4)
      l2 = mod((a-1)/4,4)
      l1 = (a-1)/16
      b = l3+1 + 10 * ( l2+1 + 10 * (l1+1) )
    end if
  end subroutine Encode

  subroutine Situation_Analysis
    integer :: J1, J2, J3, J4, J5, J6, J7, J8
    integer :: K3, K5, K8
    integer :: K2, L2, L3, L5, L8
    integer :: T1, T2, T3
    do j1 = 1, 76
      s(j1) = 0
      k2 = 4*j1
      l2 = k2-3
      ! sum board
      do j2 = l2, k2
        j3 = r(j2)
        s(j1) = s(j1)+m(j3)
      end do ! j2
    end do ! j1
    ! This subroutine finds a blank square m1 on a row of sum=test1,
    ! such that another row of sum=test2 contains m1 and also
    ! contains a second blank square m2 which is on a third row of
    ! sum=test3. Negative tests are skipped. If situation is 1 or
    ! 2, answer is a row subscript, else answer is m1, m1 and m2
    ! may be identical. First calculate the sum value for each row.
    do j1 = 1, 14
      m3 = j1
      t1 = t(1,j1)
      if ( t1<0 ) cycle
      t2 = t(2,j1)
      t3 = t(3,j1)
      do j2 = 1, 76
        if ( s(j2) /= t1 ) cycle
        if ( j1 <= 2 ) go to 1
        k3 = 4*j2
        l3 = k3-3
        do j3 = l3, k3
          m1 = r(j3)
          if ( m(m1) /= 0 ) cycle
          if ( t2 < 0 ) go to 2
          do j4 = 1, 76
            if ( s(j4) /= t2 ) cycle
            if ( j4 == j2 ) cycle
            k5 = 4*j4
            l5 = k5-3
            do j5 = l5, k5
              if ( m1 /= r(j5) ) cycle
              if ( t3 < 0 ) go to 2
              do j6 = l5, k5
                m2 = r(j6)
                if ( m(m2) /= 0 ) cycle
                do j7 = 1, 76
                  if ( s(j7) /= t3 ) cycle
                  if ( j7 == j2 ) cycle
                  if ( j7 == j4 ) cycle
                  k8 = 4*j7
                  l8 = k8-3
                  do j8 = l8, k8
                    if ( m2 == r(j8) ) return
                  end do ! j8
                end do ! j7
              end do ! j6
            end do ! j5
          end do ! j4
        end do ! j3
      end do ! j2
    end do ! j1
    m1 = 0
    go to 2
  1 m1 = j2
  2 m2 = 0
  end subroutine Situation_Analysis

  logical function Yes_Or_No ( Question )
    character(len=*), intent(in) :: Question
    character(len=3) :: Answer
  1 format ( a )
    do
      print 1, trim(question)
      read ( *, 1, end=9 ) answer
      select case ( answer )
      case ( 'YES', 'yes' )
        yes_or_no = .true.
        return
      case ( 'NO', 'no' )
        yes_or_no = .false.
        return
      case default
        print 1, 'Please answer YES (or yes) or NO (or no)'
      end select
    end do
    return
  9 stop
  end function Yes_Or_No

end program Tic_Tac_Toe_4x4x4
