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 (file)
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 (executable)
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 (file)
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