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