agents/fortran/agent.f90

   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.
   3
   4 module qchess
   5         implicit none
   6
   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
  11
  12         integer, parameter :: BUFSIZ = 256 ! Need this for strings...
  13
  14         integer, parameter :: STDERR = 0
  15
  16         ! But it has types!
  17         type piece
  18                 integer :: x
  19                 integer :: y
  20                 integer :: types(2)
  21                 integer :: type_index
  22                 integer :: colour
  23         end type piece
  24
  25         ! And... really... confusing... pointer... stuff
  26         ! (You can't have an array of pointers... but you can have an array of piece_ptr)
  27         type piece_ptr
  28                 type(piece), pointer :: p
  29         end type piece_ptr
  30
  31         type board
  32                 type(piece_ptr) :: grid(8,8)
  33                 ! If I wrote this:
  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)
  38         end type board
  39
  40         type square
  41                 integer :: x
  42                 integer :: y
  43         end type square
  44
  45
  46 end module qchess
  47
  48
  49 program agent
  50
  51         use qchess
  52         implicit none
  53
  54         type(board) :: b
  55
  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
  61         real :: rand(1)
  62
  63
  64         type(piece_ptr) :: choice
  65
  66         allocate(moves(0))
  67
  68         call board_init(b)
  69
  70         call random_seed(i) ! Probably want to fix this...
  71
  72
  73         read(*, '(A)') buffer
  74         if (buffer .eq. "white") then
  75                 colour = WHITE
  76         else
  77                 colour = BLACK
  78         endif
  79
  80
  81
  82         do while (.true.)
  83                 read(*, '(A)') buffer
  84                 !write(STDERR,*) "Got: ", buffer
  85                 if (buffer .eq. "QUIT black" .or. buffer .eq. "QUIT white") then
  86                         exit
  87                 else if (buffer .eq. "SELECTION?") then
  88
  89                         do while(.true.)
  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
  94                                         exit
  95                                 endif
  96                         enddo
  97                         !write(STDERR,*) "Selected:", choice%p%x-1, choice%p%y-1
  98                         write(*,*) choice%p%x-1, choice%p%y-1
  99
 100                 else if (buffer .eq. "MOVE?") then
 101
 102                         call random_number(rand)
 103                         call possible_moves(b, choice%p, moves)
 104
 105                         if (size(moves) == 0) then
 106                                 !write(STDERR,*) "No moves!"
 107                         endif
 108
 109                         do i=1,size(moves)
 110                                 !write(STDERR,*) "Possible move:", i, "->", moves(i)%x-1, moves(i)%y-1
 111                         enddo
 112
 113                         i = int(rand(1) * (size(moves) - 1)) + 1
 114
 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
 117                         deallocate(moves)
 118                         allocate(moves(0))
 119
 120                 else
 121
 122
 123                         read(buffer, '(I2,I2, A)') x, y, buffer
 124                         x = x + 1
 125                         y = y + 1
 126
 127                         buffer2 = buffer
 128                         read(buffer, '(A2)') s
 129                         if (s .eq. "->") then
 130                                 read(buffer2, *) s, x2, y2
 131                                 x2 = x2 + 1
 132                                 y2 = y2 + 1
 133                                 !write(STDERR,*) "Update:", x-1, y-1, "->" , x2-1, y2-1
 134                                 call board_update_move(b, x, y, x2, y2)
 135                         else
 136                                 read(buffer, *), i, buffer
 137                                 t = str2type(buffer)
 138                                 !write(STDERR,*) "Update:", x-1, y-1, "selected:" , i, "type:", t
 139                                 call board_update_select(b, x, y, i+1, t)
 140                         endif
 141                 endif
 142
 143         enddo
 144
 145         deallocate(moves)
 146
 147         call board_destroy(b)
 148
 149 contains
 150
 151 integer function str2type(s)
 152
 153         character(len=BUFSIZ), intent(in) :: s
 154         !write(STDERR,*) "Determine type of piece:", s, ":"
 155         if (s .eq. "king") then
 156                 str2type = KING
 157         else if (s .eq. "queen") then
 158                 str2type = QUEEN
 159         else if (s .eq. "rook") then
 160                 str2type = ROOK
 161         else if (s .eq. "knight") then
 162                 str2type = KNIGHT
 163         else if (s .eq. "bishop") then
 164                 str2type = BISHOP
 165         else if (s .eq. "pawn") then
 166                 str2type = PAWN
 167         else if (s.eq. "unknown") then
 168                 str2type = UNKNOWN
 169         endif
 170
 171 end function str2type
 172
 173 subroutine piece_init(p, colour, type1, type2)
 174
 175         type(piece), intent(inout) :: p
 176         integer, intent(in) :: colour, type1, type2
 177         p%colour = colour
 178         p%types(1) = type1
 179         p%types(2) = type2
 180         p%type_index = 0
 181
 182
 183 end subroutine piece_init
 184
 185 subroutine board_init(b)
 186         type(board), intent(inout) :: b
 187         integer :: x, y, j
 188         integer :: colour
 189
 190         do x=1,8
 191                 do y=1,8
 192                         nullify(b%grid(x,y)%p)
 193                 enddo
 194         enddo
 195
 196         ! Add the pieces
 197
 198
 199
 200         do colour=1,2
 201                 j = 1
 202                 if (colour .eq. WHITE) then
 203                         y = 7
 204                 else
 205                         y = 2
 206                 endif
 207
 208                 ! Add pawns
 209                 do x=1,8
 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)
 213                         j = j + 1
 214                 enddo
 215
 216                 ! Add other pieces
 217                 if (colour .eq. WHITE) then
 218                         y = 8
 219                 else
 220                         y = 1
 221                 endif
 222
 223                 do x=1, 8
 224                         allocate(b%grid(x, y)%p)
 225                         b%pieces(colour, j) = b%grid(x,y)
 226                         j = j + 1
 227                 enddo
 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)
 236
 237                 b%kings(colour) = b%grid(4, y)
 238         enddo
 239
 240         do x=1,8
 241                 do y=1,8
 242                         if (associated(b%grid(x,y)%p)) then
 243                                 b%grid(x,y)%p%x = x
 244                                 b%grid(x,y)%p%y = y
 245                                 !write(STDERR,*) "Piece", b%grid(x,y)%p%types(1), "at", x, y
 246                         endif
 247                 enddo
 248         enddo
 249
 250 end subroutine board_init
 251
 252 subroutine board_update_select(b, x, y, type_index, t)
 253
 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
 258
 259 end subroutine board_update_select
 260
 261 subroutine board_update_move(b, x, y, x2, y2)
 262
 263         type(board), intent(inout) :: b
 264         integer, intent(in) :: x, y, x2, y2
 265         integer :: colour, i
 266
 267
 268
 269         if (associated(b%grid(x2, y2)%p) .eqv. .true.) then
 270                 colour = b%grid(x2,y2)%p%colour
 271                 do i=1,16
 272                         if (associated(b%pieces(colour, i)%p, b%grid(x2, y2)%p)) then
 273                                 b%pieces(colour, i)%p => NULL()
 274                         endif
 275                 enddo
 276                 deallocate(b%grid(x2,y2)%p)
 277         endif
 278
 279         b%grid(x2,y2) = b%grid(x,y)
 280         b%grid(x,y)%p%x = x2
 281         b%grid(x,y)%p%y = y2
 282         b%grid(x,y)%p => NULL()
 283
 284
 285
 286 end subroutine board_update_move
 287
 288 subroutine possible_moves(b, p, m)
 289
 290         type(board), intent(in) :: b
 291         type(piece), intent(in) :: p
 292         type(square), intent(inout), allocatable :: m(:)
 293         type(square), allocatable :: copy(:)
 294
 295         integer :: i
 296         integer :: x, y
 297
 298
 299
 300
 301         do x=1,8
 302                 do y=1,8
 303                         if (legal_move(b, p, x, y) .eqv. .true.) then
 304                                 allocate(copy(size(m) + 1))
 305                                 copy(1:size(m)) = m
 306                                 deallocate(m)
 307                                 allocate(m(size(copy)))
 308                                 m(1:size(copy)) = copy
 309                                 deallocate(copy)
 310
 311                                 m(size(m))%x = x
 312                                 m(size(m))%y = y
 313                         else
 314                                 !write(STDERR,*) "Piece of type", p%types(p%type_index), "can't move from", p%x, p%y, "to", x, y
 315                         endif
 316
 317                 enddo
 318         enddo
 319
 320 end subroutine possible_moves
 321
 322 logical function legal_move(b, p, x, y)
 323
 324         type(board), intent(in) :: b
 325         type(piece), intent(in) :: p
 326         integer, intent(in) :: x, y
 327
 328
 329         integer :: t, c, xx, yy
 330
 331         if (x .le. 0 .or. x .gt. 8 .or. y .le. 0 .or. y .gt. 8) then
 332                 legal_move = .false.
 333                 return
 334         endif
 335
 336         t = p%types(p%type_index)
 337         c = p%colour
 338
 339         !write(STDERR,*) "Test legal move for piece", p%types(p%type_index), "at", p%x-1, p%y-1, "->", x-1, y-1
 340
 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
 345         endif
 346
 347
 348         if (t == PAWN) then
 349                 ! Check y coord
 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))
 352                 ! Check x coord
 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)
 357                         return
 358                 endif
 359
 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)
 364                 endif
 365
 366                 return
 367         endif
 368
 369         if (t == KING) then
 370                 legal_move = (abs(x - p%x) .le. 1 .and. abs(y - p%y) .le. 1)
 371                 return
 372         endif
 373
 374         if (t == KNIGHT) then
 375
 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))
 378                 return
 379         endif
 380
 381         if (t == BISHOP .or. t == QUEEN) then
 382                 legal_move = (abs(x - p%x) .eq. abs(y - p%y))
 383         endif
 384
 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)
 387         endif
 388
 389         if (legal_move .eqv. .false.) then
 390                 return
 391         endif
 392
 393         xx = p%x
 394         yy = p%y
 395         do while (xx .ne. x .or. yy .ne. y)
 396                 if (xx .gt. x) then
 397                         xx = xx - 1
 398                 endif
 399                 if (xx .lt. x) then
 400                         xx = xx + 1
 401                 endif
 402                 if (yy .gt. y) then
 403                         yy = yy - 1
 404                 endif
 405                 if (yy .lt. y) then
 406                         yy = yy + 1
 407                 endif
 408
 409                 if (associated(b%grid(xx,yy)%p)) then
 410                         legal_move = .false.
 411                         return
 412                 endif
 413         enddo
 414
 415
 416
 417 end function legal_move
 418
 419 subroutine board_destroy(b)
 420         type(board), intent(inout) :: b
 421
 422         integer :: x, y, c, i
 423
 424         do x=1, 8
 425                 do y=1,8
 426                         if (associated(b%grid(x,y)%p)) then
 427                                 deallocate(b%grid(x,y)%p)
 428                                 b%grid(x,y)%p => NULL()
 429
 430                         endif
 431                 enddo
 432         enddo
 433
 434         do c=1,2
 435                 do i=1,16
 436                         b%pieces(c, i)%p =>NULL()
 437                 enddo
 438
 439                 b%kings(c)%p => NULL()
 440         enddo
 441
 442 end subroutine board_destroy
 443
 444
 445
 446 end program agent