Commit 17d3a7ed authored by Sam Moore's avatar Sam Moore

Added Fortran sample Agent

It occasionally gets confused and breaks. Fixing is an excercise for any fools that decide to use FORTRAN.
parent 15970878
SRC = agent.f90
BIN = agent
$(BIN) : $(SRC)
gfortran -o $(BIN) $(SRC)
clean :
rm -f $(BIN)
rm -f *~
rm -f *.mod
! 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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment