--- /dev/null
+! From the darkness of the 1970s came forth a language so foul and terrible that none can speak its name without shuddering in fear.
+! And woe unto all who seek to use it, for decades of development have not dulled it's magnificent horror.
+
+module qchess
+ implicit none
+
+ ! Fortran90 doesn't have enums...
+ integer, parameter :: KING=1, QUEEN=2, ROOK=3, KNIGHT=4, BISHOP=5, PAWN=6, UNKNOWN=7
+ ! Also it's case insensitive, but I thought I would make an effort to be consistent even if Fortran90 won't
+ integer, parameter :: NONE=0, WHITE=2, BLACK=1
+
+ integer, parameter :: BUFSIZ = 256 ! Need this for strings...
+
+ integer, parameter :: STDERR = 0
+
+ ! But it has types!
+ type piece
+ integer :: x
+ integer :: y
+ integer :: types(2)
+ integer :: type_index
+ integer :: colour
+ end type piece
+
+ ! And... really... confusing... pointer... stuff
+ ! (You can't have an array of pointers... but you can have an array of piece_ptr)
+ type piece_ptr
+ type(piece), pointer :: p
+ end type piece_ptr
+
+ type board
+ type(piece_ptr) :: grid(8,8)
+ ! If I wrote this:
+ ! type(piece), pointer :: grid(:,:)
+ ! It would be a pointer to an array of pieces... not an array of pointers to pieces
+ type(piece_ptr) :: pieces(2,16)
+ type(piece_ptr) :: kings(2)
+ end type board
+
+ type square
+ integer :: x
+ integer :: y
+ end type square
+
+
+end module qchess
+
+
+program agent
+
+ use qchess
+ implicit none
+
+ type(board) :: b
+
+ type(square), allocatable :: moves(:)
+ character(len = BUFSIZ) :: buffer
+ character(len = BUFSIZ) :: buffer2
+ character(len = 2) :: s
+ integer :: x, y, x2, y2, i, t, colour
+ real :: rand(1)
+
+
+ type(piece_ptr) :: choice
+
+ allocate(moves(0))
+
+ call board_init(b)
+
+ call random_seed(i) ! Probably want to fix this...
+
+
+ read(*, '(A)') buffer
+ if (buffer .eq. "white") then
+ colour = WHITE
+ else
+ colour = BLACK
+ endif
+
+
+
+ do while (.true.)
+ read(*, '(A)') buffer
+ !write(STDERR,*) "Got: ", buffer
+ if (buffer .eq. "QUIT black" .or. buffer .eq. "QUIT white") then
+ exit
+ else if (buffer .eq. "SELECTION?") then
+
+ do while(.true.)
+ call random_number(rand)
+ i = int(rand(1) * (size(b%pieces(colour,:)) - 1)) + 1
+ choice = b%pieces(colour, i)
+ if (associated(choice%p)) then
+ exit
+ endif
+ enddo
+ !write(STDERR,*) "Selected:", choice%p%x-1, choice%p%y-1
+ write(*,*) choice%p%x-1, choice%p%y-1
+
+ else if (buffer .eq. "MOVE?") then
+
+ call random_number(rand)
+ call possible_moves(b, choice%p, moves)
+
+ if (size(moves) == 0) then
+ !write(STDERR,*) "No moves!"
+ endif
+
+ do i=1,size(moves)
+ !write(STDERR,*) "Possible move:", i, "->", moves(i)%x-1, moves(i)%y-1
+ enddo
+
+ i = int(rand(1) * (size(moves) - 1)) + 1
+
+ !write(STDERR,*) "Move",i,":", choice%p%x-1, choice%p%y-1, "->", moves(i)%x-1, moves(i)%y-1
+ write(*,*) moves(i)%x-1, moves(i)%y-1
+ deallocate(moves)
+ allocate(moves(0))
+
+ else
+
+
+ read(buffer, '(I2,I2, A)') x, y, buffer
+ x = x + 1
+ y = y + 1
+
+ buffer2 = buffer
+ read(buffer, '(A2)') s
+ if (s .eq. "->") then
+ read(buffer2, *) s, x2, y2
+ x2 = x2 + 1
+ y2 = y2 + 1
+ !write(STDERR,*) "Update:", x-1, y-1, "->" , x2-1, y2-1
+ call board_update_move(b, x, y, x2, y2)
+ else
+ read(buffer, *), i, buffer
+ t = str2type(buffer)
+ !write(STDERR,*) "Update:", x-1, y-1, "selected:" , i, "type:", t
+ call board_update_select(b, x, y, i+1, t)
+ endif
+ endif
+
+ enddo
+
+ deallocate(moves)
+
+ call board_destroy(b)
+
+contains
+
+integer function str2type(s)
+
+ character(len=BUFSIZ), intent(in) :: s
+ !write(STDERR,*) "Determine type of piece:", s, ":"
+ if (s .eq. "king") then
+ str2type = KING
+ else if (s .eq. "queen") then
+ str2type = QUEEN
+ else if (s .eq. "rook") then
+ str2type = ROOK
+ else if (s .eq. "knight") then
+ str2type = KNIGHT
+ else if (s .eq. "bishop") then
+ str2type = BISHOP
+ else if (s .eq. "pawn") then
+ str2type = PAWN
+ else if (s.eq. "unknown") then
+ str2type = UNKNOWN
+ endif
+
+end function str2type
+
+subroutine piece_init(p, colour, type1, type2)
+
+ type(piece), intent(inout) :: p
+ integer, intent(in) :: colour, type1, type2
+ p%colour = colour
+ p%types(1) = type1
+ p%types(2) = type2
+ p%type_index = 0
+
+
+end subroutine piece_init
+
+subroutine board_init(b)
+ type(board), intent(inout) :: b
+ integer :: x, y, j
+ integer :: colour
+
+ do x=1,8
+ do y=1,8
+ nullify(b%grid(x,y)%p)
+ enddo
+ enddo
+
+ ! Add the pieces
+
+
+
+ do colour=1,2
+ j = 1
+ if (colour .eq. WHITE) then
+ y = 7
+ else
+ y = 2
+ endif
+
+ ! Add pawns
+ do x=1,8
+ allocate(b%grid(x,y)%p)
+ call piece_init(b%grid(x,y)%p, colour, PAWN, UNKNOWN)
+ b%pieces(colour, j) = b%grid(x,y)
+ j = j + 1
+ enddo
+
+ ! Add other pieces
+ if (colour .eq. WHITE) then
+ y = 8
+ else
+ y = 1
+ endif
+
+ do x=1, 8
+ allocate(b%grid(x, y)%p)
+ b%pieces(colour, j) = b%grid(x,y)
+ j = j + 1
+ enddo
+ call piece_init(b%grid(1,y)%p, colour, ROOK, UNKNOWN)
+ call piece_init(b%grid(2,y)%p, colour, KNIGHT, UNKNOWN)
+ call piece_init(b%grid(3,y)%p, colour, BISHOP, UNKNOWN)
+ call piece_init(b%grid(4,y)%p, colour, KING, KING)
+ call piece_init(b%grid(5,y)%p, colour, QUEEN, UNKNOWN)
+ call piece_init(b%grid(6,y)%p, colour, BISHOP, UNKNOWN)
+ call piece_init(b%grid(7,y)%p, colour, KNIGHT, UNKNOWN)
+ call piece_init(b%grid(8,y)%p, colour, ROOK, UNKNOWN)
+
+ b%kings(colour) = b%grid(4, y)
+ enddo
+
+ do x=1,8
+ do y=1,8
+ if (associated(b%grid(x,y)%p)) then
+ b%grid(x,y)%p%x = x
+ b%grid(x,y)%p%y = y
+ !write(STDERR,*) "Piece", b%grid(x,y)%p%types(1), "at", x, y
+ endif
+ enddo
+ enddo
+
+end subroutine board_init
+
+subroutine board_update_select(b, x, y, type_index, t)
+
+ integer, intent(in) :: x, y, type_index, t
+ type(board), intent(inout) :: b
+ b%grid(x, y)%p%type_index = type_index
+ b%grid(x, y)%p%types(type_index) = t
+
+end subroutine board_update_select
+
+subroutine board_update_move(b, x, y, x2, y2)
+
+ type(board), intent(inout) :: b
+ integer, intent(in) :: x, y, x2, y2
+ integer :: colour, i
+
+
+
+ if (associated(b%grid(x2, y2)%p) .eqv. .true.) then
+ colour = b%grid(x2,y2)%p%colour
+ do i=1,16
+ if (associated(b%pieces(colour, i)%p, b%grid(x2, y2)%p)) then
+ b%pieces(colour, i)%p => NULL()
+ endif
+ enddo
+ deallocate(b%grid(x2,y2)%p)
+ endif
+
+ b%grid(x2,y2) = b%grid(x,y)
+ b%grid(x,y)%p%x = x2
+ b%grid(x,y)%p%y = y2
+ b%grid(x,y)%p => NULL()
+
+
+
+end subroutine board_update_move
+
+subroutine possible_moves(b, p, m)
+
+ type(board), intent(in) :: b
+ type(piece), intent(in) :: p
+ type(square), intent(inout), allocatable :: m(:)
+ type(square), allocatable :: copy(:)
+
+ integer :: i
+ integer :: x, y
+
+
+
+
+ do x=1,8
+ do y=1,8
+ if (legal_move(b, p, x, y) .eqv. .true.) then
+ allocate(copy(size(m) + 1))
+ copy(1:size(m)) = m
+ deallocate(m)
+ allocate(m(size(copy)))
+ m(1:size(copy)) = copy
+ deallocate(copy)
+
+ m(size(m))%x = x
+ m(size(m))%y = y
+ else
+ !write(STDERR,*) "Piece of type", p%types(p%type_index), "can't move from", p%x, p%y, "to", x, y
+ endif
+
+ enddo
+ enddo
+
+end subroutine possible_moves
+
+logical function legal_move(b, p, x, y)
+
+ type(board), intent(in) :: b
+ type(piece), intent(in) :: p
+ integer, intent(in) :: x, y
+
+
+ integer :: t, c, xx, yy
+
+ if (x .le. 0 .or. x .gt. 8 .or. y .le. 0 .or. y .gt. 8) then
+ legal_move = .false.
+ return
+ endif
+
+ t = p%types(p%type_index)
+ c = p%colour
+
+ !write(STDERR,*) "Test legal move for piece", p%types(p%type_index), "at", p%x-1, p%y-1, "->", x-1, y-1
+
+ ! Establish move is into empty square or takes a piece
+ legal_move = .not. (associated(b%grid(x,y)%p) .and. b%grid(x,y)%p%colour .eq. c)
+ if (legal_move .eqv. .false.) then
+ return ! Move into allied square; not allowed
+ endif
+
+
+ if (t == PAWN) then
+ ! Check y coord
+ legal_move = (c == WHITE .and. y == p%y - 1 .or. (y == p%y-2 .and. p%y == 7)) &
+ .or. (c == BLACK .and. y == p%y+1 .or. (y == p%y+2 .and. p%y == 1))
+ ! Check x coord
+ legal_move = legal_move .and. (x == p%x)
+ if (legal_move .eqv. .true.) then
+ ! Can't move pawn forward into any occupied square
+ legal_move = .not. associated(b%grid(x,y)%p)
+ return
+ endif
+
+ if (associated(b%grid(x,y)%p) .eqv. .true.) then
+ ! Can take diagonally
+ legal_move = (c == WHITE .and. y == p%y - 1 .and. abs(x - p%x) == 1) &
+ .or. (c == BLACK .and. y == p%y+1 .and. abs(x - p%x) == 1)
+ endif
+
+ return
+ endif
+
+ if (t == KING) then
+ legal_move = (abs(x - p%x) .le. 1 .and. abs(y - p%y) .le. 1)
+ return
+ endif
+
+ if (t == KNIGHT) then
+
+ legal_move = ((abs(x - p%x) == 2 .and. abs(y - p%y) == 1) &
+ .or. (abs(x - p%x) == 1 .and. abs(y - p%y) == 2))
+ return
+ endif
+
+ if (t == BISHOP .or. t == QUEEN) then
+ legal_move = (abs(x - p%x) .eq. abs(y - p%y))
+ endif
+
+ if (t == ROOK .or. (t == QUEEN .and. .not. legal_move)) then
+ legal_move = (abs(x - p%x) == 0 .or. abs(y - p%y) == 0)
+ endif
+
+ if (legal_move .eqv. .false.) then
+ return
+ endif
+
+ xx = p%x
+ yy = p%y
+ do while (xx .ne. x .or. yy .ne. y)
+ if (xx .gt. x) then
+ xx = xx - 1
+ endif
+ if (xx .lt. x) then
+ xx = xx + 1
+ endif
+ if (yy .gt. y) then
+ yy = yy - 1
+ endif
+ if (yy .lt. y) then
+ yy = yy + 1
+ endif
+
+ if (associated(b%grid(xx,yy)%p)) then
+ legal_move = .false.
+ return
+ endif
+ enddo
+
+
+
+end function legal_move
+
+subroutine board_destroy(b)
+ type(board), intent(inout) :: b
+
+ integer :: x, y, c, i
+
+ do x=1, 8
+ do y=1,8
+ if (associated(b%grid(x,y)%p)) then
+ deallocate(b%grid(x,y)%p)
+ b%grid(x,y)%p => NULL()
+
+ endif
+ enddo
+ enddo
+
+ do c=1,2
+ do i=1,16
+ b%pieces(c, i)%p =>NULL()
+ enddo
+
+ b%kings(c)%p => NULL()
+ enddo
+
+end subroutine board_destroy
+
+
+
+end program agent
git.ucc.asn.au / progcomp2013.git / blobdiff
UCC git Repository :: git.ucc.asn.au