夏休みも近いので Fortran2003 の勉強ついでに、カレンダーを作ることにしました。
parametric type を Object-Oriented 機能で用いました。まだ Intel Fortran v.15 beta コンパイラにバグがあるようで debug mode では実行時エラーが出てしまいます。
なお画像の Ascii Art は、こちらのプログラムを用いました。http://fortran66.hatenablog.com/entry/2014/07/01/001238
プリンタに出すとコンソール出力と白黒が反転するので、RGB を反転させました。
module m_hanamoji
implicit none
character(len = 32), parameter :: dig = '0123456789'
type :: t_hana(nrow, ncol)
integer, len :: nrow, ncol
character(len = ncol) :: ch(1:nrow)
contains
procedure :: pr => pr_hana
end type t_hana
type(t_hana(5, 6)) :: digit(0:9)
type(t_hana(7, 8)) :: tsuki(0:10)
type(t_hana(7, 8)) :: youbi(0:7)
character(len = 136) :: screen(64) = ''
contains
subroutine pr_hana(hana_moji, ix, iy)
type(t_hana(*, *)), intent(in) :: hana_moji !
integer, intent(in) :: ix, iy
integer :: irow
do irow = 1, hana_moji%nrow
screen(irow + iy - 1)(ix:ix + hana_moji%ncol - 1) = hana_moji%ch(irow)
end do
end subroutine pr_hana
subroutine print_number(text, ix, iy, center)
character(len = *), intent(in) :: text
integer, intent(in) :: ix, iy
logical, optional, intent(in) :: center
integer :: i, k, ix0
ix0 = 0
if (present(center) .and. center) ix0 = (len(text) * digit%ncol) / 2
do i = 1, len(text)
k = index(dig, text(i:i)) - 1
if (k >= 0) call digit(k)%pr(ix - ix0 + digit%ncol * (i - 1), iy)
end do
end subroutine print_number
subroutine print_tsuki(month, ix, iy)
integer, intent(in) :: month, ix, iy
call tsuki(month)%pr(ix - 2 * tsuki%ncol, iy)
call tsuki( 0)%pr(ix + tsuki%ncol, iy)
end subroutine print_tsuki
subroutine print_youbi(k, ix, iy)
integer, intent(in) :: k, ix, iy
call youbi(k)%pr(ix - youbi%ncol / 2, iy)
end subroutine print_youbi
subroutine init_hana()
character(len = 60) :: tmp1(5) = ''
character(len = 99) :: tmp2(7) = ''
integer :: i
tmp1(1) = ' 000 1 222 333 4 55555 666 77777 888 999 '
tmp1(2) = '0 0 11 2 2 3 3 44 5 6 7 8 8 9 9 '
tmp1(3) = '0 0 1 2 333 4 4 5555 6666 7 888 9999 '
tmp1(4) = '0 0 1 2 3 3 44444 5 6 6 7 8 8 9 '
tmp1(5) = ' 000 11111 22222 333 4 5555 666 7 888 999 '
do i = 0, 9
associate(pos0 => digit(i)%ncol * i + 1, pos1 => digit(i)%ncol * (i + 1))
digit(i)%ch(:) = tmp1(:)(pos0:pos1)
end associate
end do
tmp2(1) = ' ###### ####### ##### # # # # # # '
tmp2(2) = ' # # ##### ####### # ####### # # # ##### # '
tmp2(3) = ' ###### # # # # # ####### # # # # # '
tmp2(4) = ' # # ####### ##### # # # # ###### # # # # # # # ####### '
tmp2(5) = ' ###### ## ## # # # # # # # # # # '
tmp2(6) = ' # # # # # # # # # # # # # # # '
tmp2(7) = '# ## ####### ####### ####### ####### # # #### # # # ## # '
do i = 0, 10
associate(pos0 => tsuki(i)%ncol * i + 1, pos1 => tsuki(i)%ncol * (i + 1))
tsuki(i)%ch(:) = tmp2(:)(pos0:pos1)
end associate
end do
tmp2(1) = '####### ###### # # # ### # # '
tmp2(2) = '# # # # # # # # ## ####### # # # ####### '
tmp2(3) = '# # ###### # # # ##### ### # ### # ##### ### '
tmp2(4) = '####### # # # # # ## # # # # # ### # # # # # '
tmp2(5) = '# # ###### # # # # # # # # # # # # '
tmp2(6) = '# # # # # # # # # # # # # # # # # ### # '
tmp2(7) = '####### # ## # # # # # # ####### ####### # # # '
do i = 0, 7
associate(pos0 => youbi(i)%ncol * i + 1, pos1 => youbi(i)%ncol * (i + 1))
youbi(i)%ch(:) = tmp2(:)(pos0:pos1)
end associate
end do
end subroutine init_hana
integer function zeller(iy, im, id) ! Gregorian
integer, value :: iy, im, id
integer :: iwk, ih
if (im == 1 .or. im == 2) then
iy = iy - 1
im = 12 + im
end if
ih = iy / 100
iy = mod(iy, 100)
iwk = iy + floor(iy / 4.0) + floor(ih / 4.0) - 2 * ih + floor(13.0 * (im + 1.0) / 5.0) + id
zeller = modulo(iwk , 7)
end function zeller
integer function ishift_day(iy, im)
integer, intent(in) :: iy, im
integer :: iwk
iwk = zeller(iy, im, 1)
if (iwk == 0) iwk = 7
ishift_day = 2 - iwk
end function ishift_day
integer function inum_days(iy, im)
integer, intent(in) :: iy, im
integer, parameter :: nd(12) = [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31]
inum_days = nd(im)
if (im == 2 .and. leap_year(iy)) inum_days = inum_days + 1
contains
logical function leap_year(iy)
integer, intent(in) :: iy
leap_year = .false.
if (mod(iy, 4) == 0) leap_year = .true.
if (mod(iy, 100) == 0) leap_year = .false.
if (mod(iy, 400) == 0) leap_year = .true.
end function leap_year
end function inum_days
end module m_hanamoji
program hana
use m_hanamoji
implicit none
character(len = 4) :: buff
integer :: i, j, ix, iy, iyear, month
call init_hana()
iyear = 2014
month = 8
write(buff, '(i4)') iyear
call print_tsuki(month, 64, 2)
call print_number(buff, 100, 4)
do i = 0, 6
call print_youbi(i, 18 * i + 12, 12)
end do
j = 0
do i = ishift_day(iyear, month), inum_days(iyear, month)
ix = 14 + 18 * mod(j, 7)
iy = 22 + 7 * (j / 7)
buff = ''
if (i > 0) write(buff, '(g0)') i
call print_number(trim(buff), ix, iy, center = .true.)
j = j + 1
end do
! print screen
do i = 1, size(screen)
print '(a128)', screen(i)
end do
end program hana