同じ大きさに分割(CodeIQ)

CodeIQ @masuipeoさんの問題「同じ大きさに分割」を解いた。今回の問題は、m×n個のマスからなる領域を、連結な二つの領域に分割せよ、というもの。

バッジを貰えたのでソースコードを公開しておく。といってもこれはオリジナルの回答ではなくて、フィードバックを見た後で高速化のための改良を施してある。言語は例によってFortran。

!****************************************************************************
!
    program divide
!
!****************************************************************************
    implicit none
    integer, parameter :: nstde = 0
 
    ! 変数
    integer :: l, m, n, ss, ans
    integer, allocatable :: c(:)
    ! m : number of lows
    ! n : number of columns
    ! l = m*n
    ! ss : number of red
    ! c(0:l-1) : i-th cell's color is red if c(i) = 1
    !                                 blue if c(i) = 0
    ! ans : answer
 
    read(*, *)m, n, ss
    l = m*n
    allocate(c(0:l-1))
    ans = 0
    open(11, file = 'ans.txt', status = 'unknown')
    write(11, 1000)m, n, ss
    1000 format('# m, n, ss = ', 3(1x, i3))
    c=0
    c(0)=1
    call gen(l, m, n, ss, c, 0, 1, ans)
    write(11, 1100)ans
    write(nstde, 1100)ans
    1100 format('# ans = ', i6)
 
    end program divide
 
!****************************************************************************
    recursive subroutine gen(l, m, n, ss, c, r, s, ans)
!****************************************************************************
    implicit none
    integer, parameter :: nstde = 0
 
    integer, intent(in) :: l, m, n, ss
    integer, intent(inout) :: c(0:l-1)
    integer, intent(in) :: r, s
    integer, intent(inout) :: ans
 
    integer :: i

    if(l-1-r < ss-s)then
        return
    elseif(s == ss)then
        call check(l, m, n, ss, c, ans)
    else
        do i = r+1, l-1
            c(r+1:l-1) = 0
            c(i) = 1
            call gen(l, m, n, ss, c, i, s+1, ans)
        enddo
    endif
    end subroutine gen
 
!****************************************************************************
    subroutine check(l, m, n, ss, c, ans)
!****************************************************************************  
    implicit none
    integer, parameter :: nstde = 0
    integer, intent(in) :: l, m, n, ss, c(0:l-1)
    integer, intent(inout) :: ans
    integer :: d(0:l)
    ! d : 連結かどうかを調べる為の一時領域
    integer :: i, j, k, kk
 
    d = 0
    d(0) = 1
    do k = 1, l-1
        if(c(k) == 0)then
            d(k) = 1
            exit
        endif
    enddo
 
    do kk = 1, max(ss, l-ss)
        do k = 0, l-1
            if(mod(k, n) > 0)then
                if(c(k-1) == c(k) .and. d(k-1) == 1)d(k) = 1
            endif
            if(mod(k, n) < n-1)then
                if(c(k+1) == c(k) .and. d(k+1) == 1)d(k) = 1
            endif
            if(k/n > 0)then
                if(c(k-n) == c(k) .and. d(k-n) == 1)d(k) = 1
            endif
            if(k/n < m-1)then
                if(c(k+n) == c(k) .and. d(k+n) == 1)d(k) = 1
            endif
        enddo
    enddo
    if(sum(d) == l)then
        ans = ans+1
        do i = 0, m-1
            write(11, 1000) (c(i*n+j), j = 0, n-1)
            1000 format(100(1x, i2))
        enddo
        write(11, *)
    endif
    end subroutine check