1 ! From the darkness of the 1970s came forth a language so foul and terrible that none can speak its name without shuddering in fear.
2 ! And woe unto all who seek to use it, for decades of development have not dulled it's magnificent horror.
7 ! Fortran90 doesn't have enums...
8 integer, parameter :: KING=1, QUEEN=2, ROOK=3, KNIGHT=4, BISHOP=5, PAWN=6, UNKNOWN=7
9 ! Also it's case insensitive, but I thought I would make an effort to be consistent even if Fortran90 won't
10 integer, parameter :: NONE=0, WHITE=2, BLACK=1
12 integer, parameter :: BUFSIZ = 256 ! Need this for strings...
14 integer, parameter :: STDERR = 0
25 ! And... really... confusing... pointer... stuff
26 ! (You can't have an array of pointers... but you can have an array of piece_ptr)
28 type(piece), pointer :: p
32 type(piece_ptr) :: grid(8,8)
34 ! type(piece), pointer :: grid(:,:)
35 ! It would be a pointer to an array of pieces... not an array of pointers to pieces
36 type(piece_ptr) :: pieces(2,16)
37 type(piece_ptr) :: kings(2)
56 type(square), allocatable :: moves(:)
57 character(len = BUFSIZ) :: buffer
58 character(len = BUFSIZ) :: buffer2
59 character(len = 2) :: s
60 integer :: x, y, x2, y2, i, t, colour
64 type(piece_ptr) :: choice
70 call random_seed(i) ! Probably want to fix this...
74 if (buffer .eq. "white") then
84 !write(STDERR,*) "Got: ", buffer
85 if (buffer .eq. "QUIT black" .or. buffer .eq. "QUIT white") then
87 else if (buffer .eq. "SELECTION?") then
90 call random_number(rand)
91 i = int(rand(1) * (size(b%pieces(colour,:)) - 1)) + 1
92 choice = b%pieces(colour, i)
93 if (associated(choice%p)) then
97 !write(STDERR,*) "Selected:", choice%p%x-1, choice%p%y-1
98 write(*,*) choice%p%x-1, choice%p%y-1
100 else if (buffer .eq. "MOVE?") then
102 call random_number(rand)
103 call possible_moves(b, choice%p, moves)
105 if (size(moves) == 0) then
106 !write(STDERR,*) "No moves!"
110 !write(STDERR,*) "Possible move:", i, "->", moves(i)%x-1, moves(i)%y-1
113 i = int(rand(1) * (size(moves) - 1)) + 1
115 !write(STDERR,*) "Move",i,":", choice%p%x-1, choice%p%y-1, "->", moves(i)%x-1, moves(i)%y-1
116 write(*,*) moves(i)%x-1, moves(i)%y-1
123 read(buffer, '(I2,I2, A)') x, y, buffer
128 read(buffer, '(A2)') s
129 if (s .eq. "->") then
130 read(buffer2, *) s, x2, y2
133 !write(STDERR,*) "Update:", x-1, y-1, "->" , x2-1, y2-1
134 call board_update_move(b, x, y, x2, y2)
136 read(buffer, *), i, buffer
138 !write(STDERR,*) "Update:", x-1, y-1, "selected:" , i, "type:", t
139 call board_update_select(b, x, y, i+1, t)
147 call board_destroy(b)
151 integer function str2type(s)
153 character(len=BUFSIZ), intent(in) :: s
154 !write(STDERR,*) "Determine type of piece:", s, ":"
155 if (s .eq. "king") then
157 else if (s .eq. "queen") then
159 else if (s .eq. "rook") then
161 else if (s .eq. "knight") then
163 else if (s .eq. "bishop") then
165 else if (s .eq. "pawn") then
167 else if (s.eq. "unknown") then
171 end function str2type
173 subroutine piece_init(p, colour, type1, type2)
175 type(piece), intent(inout) :: p
176 integer, intent(in) :: colour, type1, type2
183 end subroutine piece_init
185 subroutine board_init(b)
186 type(board), intent(inout) :: b
192 nullify(b%grid(x,y)%p)
202 if (colour .eq. WHITE) then
210 allocate(b%grid(x,y)%p)
211 call piece_init(b%grid(x,y)%p, colour, PAWN, UNKNOWN)
212 b%pieces(colour, j) = b%grid(x,y)
217 if (colour .eq. WHITE) then
224 allocate(b%grid(x, y)%p)
225 b%pieces(colour, j) = b%grid(x,y)
228 call piece_init(b%grid(1,y)%p, colour, ROOK, UNKNOWN)
229 call piece_init(b%grid(2,y)%p, colour, KNIGHT, UNKNOWN)
230 call piece_init(b%grid(3,y)%p, colour, BISHOP, UNKNOWN)
231 call piece_init(b%grid(4,y)%p, colour, KING, KING)
232 call piece_init(b%grid(5,y)%p, colour, QUEEN, UNKNOWN)
233 call piece_init(b%grid(6,y)%p, colour, BISHOP, UNKNOWN)
234 call piece_init(b%grid(7,y)%p, colour, KNIGHT, UNKNOWN)
235 call piece_init(b%grid(8,y)%p, colour, ROOK, UNKNOWN)
237 b%kings(colour) = b%grid(4, y)
242 if (associated(b%grid(x,y)%p)) then
245 !write(STDERR,*) "Piece", b%grid(x,y)%p%types(1), "at", x, y
250 end subroutine board_init
252 subroutine board_update_select(b, x, y, type_index, t)
254 integer, intent(in) :: x, y, type_index, t
255 type(board), intent(inout) :: b
256 b%grid(x, y)%p%type_index = type_index
257 b%grid(x, y)%p%types(type_index) = t
259 end subroutine board_update_select
261 subroutine board_update_move(b, x, y, x2, y2)
263 type(board), intent(inout) :: b
264 integer, intent(in) :: x, y, x2, y2
269 if (associated(b%grid(x2, y2)%p) .eqv. .true.) then
270 colour = b%grid(x2,y2)%p%colour
272 if (associated(b%pieces(colour, i)%p, b%grid(x2, y2)%p)) then
273 b%pieces(colour, i)%p => NULL()
276 deallocate(b%grid(x2,y2)%p)
279 b%grid(x2,y2) = b%grid(x,y)
282 b%grid(x,y)%p => NULL()
286 end subroutine board_update_move
288 subroutine possible_moves(b, p, m)
290 type(board), intent(in) :: b
291 type(piece), intent(in) :: p
292 type(square), intent(inout), allocatable :: m(:)
293 type(square), allocatable :: copy(:)
303 if (legal_move(b, p, x, y) .eqv. .true.) then
304 allocate(copy(size(m) + 1))
307 allocate(m(size(copy)))
308 m(1:size(copy)) = copy
314 !write(STDERR,*) "Piece of type", p%types(p%type_index), "can't move from", p%x, p%y, "to", x, y
320 end subroutine possible_moves
322 logical function legal_move(b, p, x, y)
324 type(board), intent(in) :: b
325 type(piece), intent(in) :: p
326 integer, intent(in) :: x, y
329 integer :: t, c, xx, yy
331 if (x .le. 0 .or. x .gt. 8 .or. y .le. 0 .or. y .gt. 8) then
336 t = p%types(p%type_index)
339 !write(STDERR,*) "Test legal move for piece", p%types(p%type_index), "at", p%x-1, p%y-1, "->", x-1, y-1
341 ! Establish move is into empty square or takes a piece
342 legal_move = .not. (associated(b%grid(x,y)%p) .and. b%grid(x,y)%p%colour .eq. c)
343 if (legal_move .eqv. .false.) then
344 return ! Move into allied square; not allowed
350 legal_move = (c == WHITE .and. y == p%y - 1 .or. (y == p%y-2 .and. p%y == 7)) &
351 .or. (c == BLACK .and. y == p%y+1 .or. (y == p%y+2 .and. p%y == 1))
353 legal_move = legal_move .and. (x == p%x)
354 if (legal_move .eqv. .true.) then
355 ! Can't move pawn forward into any occupied square
356 legal_move = .not. associated(b%grid(x,y)%p)
360 if (associated(b%grid(x,y)%p) .eqv. .true.) then
361 ! Can take diagonally
362 legal_move = (c == WHITE .and. y == p%y - 1 .and. abs(x - p%x) == 1) &
363 .or. (c == BLACK .and. y == p%y+1 .and. abs(x - p%x) == 1)
370 legal_move = (abs(x - p%x) .le. 1 .and. abs(y - p%y) .le. 1)
374 if (t == KNIGHT) then
376 legal_move = ((abs(x - p%x) == 2 .and. abs(y - p%y) == 1) &
377 .or. (abs(x - p%x) == 1 .and. abs(y - p%y) == 2))
381 if (t == BISHOP .or. t == QUEEN) then
382 legal_move = (abs(x - p%x) .eq. abs(y - p%y))
385 if (t == ROOK .or. (t == QUEEN .and. .not. legal_move)) then
386 legal_move = (abs(x - p%x) == 0 .or. abs(y - p%y) == 0)
389 if (legal_move .eqv. .false.) then
395 do while (xx .ne. x .or. yy .ne. y)
409 if (associated(b%grid(xx,yy)%p)) then
417 end function legal_move
419 subroutine board_destroy(b)
420 type(board), intent(inout) :: b
422 integer :: x, y, c, i
426 if (associated(b%grid(x,y)%p)) then
427 deallocate(b%grid(x,y)%p)
428 b%grid(x,y)%p => NULL()
436 b%pieces(c, i)%p =>NULL()
439 b%kings(c)%p => NULL()
442 end subroutine board_destroy