Added Fortran sample Agent

It occasionally gets confused and breaks. Fixing is an excercise for any fools that decide to use FORTRAN.

agents/fortran/Makefile

+
+SRC = agent.f90
+
+BIN = agent
+
+$(BIN) : $(SRC)
+	gfortran -o $(BIN) $(SRC)
+
+clean :
+	rm -f $(BIN)
+	rm -f *~
+	rm -f *.mod

agents/fortran/agent.f90

+! 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