280 lines
8.6 KiB
Fortran
280 lines
8.6 KiB
Fortran
program example__n_queens
|
|
|
|
use, intrinsic :: iso_fortran_env, only: output_unit
|
|
|
|
use, non_intrinsic :: garbage_collector
|
|
use, non_intrinsic :: cons_pairs
|
|
|
|
implicit none
|
|
|
|
! .true. is good for testing that necessary values are rooted.
|
|
! .false. to collect garbage only when the heap reaches a limit.
|
|
logical :: aggressive_garbage_collection = .true.
|
|
|
|
integer :: arg_count
|
|
integer :: stat
|
|
character(80) :: arg
|
|
|
|
type(gcroot_t) :: board_sizes
|
|
|
|
arg_count = command_argument_count ()
|
|
if (arg_count < 1) then
|
|
call print_usage (output_unit)
|
|
else
|
|
board_sizes = nil
|
|
block
|
|
integer :: i
|
|
integer :: board_size
|
|
do i = 1, arg_count
|
|
call get_command_argument (i, arg)
|
|
read (arg, *, iostat = stat) board_size
|
|
if (stat /= 0 .or. board_size < 1) then
|
|
board_size = -1
|
|
end if
|
|
board_sizes = cons (board_size, board_sizes)
|
|
end do
|
|
board_sizes = reversex (board_sizes)
|
|
end block
|
|
|
|
if (is_member (int_eq, -1, board_sizes)) then
|
|
call print_usage (output_unit)
|
|
else
|
|
! Use pair_for_each as a way to distinguish the last
|
|
! BOARD_SIZE from the others. The last entry will be the final
|
|
! pair, and so its CDR will *not* be a pair.
|
|
call pair_for_each (find_and_print_all_solutions, &
|
|
& circular_list (output_unit), &
|
|
& board_sizes)
|
|
end if
|
|
end if
|
|
|
|
contains
|
|
|
|
subroutine print_usage (outp)
|
|
integer, intent(in) :: outp
|
|
|
|
write (outp, '("Usage: example__n_queens BOARD_SIZE [BOARD_SIZE...]")')
|
|
write (outp, '("Each BOARD_SIZE must be at least 1.")')
|
|
write (outp, '("For each BOARD_SIZE, all solutions are computed before any is printed.")')
|
|
end subroutine print_usage
|
|
|
|
subroutine find_and_print_all_solutions (outp_pair, board_sizes)
|
|
class(*), intent(in) :: outp_pair
|
|
class(*), intent(in) :: board_sizes
|
|
|
|
integer :: n_outp
|
|
type(gcroot_t) :: all_solutions
|
|
|
|
n_outp = int_cast (car (outp_pair))
|
|
|
|
all_solutions = find_all_solutions (car (board_sizes))
|
|
call check_garbage
|
|
call print_all_solutions (n_outp, car (board_sizes), all_solutions)
|
|
call check_garbage
|
|
if (is_pair (cdr (board_sizes))) then
|
|
! Space between one BOARD_SIZE and another.
|
|
write (n_outp, '()')
|
|
end if
|
|
end subroutine find_and_print_all_solutions
|
|
|
|
function find_all_solutions (board_size) result (all_solutions)
|
|
class(*), intent(in) :: board_size
|
|
type(cons_t) :: all_solutions
|
|
|
|
class(*), allocatable :: solutions
|
|
|
|
call find_solutions_from_ranks_so_far (board_size, nil, solutions)
|
|
all_solutions = solutions
|
|
end function find_all_solutions
|
|
|
|
recursive subroutine find_solutions_from_ranks_so_far (board_size, ranks_so_far, solutions)
|
|
class(*), intent(in) :: board_size
|
|
class(*), intent(in) :: ranks_so_far
|
|
class(*), allocatable, intent(out) :: solutions
|
|
|
|
type(cons_t) :: ranks
|
|
|
|
if (length (ranks_so_far) == int_cast (board_size)) then
|
|
solutions = list (ranks_so_far)
|
|
else
|
|
ranks = find_legal_ranks_for_file (int_cast (board_size), ranks_so_far)
|
|
solutions = concatenatex (map (find_solutions_from_ranks_so_far, &
|
|
& circular_list (board_size), &
|
|
& map (kons, ranks, circular_list (ranks_so_far))))
|
|
end if
|
|
end subroutine find_solutions_from_ranks_so_far
|
|
|
|
function find_legal_ranks_for_file (board_size, ranks_so_far) result (ranks)
|
|
!
|
|
! Return a list of all the ranks in the next file, under the
|
|
! constraint that a queen placed in the position not be under
|
|
! attack.
|
|
!
|
|
integer, intent(in) :: board_size
|
|
class(*), intent(in) :: ranks_so_far
|
|
type(cons_t) :: ranks
|
|
|
|
ranks = iota (board_size, 1) ! All the possible ranks.
|
|
ranks = remove_illegal_ranks (ranks, ranks_so_far)
|
|
end function find_legal_ranks_for_file
|
|
|
|
function remove_illegal_ranks (new_ranks, ranks_so_far) result (legal_ranks)
|
|
class(*), intent(in) :: new_ranks
|
|
class(*), intent(in) :: ranks_so_far
|
|
type(cons_t) :: legal_ranks
|
|
|
|
legal_ranks = filter_map (keep_legal_rank, new_ranks, &
|
|
& circular_list (ranks_so_far))
|
|
end function remove_illegal_ranks
|
|
|
|
subroutine keep_legal_rank (rank, ranks_so_far, retval)
|
|
class(*), intent(in) :: rank
|
|
class(*), intent(in) :: ranks_so_far
|
|
class(*), allocatable, intent(out) :: retval
|
|
|
|
if (rank_is_legal (rank, ranks_so_far)) then
|
|
retval = rank
|
|
else
|
|
retval = .false.
|
|
end if
|
|
end subroutine keep_legal_rank
|
|
|
|
function rank_is_legal (new_rank, ranks_so_far) result (bool)
|
|
class(*), intent(in) :: new_rank
|
|
class(*), intent(in) :: ranks_so_far
|
|
logical :: bool
|
|
|
|
integer :: new_file
|
|
type(cons_t) :: files_so_far
|
|
|
|
new_file = int (length (ranks_so_far)) + 1
|
|
files_so_far = iota (new_file - 1, new_file - 1, -1)
|
|
bool = every (these_two_queens_are_nonattacking, &
|
|
& circular_list (new_file), &
|
|
& circular_list (new_rank), &
|
|
& files_so_far, &
|
|
& ranks_so_far)
|
|
end function rank_is_legal
|
|
|
|
function these_two_queens_are_nonattacking (file1, rank1, file2, rank2) result (bool)
|
|
class(*), intent(in) :: file1, rank1
|
|
class(*), intent(in) :: file2, rank2
|
|
logical :: bool
|
|
|
|
integer :: f1, r1
|
|
integer :: f2, r2
|
|
|
|
! The rank and the two diagonals must not be the same. (The files
|
|
! are known to be different.)
|
|
|
|
f1 = int_cast (file1)
|
|
r1 = int_cast (rank1)
|
|
f2 = int_cast (file2)
|
|
r2 = int_cast (rank2)
|
|
|
|
bool = (r1 /= r2 .and. r1 + f1 /= r2 + f2 .and. r1 - f1 /= r2 - f2)
|
|
end function these_two_queens_are_nonattacking
|
|
|
|
subroutine print_all_solutions (outp, board_size, all_solutions)
|
|
class(*), intent(in) :: outp
|
|
class(*), intent(in) :: board_size
|
|
class(*), intent(in) :: all_solutions
|
|
|
|
integer(size_kind) :: n
|
|
|
|
n = length (all_solutions)
|
|
write (int_cast (outp), '("For a board ", I0, " by ", I0, ", ")', advance = 'no') &
|
|
& int_cast (board_size), int_cast (board_size)
|
|
if (n == 1) then
|
|
write (int_cast (outp), '("there is ", I0, " solution.")') n
|
|
else
|
|
write (int_cast (outp), '("there are ", I0, " solutions.")') n
|
|
end if
|
|
call for_each (print_spaced_solution, circular_list (outp), &
|
|
& circular_list (board_size), all_solutions)
|
|
end subroutine print_all_solutions
|
|
|
|
subroutine print_spaced_solution (outp, board_size, solution)
|
|
class(*), intent(in) :: outp
|
|
class(*), intent(in) :: board_size
|
|
class(*), intent(in) :: solution
|
|
|
|
write (int_cast (outp), '()', advance = 'yes')
|
|
call print_solution (outp, board_size, solution)
|
|
end subroutine print_spaced_solution
|
|
|
|
subroutine print_solution (outp, board_size, solution)
|
|
class(*), intent(in) :: outp
|
|
class(*), intent(in) :: board_size
|
|
class(*), intent(in) :: solution
|
|
|
|
integer :: n_outp
|
|
integer :: n_board_size
|
|
integer :: rank
|
|
integer :: file
|
|
integer :: file_of_queen
|
|
|
|
n_outp = int_cast (outp)
|
|
n_board_size = int_cast (board_size)
|
|
|
|
do rank = n_board_size, 1, -1
|
|
do file = 1, n_board_size
|
|
write (n_outp, '("----")', advance = 'no')
|
|
end do
|
|
write (n_outp, '("-")', advance = 'yes')
|
|
|
|
file_of_queen = n_board_size - int (list_index0 (int_eq, circular_list (rank), solution))
|
|
|
|
do file = 1, n_board_size
|
|
if (file == file_of_queen) then
|
|
write (n_outp, '("| Q ")', advance = 'no')
|
|
else
|
|
write (n_outp, '("| ")', advance = 'no')
|
|
end if
|
|
end do
|
|
write (n_outp, '("|")', advance = 'yes')
|
|
end do
|
|
|
|
do file = 1, n_board_size
|
|
write (n_outp, '("----")', advance = 'no')
|
|
end do
|
|
write (n_outp, '("-")', advance = 'yes')
|
|
end subroutine print_solution
|
|
|
|
subroutine kons (x, y, xy)
|
|
class(*), intent(in) :: x
|
|
class(*), intent(in) :: y
|
|
class(*), allocatable, intent(out) :: xy
|
|
|
|
xy = cons (x, y)
|
|
end subroutine kons
|
|
|
|
pure function int_cast (x) result (val)
|
|
class(*), intent(in) :: x
|
|
integer :: val
|
|
|
|
select type (x)
|
|
type is (integer)
|
|
val = x
|
|
class default
|
|
error stop
|
|
end select
|
|
end function int_cast
|
|
|
|
pure function int_eq (x, y) result (bool)
|
|
class(*), intent(in) :: x
|
|
class(*), intent(in) :: y
|
|
logical :: bool
|
|
|
|
bool = (int_cast (x) == int_cast (y))
|
|
end function int_eq
|
|
|
|
subroutine check_garbage
|
|
if (aggressive_garbage_collection) then
|
|
call collect_garbage_now
|
|
else
|
|
call check_heap_size
|
|
end if
|
|
end subroutine check_garbage
|
|
|
|
end program example__n_queens
|