Peaceful chess queen armies: Difference between revisions
→{{header|Go}}
Line 2,581:
◦ • ◦ W ◦ • ◦
W ◦ W W • ◦ • </pre>
=={{header|Fortran}}==
{{works with|gfortran|11.2.1}}
There are two Fortran programs and a driver script. One program generates a Fortran module for basic operations; the other program (which must be linked with the generated module) does the actual work. The driver script is for Unix shell.
Here is the first program, '''peaceful_queens_elements_generator.f90''', which generates code to deal with the representations of the armies as integers:
<lang fortran>program peaceful_queens_elements_generator
use, intrinsic :: iso_fortran_env, only: int64
use, intrinsic :: iso_fortran_env, only: error_unit
implicit none
! 64-bit integers, for boards up to 8-by-8.
integer, parameter :: kind8x8 = int64
! 128-bit integers, for boards up to 11-by-11.
! This value is correct for gfortran.
integer, parameter :: kind11x11 = 16
integer(kind = kind11x11), parameter :: one = 1
integer(kind = kind11x11), parameter :: two = 2
integer, parameter :: n_max = 11
integer(kind = kind11x11) :: rook1_masks(0 : n_max - 1)
integer(kind = kind11x11) :: rook2_masks(0 : n_max - 1)
integer(kind = kind11x11) :: bishop1_masks(0 : (2 * n_max) - 4)
integer(kind = kind11x11) :: bishop2_masks(0 : (2 * n_max) - 4)
! Combines rook1_masks and rook2_masks.
integer(kind = kind11x11) :: rook_masks(0 : (2 * n_max) - 1)
! Combines bishop1_masks and bishop2_masks.
integer(kind = kind11x11) :: bishop_masks(0 : (4 * n_max) - 7)
! Combines rook and bishop masks.
integer(kind = kind11x11) :: queen_masks(0 : (6 * n_max) - 7)
character(len = 16), parameter :: s_kind8x8 = "kind8x8 "
character(len = 16), parameter :: s_kind11x11 = "kind11x11 "
character(200) :: arg
integer :: arg_count
integer :: m, n, max_solutions
integer :: board_kind
arg_count = command_argument_count ()
if (arg_count /= 3) then
call get_command_argument (0, arg)
write (error_unit, '("Usage: ", A, " M N MAX_SOLUTIONS")') trim (arg)
stop 1
end if
call get_command_argument (1, arg)
read (arg, *) m
if (m < 1) then
write (error_unit, '("M must be between 1 or greater.")')
stop 2
end if
call get_command_argument (2, arg)
read (arg, *) n
if (n < 3 .or. 11 < n) then
write (error_unit, '("N must be between 3 and ", I0, ", inclusive.")') n_max
stop 2
end if
call get_command_argument (3, arg)
read (arg, *) max_solutions
write (*, '("module peaceful_queens_elements")')
write (*, '()')
write (*, '(" use, intrinsic :: iso_fortran_env, only: int64")')
write (*, '()')
write (*, '(" implicit none")')
write (*, '(" private")')
write (*, '()')
write (*, '(" integer, parameter, public :: m = ", I0)') m
write (*, '(" integer, parameter, public :: n = ", I0)') n
write (*, '(" integer, parameter, public :: max_solutions = ", I0)') max_solutions
write (*, '()')
if (n <= 8) then
write (*, '(" ! 64-bit integers, for boards up to 8-by-8.")')
write (*, '(" integer, parameter, private :: kind8x8 = int64")')
else
write (*, '(" ! 128-bit integers, for boards up to 11-by-11.")')
write (*, '(" integer, parameter, private :: kind11x11 = ", I0)') kind11x11
end if
write (*, '(" integer, parameter, public :: board_kind = ", A)') trim (s_kindnxn (n))
write (*, '()')
write (*, '()')
write (*, '(" public :: rooks1_attack_check")')
write (*, '(" public :: rooks2_attack_check")')
write (*, '(" public :: rooks_attack_check")')
write (*, '(" public :: bishops1_attack_check")')
write (*, '(" public :: bishops2_attack_check")')
write (*, '(" public :: bishops_attack_check")')
write (*, '(" public :: queens_attack_check")')
write (*, '()')
write (*, '(" public :: board_rotate90")')
write (*, '(" public :: board_rotate180")')
write (*, '(" public :: board_rotate270")')
write (*, '(" public :: board_reflect1")')
write (*, '(" public :: board_reflect2")')
write (*, '(" public :: board_reflect3")')
write (*, '(" public :: board_reflect4")')
write (*, '()')
call write_rook1_masks
call write_rook2_masks
call write_bishop1_masks
call write_bishop2_masks
call write_rook_masks
call write_bishop_masks
call write_queen_masks
write (*, '("contains")')
write (*, '()')
call write_rooks1_attack_check
call write_rooks2_attack_check
call write_bishops1_attack_check
call write_bishops2_attack_check
call write_rooks_attack_check
call write_bishops_attack_check
call write_queens_attack_check
call write_board_rotate90
call write_board_rotate180
call write_board_rotate270
call write_board_reflect1
call write_board_reflect2
call write_board_reflect3
call write_board_reflect4
call write_insert_zeros
call write_reverse_insert_zeros
write (*, '("end module peaceful_queens_elements")')
contains
subroutine write_rook1_masks
integer :: i
call fill_masks (n)
do i = 0, n - 1
write (*, '(" integer(kind = ", A, "), parameter :: rook1_mask_",&
& I0, "x", I0, "_", I0, " = int (z''", Z0.32, "'', kind &
&= ", A, ")")') trim (s_kindnxn (n)), n, n, i,&
& rook1_masks(i), trim (s_kindnxn (n))
end do
write (*, '()')
end subroutine write_rook1_masks
subroutine write_rook2_masks
integer :: i
call fill_masks (n)
do i = 0, n - 1
write (*, '(" integer(kind = ", A, "), parameter :: rook2_mask_",&
& I0, "x", I0, "_", I0, " = int (z''", Z0.32, "'', kind &
&= ", A, ")")') trim (s_kindnxn (n)), n, n, i,&
& rook2_masks(i), trim (s_kindnxn (n))
end do
write (*, '()')
end subroutine write_rook2_masks
subroutine write_bishop1_masks
integer :: i
call fill_masks (n)
do i = 0, (2 * n) - 4
write (*, '(" integer(kind = ", A, "), parameter :: bishop1_mask_",&
& I0, "x", I0, "_", I0, " = int (z''", Z0.32, "'', kind &
&= ", A, ")")') trim (s_kindnxn (n)), n, n, i,&
& bishop1_masks(i), trim (s_kindnxn (n))
end do
write (*, '()')
end subroutine write_bishop1_masks
subroutine write_bishop2_masks
integer :: i
call fill_masks (n)
do i = 0, (2 * n) - 4
write (*, '(" integer(kind = ", A, "), parameter :: bishop2_mask_",&
& I0, "x", I0, "_", I0, " = int (z''", Z0.32, "'', kind &
&= ", A, ")")') trim (s_kindnxn (n)), n, n, i,&
& bishop2_masks(i), trim (s_kindnxn (n))
end do
write (*, '()')
end subroutine write_bishop2_masks
subroutine write_rook_masks
integer :: i
call fill_masks (n)
do i = 0, (2 * n) - 1
write (*, '(" integer(kind = ", A, "), parameter :: rook_mask_",&
& I0, "x", I0, "_", I0, " = int (z''", Z0.32, "'', kind &
&= ", A, ")")') trim (s_kindnxn (n)), n, n, i,&
& rook_masks(i), trim (s_kindnxn (n))
end do
write (*, '()')
end subroutine write_rook_masks
subroutine write_bishop_masks
integer :: i
call fill_masks (n)
do i = 0, (4 * n) - 7
write (*, '(" integer(kind = ", A, "), parameter :: bishop_mask_",&
& I0, "x", I0, "_", I0, " = int (z''", Z0.32, "'', kind &
&= ", A, ")")') trim (s_kindnxn (n)), n, n, i,&
& bishop_masks(i), trim (s_kindnxn (n))
end do
write (*, '()')
end subroutine write_bishop_masks
subroutine write_queen_masks
integer :: i
call fill_masks (n)
do i = 0, (6 * n) - 7
write (*, '(" integer(kind = ", A, "), parameter :: queen_mask_",&
& I0, "x", I0, "_", I0, " = int (z''", Z0.32, "'', kind &
&= ", A, ")")') trim (s_kindnxn (n)), n, n, i,&
& queen_masks(i), trim (s_kindnxn (n))
end do
write (*, '()')
end subroutine write_queen_masks
subroutine write_rooks1_attack_check
integer :: i
write (*, '(" elemental function rooks1_attack_check (army1, army2) result (attacking)")')
write (*, '(" integer(kind = ", A, "), value :: army1, army2")') trim (s_kindnxn (n))
write (*, '(" logical :: attacking")')
write (*, '()')
write (*, '(" attacking = ((iand (army1, rook1_mask_", I0, "x", I0,&
& "_0) /= 0) .and. (iand (army2, rook1_mask_", I0, "x", I0, "_0) /=&
& 0)) .or. &")') n, n, n, n
do i = 1, n - 1
write (*, '(" & ((iand (army1, rook1_mask_", I0, "x",&
& I0, "_", I0, ") /= 0) .and. (iand (army2, rook1_mask_", I0,&
& "x", I0, "_", I0, ") /= 0))")', advance = 'no') n, n, i, n, n, i
if (i /= n - 1) then
write (*, '(" .or. &")')
else
write (*, '()')
end if
end do
write (*, '(" end function rooks1_attack_check")')
write (*, '()')
end subroutine write_rooks1_attack_check
subroutine write_rooks2_attack_check
integer :: i
write (*, '(" elemental function rooks2_attack_check (army1, army2) result (attacking)")')
write (*, '(" integer(kind = ", A, "), value :: army1, army2")') trim (s_kindnxn (n))
write (*, '(" logical :: attacking")')
write (*, '()')
write (*, '(" attacking = ((iand (army1, rook2_mask_", I0, "x", I0,&
& "_0) /= 0) .and. (iand (army2, rook2_mask_", I0, "x", I0, "_0) /=&
& 0)) .or. &")') n, n, n, n
do i = 1, n - 1
write (*, '(" & ((iand (army1, rook2_mask_", I0, "x",&
& I0, "_", I0, ") /= 0) .and. (iand (army2, rook2_mask_", I0,&
& "x", I0, "_", I0, ") /= 0))")', advance = 'no') n, n, i, n, n, i
if (i /= n - 1) then
write (*, '(" .or. &")')
else
write (*, '()')
end if
end do
write (*, '(" end function rooks2_attack_check")')
write (*, '()')
end subroutine write_rooks2_attack_check
subroutine write_bishops1_attack_check
integer :: i
write (*, '(" elemental function bishops1_attack_check (army1, army2) result (attacking)")')
write (*, '(" integer(kind = ", A, "), value :: army1, army2")') trim (s_kindnxn (n))
write (*, '(" logical :: attacking")')
write (*, '()')
write (*, '(" attacking = ((iand (army1, bishop1_mask_", I0, "x", I0,&
& "_0) /= 0) .and. (iand (army2, bishop1_mask_", I0, "x", I0, "_0) /=&
& 0)) .or. &")') n, n, n, n
do i = 1, (2 * n) - 4
write (*, '(" & ((iand (army1, bishop1_mask_", I0, "x",&
& I0, "_", I0, ") /= 0) .and. (iand (army2, bishop1_mask_", I0,&
& "x", I0, "_", I0, ") /= 0))")', advance = 'no') n, n, i, n, n, i
if (i /= (2 * n) - 4) then
write (*, '(" .or. &")')
else
write (*, '()')
end if
end do
write (*, '(" end function bishops1_attack_check")')
write (*, '()')
end subroutine write_bishops1_attack_check
subroutine write_bishops2_attack_check
integer :: i
write (*, '(" elemental function bishops2_attack_check (army1, army2) result (attacking)")')
write (*, '(" integer(kind = ", A, "), value :: army1, army2")') trim (s_kindnxn (n))
write (*, '(" logical :: attacking")')
write (*, '()')
write (*, '(" attacking = ((iand (army1, bishop2_mask_", I0, "x", I0,&
& "_0) /= 0) .and. (iand (army2, bishop2_mask_", I0, "x", I0, "_0) /=&
& 0)) .or. &")') n, n, n, n
do i = 1, (2 * n) - 4
write (*, '(" & ((iand (army1, bishop2_mask_", I0, "x",&
& I0, "_", I0, ") /= 0) .and. (iand (army2, bishop2_mask_", I0,&
& "x", I0, "_", I0, ") /= 0))")', advance = 'no') n, n, i, n, n, i
if (i /= (2 * n) - 4) then
write (*, '(" .or. &")')
else
write (*, '()')
end if
end do
write (*, '(" end function bishops2_attack_check")')
write (*, '()')
end subroutine write_bishops2_attack_check
subroutine write_rooks_attack_check
integer :: i
write (*, '(" elemental function rooks_attack_check (army1, army2) result (attacking)")')
write (*, '(" integer(kind = ", A, "), value :: army1, army2")') trim (s_kindnxn (n))
write (*, '(" logical :: attacking")')
write (*, '()')
write (*, '(" attacking = ((iand (army1, rook_mask_", I0, "x", I0,&
& "_0) /= 0) .and. (iand (army2, rook_mask_", I0, "x", I0, "_0) /=&
& 0)) .or. &")') n, n, n, n
do i = 1, (2 * n) - 1
write (*, '(" & ((iand (army1, rook_mask_", I0, "x",&
& I0, "_", I0, ") /= 0) .and. (iand (army2, rook_mask_", I0,&
& "x", I0, "_", I0, ") /= 0))")', advance = 'no') n, n, i, n, n, i
if (i /= (2 * n) - 1) then
write (*, '(" .or. &")')
else
write (*, '()')
end if
end do
write (*, '(" end function rooks_attack_check")')
write (*, '()')
end subroutine write_rooks_attack_check
subroutine write_bishops_attack_check
integer :: i
write (*, '(" elemental function bishops_attack_check (army1, army2) result (attacking)")')
write (*, '(" integer(kind = ", A, "), value :: army1, army2")') trim (s_kindnxn (n))
write (*, '(" logical :: attacking")')
write (*, '()')
write (*, '(" attacking = ((iand (army1, bishop_mask_", I0, "x", I0,&
& "_0) /= 0) .and. (iand (army2, bishop_mask_", I0, "x", I0, "_0) /=&
& 0)) .or. &")') n, n, n, n
do i = 1, (4 * n) - 7
write (*, '(" & ((iand (army1, bishop_mask_", I0, "x",&
& I0, "_", I0, ") /= 0) .and. (iand (army2, bishop_mask_", I0,&
& "x", I0, "_", I0, ") /= 0))")', advance = 'no') n, n, i, n, n, i
if (i /= (4 * n) - 7) then
write (*, '(" .or. &")')
else
write (*, '()')
end if
end do
write (*, '(" end function bishops_attack_check")')
write (*, '()')
end subroutine write_bishops_attack_check
subroutine write_queens_attack_check
integer :: i
write (*, '(" elemental function queens_attack_check (army1, army2) result (attacking)")')
write (*, '(" integer(kind = ", A, "), value :: army1, army2")') trim (s_kindnxn (n))
write (*, '(" logical :: attacking")')
write (*, '()')
write (*, '(" attacking = ((iand (army1, queen_mask_", I0, "x", I0,&
& "_0) /= 0) .and. (iand (army2, queen_mask_", I0, "x", I0, "_0) /=&
& 0)) .or. &")') n, n, n, n
do i = 1, (6 * n) - 7
write (*, '(" & ((iand (army1, queen_mask_", I0, "x",&
& I0, "_", I0, ") /= 0) .and. (iand (army2, queen_mask_", I0,&
& "x", I0, "_", I0, ") /= 0))")', advance = 'no') n, n, i, n, n, i
if (i /= (6 * n) - 7) then
write (*, '(" .or. &")')
else
write (*, '()')
end if
end do
write (*, '(" end function queens_attack_check")')
write (*, '()')
end subroutine write_queens_attack_check
subroutine write_board_rotate90
integer :: i, j
write (*, '(" elemental function board_rotate90 (a) result (b)")')
write (*, '(" integer(kind = ", A, "), value :: a")') trim (s_kindnxn (n))
write (*, '(" integer(kind = ", A, ") :: b")') trim (s_kindnxn (n))
write (*, '()')
write (*, '(" ! Rotation 90 degrees in one of the orientations.")')
write (*, '()')
do i = 0, n - 1
if (i == 0) then
write (*, '(" b = ")', advance = 'no')
else
write (*, '(" & ")', advance = 'no')
do j = 1, i
write (*, '(" ")', advance = 'no')
end do
end if
if (i /= n - 1) then
write (*, '("ior (ishft (reverse_insert_zeros_", I0, " (ishft&
& (iand (rook1_mask_", I0, "x", I0, "_", I0, ", a), ",&
& I0, ")), ", I0, "), &")') n, n, n, i, -i * n, i
else
write (*, '(" ishft (reverse_insert_zeros_", I0, " (ishft&
& (iand (rook1_mask_", I0, "x", I0, "_", I0, ", a), ",&
& I0, ")), ", I0, ")")', advance = 'no') n, n, n, i, -i * n, i
do j = 1, n - 1
write (*, '(")")', advance = 'no')
end do
write (*, '()')
end if
end do
write (*, '(" end function board_rotate90")')
write (*, '()')
end subroutine write_board_rotate90
subroutine write_board_rotate180
write (*, '(" elemental function board_rotate180 (a) result (b)")')
write (*, '(" integer(kind = ", A, "), value :: a")') trim (s_kindnxn (n))
write (*, '(" integer(kind = ", A, ") :: b")') trim (s_kindnxn (n))
write (*, '()')
write (*, '(" ! Rotation 180 degrees.")')
write (*, '()')
write (*, '(" b = board_reflect1 (board_reflect2 (a))")')
write (*, '(" end function board_rotate180")')
write (*, '()')
end subroutine write_board_rotate180
subroutine write_board_rotate270
integer :: i, j
write (*, '(" elemental function board_rotate270 (a) result (b)")')
write (*, '(" integer(kind = ", A, "), value :: a")') trim (s_kindnxn (n))
write (*, '(" integer(kind = ", A, ") :: b")') trim (s_kindnxn (n))
write (*, '()')
write (*, '(" ! Rotation 270 degrees in one of the orientations.")')
write (*, '()')
do i = 0, n - 1
if (i == 0) then
write (*, '(" b = ")', advance = 'no')
else
write (*, '(" & ")', advance = 'no')
do j = 1, i
write (*, '(" ")', advance = 'no')
end do
end if
if (i /= n - 1) then
write (*, '("ior (ishft (insert_zeros_", I0, " (ishft&
& (iand (rook1_mask_", I0, "x", I0, "_", I0, ", a), ",&
& I0, ")), ", I0, "), &")') n, n, n, i, -i * n, n - 1 - i
else
write (*, '(" ishft (insert_zeros_", I0, " (ishft&
& (iand (rook1_mask_", I0, "x", I0, "_", I0, ", a), ",&
& I0, ")), ", I0, ")")', advance = 'no') n, n, n, i, -i * n, n - 1 - i
do j = 1, n - 1
write (*, '(")")', advance = 'no')
end do
write (*, '()')
end if
end do
write (*, '(" end function board_rotate270")')
write (*, '()')
end subroutine write_board_rotate270
subroutine write_board_reflect1
integer :: i, j
write (*, '(" elemental function board_reflect1 (a) result (b)")')
write (*, '(" integer(kind = ", A, "), value :: a")') trim (s_kindnxn (n))
write (*, '(" integer(kind = ", A, ") :: b")') trim (s_kindnxn (n))
write (*, '()')
write (*, '(" ! Reflection of rows or columns.")')
write (*, '()')
do i = 0, n - 1
if (i == 0) then
write (*, '(" b = ")', advance = 'no')
else
write (*, '(" & ")', advance = 'no')
do j = 1, i
write (*, '(" ")', advance = 'no')
end do
end if
if (i /= n - 1) then
write (*, '("ior (ishft (iand (rook2_mask_", I0, "x", I0, "_", I0, ", a), ", I0, "), &")') &
& n, n, i, (n - 1) - (2 * i)
else
write (*, '("ishft (iand (rook2_mask_", I0, "x", I0, "_", I0, ", a), ", I0, ")")', advance = 'no') &
& n, n, i, (n - 1) - (2 * i)
do j = 1, n - 1
write (*, '(")")', advance = 'no')
end do
write (*, '()')
end if
end do
write (*, '(" end function board_reflect1")')
write (*, '()')
end subroutine write_board_reflect1
subroutine write_board_reflect2
integer :: i, j
write (*, '(" elemental function board_reflect2 (a) result (b)")')
write (*, '(" integer(kind = ", A, "), value :: a")') trim (s_kindnxn (n))
write (*, '(" integer(kind = ", A, ") :: b")') trim (s_kindnxn (n))
write (*, '()')
write (*, '(" ! Reflection of rows or columns.")')
write (*, '()')
do i = 0, n - 1
if (i == 0) then
write (*, '(" b = ")', advance = 'no')
else
write (*, '(" & ")', advance = 'no')
do j = 1, i
write (*, '(" ")', advance = 'no')
end do
end if
if (i /= n - 1) then
write (*, '("ior (ishft (iand (rook1_mask_", I0, "x", I0, "_", I0, ", a), ", I0, "), &")') &
& n, n, i, n * ((n - 1) - (2 * i))
else
write (*, '("ishft (iand (rook1_mask_", I0, "x", I0, "_", I0, ", a), ", I0, ")")', advance = 'no') &
& n, n, i, n * ((n - 1) - (2 * i))
do j = 1, n - 1
write (*, '(")")', advance = 'no')
end do
write (*, '()')
end if
end do
write (*, '(" end function board_reflect2")')
write (*, '()')
end subroutine write_board_reflect2
subroutine write_board_reflect3
integer :: i, j
write (*, '(" elemental function board_reflect3 (a) result (b)")')
write (*, '(" integer(kind = ", A, "), value :: a")') trim (s_kindnxn (n))
write (*, '(" integer(kind = ", A, ") :: b")') trim (s_kindnxn (n))
write (*, '()')
write (*, '(" ! Reflection around one of the two main diagonals.")')
write (*, '()')
do i = 0, n - 1
if (i == 0) then
write (*, '(" b = ")', advance = 'no')
else
write (*, '(" & ")', advance = 'no')
do j = 1, i
write (*, '(" ")', advance = 'no')
end do
end if
if (i /= n - 1) then
write (*, '("ior (ishft (insert_zeros_", I0, " (ishft&
& (iand (rook1_mask_", I0, "x", I0, "_", I0, ", a), ",&
& I0, ")), ", I0, "), &")') n, n, n, i, -i * n, i
else
write (*, '(" ishft (insert_zeros_", I0, " (ishft&
& (iand (rook1_mask_", I0, "x", I0, "_", I0, ", a), ",&
& I0, ")), ", I0, ")")', advance = 'no') n, n, n, i, -i * n, i
do j = 1, n - 1
write (*, '(")")', advance = 'no')
end do
write (*, '()')
end if
end do
write (*, '(" end function board_reflect3")')
write (*, '()')
end subroutine write_board_reflect3
subroutine write_board_reflect4
integer :: i, j
write (*, '(" elemental function board_reflect4 (a) result (b)")')
write (*, '(" integer(kind = ", A, "), value :: a")') trim (s_kindnxn (n))
write (*, '(" integer(kind = ", A, ") :: b")') trim (s_kindnxn (n))
write (*, '()')
write (*, '(" ! Reflection around one of the two main diagonals.")')
write (*, '()')
do i = 0, n - 1
if (i == 0) then
write (*, '(" b = ")', advance = 'no')
else
write (*, '(" & ")', advance = 'no')
do j = 1, i
write (*, '(" ")', advance = 'no')
end do
end if
if (i /= n - 1) then
write (*, '("ior (ishft (reverse_insert_zeros_", I0, " (ishft&
& (iand (rook1_mask_", I0, "x", I0, "_", I0, ", a), ",&
& I0, ")), ", I0, "), &")') n, n, n, i, -i * n, n - 1 - i
else
write (*, '(" ishft (reverse_insert_zeros_", I0, " (ishft&
& (iand (rook1_mask_", I0, "x", I0, "_", I0, ", a), ",&
& I0, ")), ", I0, ")")', advance = 'no') n, n, n, i, -i * n, n - 1 - i
do j = 1, n - 1
write (*, '(")")', advance = 'no')
end do
write (*, '()')
end if
end do
write (*, '(" end function board_reflect4")')
write (*, '()')
end subroutine write_board_reflect4
subroutine write_insert_zeros
integer :: i, j
write (*, '(" elemental function insert_zeros_", I0, " (a) result (b)")') n
write (*, '(" integer(kind = ", A, "), value :: a")') trim (s_kindnxn (n))
write (*, '(" integer(kind = ", A, ") :: b")') trim (s_kindnxn (n))
write (*, '()')
do i = 0, n - 1
if (i == 0) then
write (*, '(" b = ")', advance = 'no')
else
write (*, '(" & ")', advance = 'no')
do j = 1, i
write (*, '(" ")', advance = 'no')
end do
end if
if (i /= n - 1) then
write (*, '("ior (ishft (ibits (a, ", I0, ", 1), ", I0, "), &")') i, i * n
else
write (*, '("ishft (ibits (a, ", I0, ", 1), ", I0, ")")', advance = 'no') i, i * n
do j = 1, n - 1
write (*, '(")")', advance = 'no')
end do
write (*, '()')
end if
end do
write (*, '(" end function insert_zeros_", I0)') n
write (*, '()')
end subroutine write_insert_zeros
subroutine write_reverse_insert_zeros
integer :: i, j
write (*, '(" elemental function reverse_insert_zeros_", I0, " (a) result (b)")') n
write (*, '(" integer(kind = ", A, "), value :: a")') trim (s_kindnxn (n))
write (*, '(" integer(kind = ", A, ") :: b")') trim (s_kindnxn (n))
write (*, '()')
do i = 0, n - 1
if (i == 0) then
write (*, '(" b = ")', advance = 'no')
else
write (*, '(" & ")', advance = 'no')
do j = 1, i
write (*, '(" ")', advance = 'no')
end do
end if
if (i /= n - 1) then
write (*, '("ior (ishft (ibits (a, ", I0, ", 1), ", I0, "), &")') n - 1 - i, i * n
else
write (*, '("ishft (ibits (a, ", I0, ", 1), ", I0, ")")', advance = 'no') n - 1 - i, i * n
do j = 1, n - 1
write (*, '(")")', advance = 'no')
end do
write (*, '()')
end if
end do
write (*, '(" end function reverse_insert_zeros_", I0)') n
write (*, '()')
end subroutine write_reverse_insert_zeros
function s_kindnxn (n) result (s)
integer, intent(in) :: n
character(len = 16) :: s
if (n <= 8) then
s = s_kind8x8
else
s = s_kind11x11
end if
end function s_kindnxn
subroutine fill_masks (n)
integer, intent(in) :: n
call fill_rook1_masks (n)
call fill_rook2_masks (n)
call fill_bishop1_masks (n)
call fill_bishop2_masks (n)
call fill_rook_masks (n)
call fill_bishop_masks (n)
call fill_queen_masks (n)
end subroutine fill_masks
subroutine fill_rook1_masks (n)
integer, intent(in) :: n
integer :: i
integer(kind = kind11x11) :: mask
mask = (two ** n) - 1
do i = 0, n - 1
rook1_masks(i) = mask
mask = ishft (mask, n)
end do
end subroutine fill_rook1_masks
subroutine fill_rook2_masks (n)
integer, intent(in) :: n
integer :: i
integer(kind = kind11x11) :: mask
mask = 0
do i = 0, n - 1
mask = ior (ishft (mask, n), one)
end do
do i = 0, n - 1
rook2_masks(i) = mask
mask = ishft (mask, 1)
end do
end subroutine fill_rook2_masks
subroutine fill_bishop1_masks (n)
integer, intent(in) :: n
integer :: i, j, k
integer(kind = kind11x11) :: mask0, mask1
! Masks for diagonals. Put them in order from most densely
! populated to least densely populated.
do k = 0, n - 2
mask0 = 0
mask1 = 0
do i = k, n - 1
j = i - k
mask0 = ior (mask0, ishft (one, i + (j * n)))
mask1 = ior (mask1, ishft (one, j + (i * n)))
end do
if (k == 0) then
bishop1_masks(0) = mask0
else
bishop1_masks((2 * k) - 1) = mask0
bishop1_masks(2 * k) = mask1
end if
end do
end subroutine fill_bishop1_masks
subroutine fill_bishop2_masks (n)
integer, intent(in) :: n
integer :: i, j, k
integer :: i1, j1
integer(kind = kind11x11) :: mask0, mask1
! Masks for skew diagonals. Put them in order from most densely
! populated to least densely populated.
do k = 0, n - 2
mask0 = 0
mask1 = 0
do i = k, n - 1
j = i - k
i1 = n - 1 - i
j1 = n - 1 - j
mask0 = ior (mask0, ishft (one, j + (i1 * n)))
mask1 = ior (mask1, ishft (one, i + (j1 * n)))
end do
if (k == 0) then
bishop2_masks(0) = mask0
else
bishop2_masks((2 * k) - 1) = mask0
bishop2_masks(2 * k) = mask1
end if
end do
end subroutine fill_bishop2_masks
subroutine fill_rook_masks (n)
integer, intent(in) :: n
rook_masks(0 : n - 1) = rook1_masks
rook_masks(n : (2 * n) - 1) = rook2_masks
end subroutine fill_rook_masks
subroutine fill_bishop_masks (n)
integer, intent(in) :: n
integer :: i
! Put the masks in order from most densely populated to least
! densely populated.
do i = 0, (2 * n) - 4
bishop_masks(2 * i) = bishop1_masks(i)
bishop_masks((2 * i) + 1) = bishop2_masks(i)
end do
end subroutine fill_bishop_masks
subroutine fill_queen_masks (n)
integer, intent(in) :: n
queen_masks(0 : (2 * n) - 1) = rook_masks
queen_masks(2 * n : (6 * n) - 7) = bishop_masks
end subroutine fill_queen_masks
end program peaceful_queens_elements_generator</lang>
Here is the second program, '''peaceful_queens.f90''':
<lang fortran>module peaceful_queens_support
use, non_intrinsic :: peaceful_queens_elements
implicit none
private
public :: write_board
public :: write_board_without_spaces
public :: write_board_with_spaces
public :: save_a_solution
interface write_board
module procedure write_board_without_spaces
module procedure write_board_with_spaces
end interface write_board
contains
subroutine write_board_without_spaces (unit, army_b, army_w)
integer, intent(in) :: unit
integer(kind = board_kind), intent(in) :: army_b, army_w
call write_board_with_spaces (unit, army_b, army_w, 0)
end subroutine write_board_without_spaces
subroutine write_board_with_spaces (unit, army_b, army_w, num_spaces)
integer, intent(in) :: unit
integer(kind = board_kind), intent(in) :: army_b, army_w
integer, intent(in) :: num_spaces
integer(kind = board_kind), parameter :: zero = 0
integer(kind = board_kind), parameter :: one = 1
integer :: i, j
integer(kind = board_kind) :: rank_b, rank_w
integer(kind = board_kind) :: mask
character(1), allocatable :: queens(:)
character(4), allocatable :: rules(:)
character(1), allocatable :: spaces(:)
allocate (queens(0 : n - 1))
allocate (rules(0 : n - 1))
allocate (spaces(1 : num_spaces))
rules = "----"
if (0 < num_spaces) then
spaces = " " ! For putting spaces after newlines.
end if
mask = not (ishft (not (zero), n))
write (unit, '("+", 100(A4, "+"))') rules
do i = 0, n - 1
rank_b = iand (mask, ishft (army_b, -i * n))
rank_w = iand (mask, ishft (army_w, -i * n))
do j = 0, n - 1
if (iand (rank_b, ishft (one, j)) /= 0) then
queens(j) = "B"
else if (iand (rank_w, ishft (one, j)) /= 0) then
queens(j) = "W"
else
queens(j) = " "
end if
end do
write (unit, '(100A1)', advance = 'no') spaces
write (unit, '("|", 100(A3, " |"))') queens
write (unit, '(100A1)', advance = 'no') spaces
if (i /= n - 1) then
write (unit, '("+", 100(A4, "+"))') rules
else
write (unit, '("+", 100(A4, "+"))', advance = 'no') rules
end if
end do
end subroutine write_board_with_spaces
subroutine save_a_solution (army1, army2, num_solutions, armies1, armies2)
integer(kind = board_kind), intent(in) :: army1, army2
integer, intent(inout) :: num_solutions
integer(kind = board_kind), intent(inout) :: armies1(1:8, 1:max_solutions)
integer(kind = board_kind), intent(inout) :: armies2(1:8, 1:max_solutions)
! A sanity check.
if (queens_attack_check (army1, army2)) then
error stop
end if
num_solutions = num_solutions + 1
armies1(1, num_solutions) = army1
armies1(2, num_solutions) = board_rotate90 (army1)
armies1(3, num_solutions) = board_rotate180 (army1)
armies1(4, num_solutions) = board_rotate270 (army1)
armies1(5, num_solutions) = board_reflect1 (army1)
armies1(6, num_solutions) = board_reflect2 (army1)
armies1(7, num_solutions) = board_reflect3 (army1)
armies1(8, num_solutions) = board_reflect4 (army1)
armies2(1, num_solutions) = army2
armies2(2, num_solutions) = board_rotate90 (army2)
armies2(3, num_solutions) = board_rotate180 (army2)
armies2(4, num_solutions) = board_rotate270 (army2)
armies2(5, num_solutions) = board_reflect1 (army2)
armies2(6, num_solutions) = board_reflect2 (army2)
armies2(7, num_solutions) = board_reflect3 (army2)
armies2(8, num_solutions) = board_reflect4 (army2)
end subroutine save_a_solution
end module peaceful_queens_support
module peaceful_queens_solver
use, non_intrinsic :: peaceful_queens_elements
use, non_intrinsic :: peaceful_queens_support
implicit none
private
public :: solve_peaceful_queens
integer(kind = board_kind), parameter :: zero = 0_board_kind
integer(kind = board_kind), parameter :: one = 1_board_kind
integer(kind = board_kind), parameter :: two = 2_board_kind
contains
subroutine solve_peaceful_queens (unit, show_equivalents, &
& num_solutions, armies1, armies2)
integer, intent(in) :: unit
logical, intent(in) :: show_equivalents
integer, intent(out) :: num_solutions
integer(kind = board_kind), intent(out) :: armies1(1:8, 1:max_solutions)
integer(kind = board_kind), intent(out) :: armies2(1:8, 1:max_solutions)
call solve (zero, 0, 0, zero, 0, 0, 0)
contains
recursive subroutine solve (army1, rooklike11, rooklike12, &
& army2, rooklike21, rooklike22, index)
integer(kind = board_kind), value :: army1
integer, value :: rooklike11, rooklike12
integer(kind = board_kind), value :: army2
integer, value :: rooklike21, rooklike22
integer, value :: index
integer :: num_queens1
integer :: num_queens2
integer(kind = board_kind) :: new_army
integer(kind = board_kind) :: new_army_reversed
integer :: bit1, bit2
logical :: skip
num_queens1 = popcnt (army1)
num_queens2 = popcnt (army2)
if (num_queens1 + num_queens2 == 2 * m) then
if (.not. is_a_duplicate (army1, army2, num_solutions, armies1, armies2)) then
call save_a_solution (army1, army2, num_solutions, armies1, armies2)
write (unit, '("Solution ", I0)') num_solutions
call write_board (unit, army1, army2)
write (unit, '()')
write (unit, '()')
call optionally_write_equivalents
end if
else if (num_queens1 - num_queens2 == 0) then
! It is time to add a queen to army1.
do while (num_solutions < max_solutions .and. index /= n**2)
skip = .false.
new_army = ior (army1, ishft (one, index))
if (new_army == army1) then
skip = .true.
else if (index < n) then
new_army_reversed = board_reflect1 (new_army)
if (new_army_reversed < new_army) then
! Skip a bunch of board_reflect1 equivalents.
skip = .true.
end if
end if
if (skip) then
index = index + 1
else
bit1 = ishft (1, index / n)
bit2 = ishft (1, mod (index, n))
if (iand (rooklike21, bit1) /= 0) then
index = round_up_to_multiple (index + 1, n)
else if (iand (rooklike22, bit2) /= 0) then
index = index + 1
else if (bishops_attack_check (new_army, army2)) then
index = index + 1
else
call solve (new_army, &
& ior (rooklike11, bit1), &
& ior (rooklike12, bit2), &
& army2, rooklike21, rooklike22, &
& n)
index = index + 1
end if
end if
end do
else
! It is time to add a queen to army2.
do while (num_solutions < max_solutions .and. index /= n**2)
new_army = ior (army2, ishft (one, index))
skip = (new_army == army2)
if (skip) then
index = index + 1
else
bit1 = ishft (1, index / n)
bit2 = ishft (1, mod (index, n))
if (iand (rooklike11, bit1) /= 0) then
index = round_up_to_multiple (index + 1, n)
else if (iand (rooklike12, bit2) /= 0) then
index = index + 1
else if (bishops_attack_check (army1, new_army)) then
index = index + 1
else
call solve (army1, rooklike11, rooklike12, &
& new_army, &
& ior (rooklike21, bit1), &
& ior (rooklike22, bit2), &
& 0)
index = index + 1
end if
end if
end do
end if
end subroutine solve
subroutine optionally_write_equivalents
integer :: i
if (show_equivalents) then
write (unit, '(5X)', advance = 'no')
write (unit, '("Equivalents")')
write (unit, '(5X)', advance = 'no')
call write_board (unit, armies2(1, num_solutions), armies1(1, num_solutions), 5)
write (unit, '()')
write (unit, '()')
do i = 2, 5
if (all ((armies1(i, num_solutions) /= armies1(1 : i - 1, num_solutions) .or. &
& armies2(i, num_solutions) /= armies2(1 : i - 1, num_solutions)) .and. &
& (armies2(i, num_solutions) /= armies1(1 : i - 1, num_solutions) .or. &
& armies1(i, num_solutions) /= armies2(1 : i - 1, num_solutions)))) then
write (unit, '(5X)', advance = 'no')
call write_board (unit, armies1(i, num_solutions), armies2(i, num_solutions), 5)
write (unit, '()')
write (unit, '()')
write (unit, '(5X)', advance = 'no')
call write_board (unit, armies2(i, num_solutions), armies1(i, num_solutions), 5)
write (unit, '()')
write (unit, '()')
end if
end do
end if
end subroutine optionally_write_equivalents
end subroutine solve_peaceful_queens
elemental function round_up_to_multiple (x, n) result (y)
integer, value :: x, n
integer :: y
y = x + mod (n - mod (x, n), n)
end function round_up_to_multiple
pure function is_a_duplicate (army1, army2, num_solutions, armies1, armies2) result (is_dup)
integer(kind = board_kind), intent(in) :: army1, army2
integer, intent(in) :: num_solutions
integer(kind = board_kind), intent(in) :: armies1(1:8, 1:max_solutions)
integer(kind = board_kind), intent(in) :: armies2(1:8, 1:max_solutions)
logical :: is_dup
is_dup = any ((army1 == armies1(:, 1:num_solutions) .and. &
& army2 == armies2(:, 1:num_solutions)) .or. &
& (army2 == armies1(:, 1:num_solutions) .and. &
& army1 == armies2(:, 1:num_solutions)))
end function is_a_duplicate
end module peaceful_queens_solver
program peaceful_queens
use, intrinsic :: iso_fortran_env, only: output_unit
use, non_intrinsic :: peaceful_queens_elements
use, non_intrinsic :: peaceful_queens_support
use, non_intrinsic :: peaceful_queens_solver
implicit none
integer :: num_solutions
logical :: show_equivalents
integer(kind = board_kind) :: armies1(1:8, 1:max_solutions)
integer(kind = board_kind) :: armies2(1:8, 1:max_solutions)
integer :: arg_count
character(len = 200) :: arg
show_equivalents = .false.
arg_count = command_argument_count ()
if (1 <= arg_count) then
call get_command_argument (1, arg)
select case (trim (arg))
case ('1', 't', 'T', 'true', 'y', 'Y', 'yes')
show_equivalents = .true.
end select
end if
call solve_peaceful_queens (output_unit, show_equivalents, &
& num_solutions, armies1, armies2)
end program peaceful_queens</lang>
Here is the driver script:
<lang sh>#!/bin/sh
#
# Driver script for peaceful_queens in Fortran.
#
if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1; then
emulate sh
fi
if test $# -ne 3 && test $# -ne 4; then
echo "Usage: $0 M N MAX_SOLUTIONS [SHOW_EQUIVALENTS]"
exit 1
fi
M=${1}
N=${2}
MAX_SOLUTIONS=${3}
SHOW_EQUIVALENTS=${4}
RM_GENERATED_SRC=rm
#RM_GENERATED_SRC=:
CHECK=f
case ${CHECK} in
0 | f | F | false | N | n | no) FCCHECK="" ;;
1 | t | T | true | Y | y | yes) FCCHECK="-fcheck=all" ;;
*) echo 'CHECK is set incorrectly';
exit 1 ;;
esac
FC="gfortran"
FCFLAGS="-std=f2018 -g -O3 -march=native -fno-stack-protector -Wall -Wextra ${FCCHECK}"
# If you have the graphite optimizer, here are some marginally helpful
# flags. They barely make a difference, for me.
FCFLAGS="${FCFLAGS} -funroll-loops -floop-nest-optimize"
RUN_IT="yes"
${FC} -o peaceful_queens_elements_generator peaceful_queens_elements_generator.f90 &&
./peaceful_queens_elements_generator ${M} ${N} ${MAX_SOLUTIONS} > peaceful_queens_elements.f90 &&
${FC} ${FCFLAGS} -c peaceful_queens_elements.f90 &&
${RM_GENERATED_SRC} peaceful_queens_elements.f90 &&
${FC} ${FCFLAGS} -c peaceful_queens.f90 &&
${FC} ${FCFLAGS} -o peaceful_queens peaceful_queens_elements.o peaceful_queens.o &&
if test x"${RUN_IT}" = xyes; then time ./peaceful_queens ${SHOW_EQUIVALENTS}; else :; fi</lang>
=={{header|Go}}==
| |||