From: Sam Moore Date: Tue, 5 Mar 2013 10:25:33 +0000 (+0800) Subject: Added Fortran sample Agent X-Git-Url: https://git.ucc.asn.au/?a=commitdiff_plain;h=17d3a7edd766918e7e2a938125e3f72efc829222;p=progcomp2013.git Added Fortran sample Agent It occasionally gets confused and breaks. Fixing is an excercise for any fools that decide to use FORTRAN. --- diff --git a/agents/fortran/Makefile b/agents/fortran/Makefile new file mode 100644 index 0000000..99d32c3 --- /dev/null +++ b/agents/fortran/Makefile @@ -0,0 +1,12 @@ + +SRC = agent.f90 + +BIN = agent + +$(BIN) : $(SRC) + gfortran -o $(BIN) $(SRC) + +clean : + rm -f $(BIN) + rm -f *~ + rm -f *.mod diff --git a/agents/fortran/agent b/agents/fortran/agent new file mode 100755 index 0000000..f21333e Binary files /dev/null and b/agents/fortran/agent differ diff --git a/agents/fortran/agent.f90 b/agents/fortran/agent.f90 new file mode 100644 index 0000000..3f4c1ae --- /dev/null +++ b/agents/fortran/agent.f90 @@ -0,0 +1,446 @@ +! 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