Go to Qiita Advent Calendar 2024 Top
LoginSignup
9
3

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

More than 3 years have passed since last update.

FortranAdvent Calendar 2018

Day 21
@sage-git

端末にクリスマスツリーを飾ろう by Fortran

Last updated at Posted at 2018-12-20

そろそろクリスマスも近づいてきましたので、クリスマスツリーを用意しましょう。

できたもの

いずれも普通のTerminal emulator（Konsole）の標準出力です。

test1.gif

test2.gif

今回勉強になったもの

  • ioctl：システムとのやりとり
  • ANSIエスケープシーケンス
  • イベントハンドラ

テーマ的にFortranのFORMAT芸もできたかもしれませんが、時間がなかった。

環境

LinuxはUbuntu16.04とCentOS 7.6で確認しました。
CygwinとMacOS(Mojave)はioctlでこけました。（追記：こけるというか、コンパイルと実行はできるのですが、結果が「０」でちゃんとした値が得られませんでした。）
Bash On Windowsは基本大丈夫でしたが、ウィンドウサイズを変えた時にイベントハンドラでエラーが起きました。

gfortranは5.4.0です。

ターミナルにツリーを飾ろう

せっかく飾るのですから、窓いっぱいに見えた方が良いかなと思います。遠慮して小さいツリー、例えば「A」を端末に出力させても寂しすぎます。かといってツリーが大きすぎると改行が起こって崩れたり、全体が見えなかったりします。なので、表示させるところがどれくらいの広さかを調べ、ジャストサイズのツリーを飾ってみましょう。

ここで使うのがioctlです。
https://linuxjm.osdn.jp/html/LDP_man-pages/man2/ioctl.2.html
http://man7.org/linux/man-pages/man2/ioctl.2.html

要は端末の描画を管理しているのはシステム側なので、その情報を得るには相応のレイヤーの関数を使う必要があるということです。
矩形配列演算特化のFortranには厳しいので、何でも屋のCの助けを借ります。

端末サイズ取得

デバイスにコマンドを送るシステム関数の

sys/ioctl.h
extern int ioctl (int __fd, unsigned long int __request, ...) __THROW;

がキモとなります1。端末サイズを取得する場合、C言語では

asm-generic/ioctls.h
#define TIOCGWINSZ      0x5413
unistd.h
#define STDOUT_FILENO   1
bits/ioctl-types.h
struct winsize
  {
    unsigned short int ws_row;
    unsigned short int ws_col;
    unsigned short int ws_xpixel;
    unsigned short int ws_ypixel;
  };

というものが定義されている状態で、

winsize ws;
ioctl(STDOUT_FILENO, TIOCGWINSZ, &ws);

とすればwsに現在の端末のサイズが格納されます。これをいつものようにFortranのinterfaceに書き下してやります。

module sys_ioctl
    use iso_c_binding
    implicit none
    type, bind(C) :: winsize
        integer(c_short) :: ws_row
        integer(c_short) :: ws_col
        integer(c_short) :: ws_xpixel
        integer(c_short) :: ws_ypixel
    end type winsize

    integer(c_int), parameter :: TIOCGWINSZ = Z'5413'
    integer(c_int), parameter :: STDOUT_FILENO = 1

    interface 
        function ioctl(fd, cmd, arg) result(r) bind(C, name="ioctl")
            import :: c_int, c_ptr
            integer(c_int) :: r
            integer(c_int), value :: fd, cmd
            type(c_ptr), value :: arg
        end function ioctl
    end interface
end module sys_ioctl

モジュール名は適当です。こうやってFortranでもioctlを呼び出せるようになりました。
たとえばこうやって使います。

module hoge
    use sys_ioctl
    implicit none
    integer :: width, height
    integer :: h_half, w_half 

contains
    subroutine get_windowsize()
        integer(c_int) :: ret
        type(winsize), target :: ws
        ret = ioctl(STDOUT_FILENO, TIOCGWINSZ, c_loc(ws))
        width = iand(256*256 - 1, ws%ws_col) - 1 ! write文は最初にスペースを1つ付けるのでその分減らします。
        height = iand(256*256 - 1, ws%ws_row) - 2 ! 次のシェル入力行の分減らします。 
        w_half = width / 2
        h_half = height / 2
    end subroutine get_windowsize
end module hoge

width = iand(256*256 - 1, ws%ws_col)とiandを使っている件ですが、例により符号なし整数を符号あり整数に変える処理です。wsの成分はunsigned shortですので、多分端末行数・列数が32767を超えたあたりから普通の代入では問題が出てくるかなと。

得られたwidthとheightを半分にし、画面の中央線が何行目、何列目かを得ておきます。これに沿って線を引けば端末のサイズにぴったりあった十字線が引けるはずです。

補足に書きましたが、「write文は最初にスペースを1つ付けるのでその分減らします。」はformatを適切に指定すると回避できます。

そこで以下の2つの関数をhogeモジュールに追加します。

    pure elemental function line_at(nline) result(s)
        integer, intent(in) :: nline
        character(len=width) :: s
        if ( nline == h_half )then
            s = repeat("-", w_half - mod(w_half, 2)) // "+" // repeat("-", w_half)
        else
            s = repeat(" ", w_half - mod(w_half, 2)) // "|"
        endif
    end function line_at

    subroutine draw_cross()
        integer :: i
        call get_windowsize()
        do i = 1, height
            write(*, *) line_at(i)
        enddo
    end subroutine draw_cross

あとは呼び出すプログラムを用意。

program main
    use hoge, only: draw_cross
    implicit none
    call draw_cross()
    stop
end program main

なお、ioctlはシステムコールになりますので、GCCのgfortranであれば特にリンクするものはありません。つまり、これまで書いたプログラムは

gfortran hoge.f90
./a.out

で実行できます。

以上の内容で、端末のウィンドウサイズを40x16とした時に以下の出力を得ました。

                   |                    
                   |                    
                   |                    
                   |                    
                   |                    
                   |                    
 ------------------+------------------- 
                   |                    
                   |                    
                   |                    
                   |                    
                   |                    
                   |                    
                   |

まずは概形

ツリーを飾るところのサイズを取得できました。続いて、これに合わせたツリーを用意します。

今回は、クリスマスツリーを

  • 一番上の☆
  • 土台の植木鉢
  • 真ん中の葉

の3つにわけました。このなかで真ん中の葉の部分を伸縮させ、サイズを調整しようと思います。

これらのクリスマスツリーを描写するサブルーチンを備えるxmastreeをこれから実装していきます。

☆

    subroutine draw_star()
        write(*, *) repeat(" ", w_half - 1) //  "|" 
        write(*, *) repeat(" ", w_half - 2) // "\|/" 
        write(*, *) repeat(" ", w_half - 5) // "----*----"
        write(*, *) repeat(" ", w_half - 2) // "/ \"
    end subroutine draw_star

最終行は木の一部では、という意見もあります。

植木鉢

    subroutine draw_base()
        write(*, *) repeat(" ", w_half - 3) // "|:::|" 
        write(*, *) repeat(" ", w_half - 6) // "[[_______]]" 
        write(*, *) repeat(" ", w_half - 5) // "|XXXXXXX|" 
        write(*, *) repeat(" ", w_half - 5) // "|XXXXXXX|"
    end subroutine draw_base

真ん中の木の葉

    subroutine draw_leaf()
        integer :: i, j
        integer :: n1, n2
        n1 = w_half - 1
        do i = 5, height - 5
            if (mod(i, 4) == 0) n1 = n1 + 1
            n1 = n1 - 1
            n2 = w_half*2 - 2*n1 - 1
            if (n1 == 0) exit
            write(*, '(a)') repeat(" ", n1) // "/" // repeat(" ", n2) // "\"
        enddo
        write(*, '(a)') repeat(" ", n1) // repeat("-", n2 + 2)
    end subroutine draw_leaf

これらでは、/ \ をheight - 9行出力し、木を演出します。
n1 = n1 - 1により、木の左側（/）に置くスペースを１行ごとに１文字減らします。
また、n2 = w_half*2 - 2*n1 - 1 は/と\の間におくスペースの数です。
n1が減ればn2が増えます。これにより、三角形のような木のシルエットを再現します。

if (mod(i, 4) == 0) n1 = n1 + 1は、4行に1回1文字分のスペースを木の左側に増やし、もみの木らしい葉っぱの段差を出してみます。

if (n1 == 0) exit は葉が左端についたらそれ以上伸ばさないようにしたものです。widthは実際の端末の幅から-1しているので右端がつくことは無いかなと。

以上をまとめて呼び出す関数

    subroutine draw_tree()
        call get_windowsize()
        if (height < 8 .or. width < 20 )then
            write(*, *) "Merry X'mas!"
            return
        endif
        call draw_star()
        call draw_leaf()
        call draw_base()
    end subroutine draw_tree

なお、あまりにウィンドウサイズが小さく、☆と植木鉢も入らなさそうだと`Merry X'mas!'とだけ表示してお茶を濁します。

以上がxmastreeモジュールに含まれる関数となります。あ、xmastreeに先に紹介したget_windowsizeとモジュール変数を追加するのを忘れずに。

あとはuse xmastreeしてcall draw_tree()するだけのプログラムを書いて終わりです。

program main
    use xmastree, only: draw_tree
    implicit none
    call draw_tree()
    stop
end program main

32x20の縦長ウィンドウで以下の出力が得られます。

               |
              \|/
           ----*----
              / \
             /   \
            /     \
           /       \
           /       \
          /         \
         /           \
        /             \
        /             \
       /               \
       -----------------
             |:::|
          [[_______]]
           |XXXXXXX|
           |XXXXXXX|

Qiitaのpre出力、行間が広すぎるんですよね・・・

オーナメント

もみの木だけでは寂しいので飾り付けします。

xmastreeモジュールのうち、draw_leafを書き換えます。

    subroutine draw_leaf()
        integer :: i, j
        integer :: n1, n2
        n1 = w_half - 1
        do i = 5, height - 5
            if (mod(i, 4) == 0) n1 = n1 + 1
            n1 = n1 - 1
            n2 = w_half*2 - 2*n1 - 1
            if (n1 == 0) exit
            write(*, '(a)', advance="no") repeat(" ", n1) // "/" 
            do j = 1, n2
                write(*, '(a)', advance="no") add_ornament(0.12d0)
            enddo
            write(*, '(a)') "\" 
        enddo
        write(*, '(A)') repeat(" ", n1) // repeat("-", n2 + 2) 
    end subroutine draw_leaf

葉の中のスペースをrepeatでまとめて出すのではなく、1文字1文字乱数でスペースにするかオーナメントにするかを決定して　write(*, '(a)', advance="no") add_ornament(0.12d0) と出力します。この関数は以下のような感じ。

    function add_ornament(rate) result(s)
        character(:), allocatable :: s
        real(REAL64), intent(in) :: rate
        real(REAL64) :: x
        call random_number(x)
        if(x < rate/2.0) then
            s = "O"
        elseif( x < rate) then
            s = "*"
        else
            s = " "
        endif
    end function add_ornament

Oと*の2種類の飾りを出すようにしました。結果のsが可変長なのは今後の拡張性のためです。

他の部分は全く同じです。この出力は以下のようになります。

               |
              \|/
           ----*----
              / \
             /   \
            /   *O\
           /       \
           / O     \
          /      *  \
         /           \
        /          *  \
        /          *  \
       /    *          \
       -----------------
             |:::|
          [[_______]]
           |XXXXXXX|
           |XXXXXXX|

カラー

Linuxのlsとかで文字に色がついていることがあるかと思いますが、あれは決してLinux組み込みコマンドの特権ではなく、端末に文字を出力できるならANSIエスケープシーケンスを活用することで誰でもできます。

応用例：https://qiita.com/tu-kun/items/d38452161bfb9da54bcd

  • 文字色
  • 背景色
  • 文字スタイル
  • カーソル位置

などを操作することができます。
そのために必要になるのは、ANSIエスケープシーケンス \x1b とそれに続く数文字、これだけです。

\x1bはFortranだとcharacter(len=1) :: ESC = char(27)として取り扱いできるかと思います。

今回の実装

まず、以下のようなパラメータを用意しました。

    character(len=5) :: STAR_COLOR = char(27) // "[33m"
    character(len=5) :: TREE_COLOR = char(27) // "[32m"
    character(len=5) :: BASE_COLOR = char(27) // "[31m"
    character(len=5) :: ORNAMENT_COLOR = char(27) // "[34m"
    character(len=4) :: RESET_COLOR = char(27) // "[0m"

これで、すべての出力の前後にXXX_COLORとRESET_COLORをつけます。こんな感じ。

    subroutine draw_star()
        write(*, *) repeat(" ", w_half - 1) // STAR_COLOR // "|" // RESET_COLOR
        write(*, *) repeat(" ", w_half - 2) // STAR_COLOR // "\|/" // RESET_COLOR
        write(*, *) repeat(" ", w_half - 5) // STAR_COLOR // "----*----" // RESET_COLOR
        write(*, *) repeat(" ", w_half - 2) // STAR_COLOR // "/ \" // RESET_COLOR
    end subroutine draw_star

    function add_ornament(rate) result(s)
        character(:), allocatable :: s
        real(REAL64), intent(in) :: rate
        real(REAL64) :: x
        call random_number(x)
        if(x < rate/2.0) then
            s = ORNAMENT_COLOR // "O" // RESET_COLOR
        elseif( x < rate) then
            s = "*"
        else
            s = " "
        endif
    end function add_ornament

    subroutine draw_leaf()
        integer :: i, j
        integer :: n1, n2
        n1 = w_half - 1
        do i = 5, height - 5
            if (mod(i, 4) == 0) n1 = n1 + 1
            n1 = n1 - 1
            n2 = w_half*2 - 2*n1 - 1
            if (n1 == 0) exit          
            write(*, '(a)', advance="no") repeat(" ", n1) // TREE_COLOR // "/" // RESET_COLOR
            do j = 1, n2
                write(*, '(a)', advance="no") add_ornament(0.12d0)
            enddo
            write(*, '(a)') TREE_COLOR // "\" // RESET_COLOR
        enddo
        write(*, '(A)') repeat(" ", n1) // TREE_COLOR // repeat("-", n2 + 2)  // RESET_COLOR
    end subroutine draw_leaf

    subroutine draw_base()
        write(*, *) repeat(" ", w_half - 3) // BASE_COLOR // "|:::|" // RESET_COLOR
        write(*, *) repeat(" ", w_half - 6) // BASE_COLOR // "[[_______]]" // RESET_COLOR
        write(*, *) repeat(" ", w_half - 5) // BASE_COLOR // "|XXXXXXX|" // RESET_COLOR
        write(*, *) repeat(" ", w_half - 5) // BASE_COLOR // "|XXXXXXX|" // RESET_COLOR
    end subroutine draw_base

オーナメントの*はデフォルトの色にしてみました。
add_ornamentの戻り変数型をcharacter(:)と可変長にしているのは、このエスケープシーケンスに対応するためでした。エスケープシーケンスは端末上では表示されませんが、データとしてはしっかり持っていますので、その分の長さを確保する必要があります。

これで端末出力では色が付くはずです。

動き回るオーナメント、ではなく点滅するランプのイメージで

この節でANSIエスケープシーケンスのうち、カーソル移動を実験します。

「できたもの」1つ目のような動きをつけてみます。これはプログラム的には毎秒書きなおしています。
この時端末の出力を次々流しては芸がないので、カーソルを戻して画面を再利用することにします。

    subroutine draw_tree(overwrite)
        logical, intent(in) :: overwrite
        integer :: i
        call get_windowsize()
        if (overwrite) call clean_disp()
        if (height < 8 .or. width < 20 )then
            write(*, *) "Merry X'mas!"
            return
        endif
        call draw_star()
        call draw_leaf()
        call draw_base()
    end subroutine draw_tree

ここで新しく追加したのが、端末描写をリセットするclean_disp。エスケープシーケンスを1つ追加します。これはカーソル位置を1行１列目に移動させる効果を持ちます。

    character(len=6) :: RESET_TERMINAL = char(27) // "[1;1H"

    subroutine clean_disp()
        integer :: i
        write(*, '(A)', advance="no") RESET_TERMINAL
        do i = 1, height
            write(*, *) repeat(" ", width)
        enddo
        write(*, '(A)', advance="no") RESET_TERMINAL
    end subroutine clean_disp

やっていることは、端末画面左上にカーソルを動かし、画面いっぱいにスペースで埋め、再びカーソルを左上に持って行っています。

また、draw_tree関数にも新しくフラグ引数を導入したので、呼び出すプログラムも以下のようになります。


program main
    use xmastree, only: draw_tree
    implicit none
    integer :: N

    call draw_tree(.false.)
    do N = 1, 100
        call sleep(1)
        call draw_tree(.true.)
    enddo
   
    stop
end program main

これで以下の出力が得られます。

test1.gif

ソースコード
glitter.f90
module sys_ioctl
    use iso_c_binding
    implicit none
    type, bind(C) :: winsize
        integer(c_short) :: ws_row
        integer(c_short) :: ws_col
        integer(c_short) :: ws_xpixel
        integer(c_short) :: ws_ypixel
    end type winsize
    integer(c_int), parameter :: TIOCGWINSZ = Z'5413'
    integer(c_int), parameter :: STDOUT_FILENO = 1

    interface 
        function ioctl(fd, cmd, arg) result(r) bind(C, name="ioctl")
            import :: c_int, c_ptr
            integer(c_int) :: r
            integer(c_int), value :: fd, cmd
            type(c_ptr), value :: arg
        end function ioctl
    end interface
end module sys_ioctl

module xmastree
    use iso_fortran_env
    use sys_ioctl
    implicit none
    integer :: width, height
    integer :: h_half, w_half 
    character(len=5) :: STAR_COLOR = char(27) // "[33m"
    character(len=5) :: TREE_COLOR = char(27) // "[32m"
    character(len=5) :: BASE_COLOR = char(27) // "[31m"
    character(len=5) :: ORNAMENT_COLOR = char(27) // "[34m"
    character(len=4) :: RESET_COLOR = char(27) // "[0m"
    character(len=6) :: RESET_TERMINAL = char(27) // "[1;1H"

contains
    subroutine get_windowsize()
        integer(c_int) :: ret
        type(winsize), target :: ws
        ret = ioctl(STDOUT_FILENO, TIOCGWINSZ, c_loc(ws))
        width = iand(256*256 - 1, ws%ws_col) - 1
        height = iand(256*256 - 1, ws%ws_row) - 1
        w_half = width / 2
        h_half = height / 2
    end subroutine get_windowsize
    
    subroutine clean_disp()
        integer :: i
        write(*, '(A)', advance="no") RESET_TERMINAL
        do i = 1, height
            write(*, *) repeat(" ", width)
        enddo
        write(*, '(A)', advance="no") RESET_TERMINAL
    end subroutine clean_disp

    subroutine draw_star()
        write(*, *) repeat(" ", w_half - 1) // STAR_COLOR // "|" // RESET_COLOR
        write(*, *) repeat(" ", w_half - 2) // STAR_COLOR // "\|/" // RESET_COLOR
        write(*, *) repeat(" ", w_half - 5) // STAR_COLOR // "----*----" // RESET_COLOR
        write(*, *) repeat(" ", w_half - 2) // STAR_COLOR // "/ \" // RESET_COLOR
    end subroutine draw_star

    function add_ornament(rate) result(s)
        character(:), allocatable :: s
        real(REAL64), intent(in) :: rate
        real(REAL64) :: x
        call random_number(x)
        if(x < rate/2.0) then
            s = ORNAMENT_COLOR // "O" // RESET_COLOR
        elseif( x < rate) then
            s = "*"
        else
            s = " "
        endif
    end function add_ornament

    subroutine draw_leaf()
        integer :: i, j
        integer :: n1, n2
        n1 = w_half - 1
        do i = 5, height - 5
            if (mod(i, 4) == 0) n1 = n1 + 1
            n1 = n1 - 1
            n2 = w_half*2 - 2*n1 - 1
            if (n1 == 0) exit
            write(*, '(a)', advance="no") repeat(" ", n1) // TREE_COLOR // "/" // RESET_COLOR
            do j = 1, n2
                write(*, '(a)', advance="no") add_ornament(0.12d0)
            enddo
            write(*, '(a)') TREE_COLOR // "\" // RESET_COLOR
        enddo
        write(*, '(a)') repeat(" ", n1) // TREE_COLOR // repeat("-", n2 + 2)  // RESET_COLOR
    end subroutine draw_leaf

    subroutine draw_base()
        write(*, *) repeat(" ", w_half - 3) // BASE_COLOR // "|:::|" // RESET_COLOR
        write(*, *) repeat(" ", w_half - 6) // BASE_COLOR // "[[_______]]" // RESET_COLOR
        write(*, *) repeat(" ", w_half - 5) // BASE_COLOR // "|XXXXXXX|" // RESET_COLOR
        write(*, *) repeat(" ", w_half - 5) // BASE_COLOR // "|XXXXXXX|" // RESET_COLOR
    end subroutine draw_base

    subroutine draw_tree(overwrite)
        logical, intent(in) :: overwrite
        integer :: i
        call get_windowsize()
        ! if (overwrite) write(*, '(A)', advance="no") RESET_TERMINAL
        if (overwrite) call clean_disp()
        if (height < 8 .or. width < 20 )then
            write(*, *) "Merry X'mas!"
            return
        endif
        call draw_star()
        call draw_leaf()
        call draw_base()
    end subroutine draw_tree

end module xmastree

program main
    use xmastree, only: draw_tree
    implicit none
    integer :: N

    call draw_tree(.false.)
    do N = 1, 100
        call sleep(1)
        call draw_tree(.true.)
    enddo
   
    stop
end program main

ウィンドウサイズ変更に追従

クリスマスツリーを表示中に窓の大きさを変更するかもしれません。このときにいつ変更が起こってもいいように1秒おきに再描画を行うプログラムでは芸がないし、Fortranのsleepが秒単位なので反応が遅いです。

実はウィンドウサイズを変更するとSIGWINCHシグナルが投げられます。これを拾ってやり、ウィンドウサイズ変更時にだけ再描画するプログラムにしてみます。

シグナル処理

メインプログラム部分の変更のみで対応できます。

program main
    use xmastree, only: draw_tree
    implicit none
    integer :: N

    call draw_tree(.false.)
    call signal(28, tree_rewrite) ! SIGWINCH
    do while(.true.)
        call sleep(1)
    enddo
    stop
contains
    subroutine tree_rewrite
        call draw_tree(.true.)
    end subroutine 
end program main

オーナメントの部分の変更

今度はオーナメントは固定で、*が点滅するLEDだとして描写します。ANSIエスケープシーケンスのブリンクを使ってみたかったので。

    character(len=7) :: LED_COLOR = char(27) // "[35;5m"

   !     function add_ornament(rate) result(s) の中ほど
        elseif( x < rate) then
            s = LED_COLOR // "*" // RESET_COLOR
        else

同じ種類のコマンドだとまとめることができるようです。（ESC[35mESC[5m → ESC[35;5m）

続いてオーナメント位置の固定のため、乱数のseedを指定してからオーナメントを描写するようにします。

   subroutine draw_leaf()

            ! 中略

            write(*, '(a)', advance="no") repeat(" ", n1) // TREE_COLOR // "/" // RESET_COLOR
            seed(:) = i
            call random_seed(put=seed(:))
            do j = 1, n2
                write(*, '(a)', advance="no") add_ornament(0.12d0)
            enddo
            write(*, *) TREE_COLOR // "\" // RESET_COLOR

            ! 中略

    end subroutine draw_leaf

種指定用の配列をxmastreeモジュール変数に追加。

    integer, allocatable :: seed(:)

これをdraw_tree初回呼び出し時に準備するようにします。

    subroutine draw_tree(overwrite)
        logical, intent(in) :: overwrite
        integer :: i, seedsize

        if ( .not. allocated(seed) )then
            call random_seed(size=seedsize)
            allocate(seed(seedsize))
        endif
以下略

以上で、「できたもの」2つ目の絵ができます。

test2.gif

ソースコード
winsize_flexible.f90
module sys_ioctl
    use iso_c_binding
    implicit none
    type, bind(C) :: winsize
        integer(c_short) :: ws_row
        integer(c_short) :: ws_col
        integer(c_short) :: ws_xpixel
        integer(c_short) :: ws_ypixel
    end type winsize
    integer(c_int), parameter :: TIOCGWINSZ = Z'5413'
    integer(c_int), parameter :: STDOUT_FILENO = 1

    interface 
        function ioctl(fd, cmd, arg) result(r) bind(C, name="ioctl")
            import :: c_int, c_ptr
            integer(c_int) :: r
            integer(c_int), value :: fd, cmd
            type(c_ptr), value :: arg
        end function ioctl
    end interface
end module sys_ioctl

module xmastree
    use iso_fortran_env
    use sys_ioctl
    implicit none
    integer :: width, height
    integer :: h_half, w_half 
    integer, allocatable :: seed(:)
    character(len=5) :: STAR_COLOR = char(27) // "[33m"
    character(len=5) :: TREE_COLOR = char(27) // "[32m"
    character(len=5) :: BASE_COLOR = char(27) // "[31m"
    character(len=5) :: ORNAMENT_COLOR = char(27) // "[34m"
    character(len=7) :: LED_COLOR = char(27) // "[35;5m"
    character(len=4) :: RESET_COLOR = char(27) // "[0m"
    character(len=6) :: RESET_TERMINAL = char(27) // "[1;1H"

contains
    subroutine get_windowsize()
        integer(c_int) :: ret
        type(winsize), target :: ws
        ret = ioctl(STDOUT_FILENO, TIOCGWINSZ, c_loc(ws))
        width = iand(256*256 - 1, ws%ws_col) - 1
        height = iand(256*256 - 1, ws%ws_row) - 1
        w_half = width / 2
        h_half = height / 2
    end subroutine get_windowsize
    
    subroutine clean_disp()
        integer :: i
        write(*, '(A)', advance="no") RESET_TERMINAL
        do i = 1, height
            write(*, *) repeat(" ", width)
        enddo
        write(*, '(A)', advance="no") RESET_TERMINAL
    end subroutine clean_disp

    subroutine draw_star()
        write(*, *) repeat(" ", w_half - 1) // STAR_COLOR // "|" // RESET_COLOR
        write(*, *) repeat(" ", w_half - 2) // STAR_COLOR // "\|/" // RESET_COLOR
        write(*, *) repeat(" ", w_half - 5) // STAR_COLOR // "----*----" // RESET_COLOR
        write(*, *) repeat(" ", w_half - 2) // STAR_COLOR // "/ \" // RESET_COLOR
    end subroutine draw_star

    function add_ornament(rate) result(s)
        character(:), allocatable :: s
        real(REAL64), intent(in) :: rate
        real(REAL64) :: x
        call random_number(x)
        if(x < rate/2.0) then
            s = ORNAMENT_COLOR // "O" // RESET_COLOR
        elseif( x < rate) then
            s = LED_COLOR // "*" // RESET_COLOR
        else
            s = " "
        endif
    end function add_ornament

    subroutine draw_leaf()
        integer :: i, j
        integer :: n1, n2
        n1 = w_half - 1
        do i = 5, height - 5
            if (mod(i, 4) == 0) n1 = n1 + 1
            n1 = n1 - 1
            n2 = w_half*2 - 2*n1 - 1
            if (n1 == 0) exit
            write(*, '(a)', advance="no") repeat(" ", n1) // TREE_COLOR // "/" // RESET_COLOR
            seed(:) = i
            call random_seed(put=seed(:))
            do j = 1, n2
                write(*, '(a)', advance="no") add_ornament(0.12d0)
            enddo
            write(*, '(a)') TREE_COLOR // "\" // RESET_COLOR
        enddo
        write(*, '(a)') repeat(" ", n1) // TREE_COLOR // repeat("-", n2 + 2)  // RESET_COLOR
    end subroutine draw_leaf

    subroutine draw_base()
        write(*, *) repeat(" ", w_half - 3) // BASE_COLOR // "|:::|" // RESET_COLOR
        write(*, *) repeat(" ", w_half - 6) // BASE_COLOR // "[[_______]]" // RESET_COLOR
        write(*, *) repeat(" ", w_half - 5) // BASE_COLOR // "|XXXXXXX|" // RESET_COLOR
        write(*, *) repeat(" ", w_half - 5) // BASE_COLOR // "|XXXXXXX|" // RESET_COLOR
    end subroutine draw_base

    subroutine draw_tree(overwrite)
        logical, intent(in) :: overwrite
        integer :: i, seedsize

        if ( .not. allocated(seed) )then
            call random_seed(size=seedsize)
            allocate(seed(seedsize))
        endif

        call get_windowsize()
        ! if (overwrite) write(*, '(A)', advance="no") RESET_TERMINAL
        if (overwrite) call clean_disp()
        if (height < 8 .or. width < 20 )then
            write(*, *) "Merry X'mas!"
            return
        endif
        call draw_star()
        call draw_leaf()
        call draw_base()
    end subroutine draw_tree
end module xmastree

program main
    use xmastree, only: draw_tree
    implicit none
    integer :: N

    call draw_tree(.false.)
    call signal(28, tree_rewrite) ! SIGWINCH
    do while(.true.)
        call sleep(1)
    enddo
    stop
contains
    subroutine tree_rewrite
        call draw_tree(.true.)
    end subroutine 
end program main

補足

「write文は最初にスペースを1つ付けるのでその分減らします」と言いましたが、write(*, *)がつけるのであって、write(*,'(a)')はつけません。

    write(*, *) "hoge"
    write(*, '(a)') "hoge"
出力
 hoge
hoge

これに記事を書く途中で気づいたので、記事中でwrite文のFormatに乱れがあり、結果n1などスペース数の定義が節によって違うことがあります。

その他

クリスマスプレゼントにNintendo Switch買おうかな。

追記

2020年7月末にざっと自分のgithubのリポジトリを見ていたら、この記事の内容をリポジトリにした

が2020 GitHub Archive Program（Arctic Code Vault）に選ばれていました。

  1. __THROWはC++などの一部環境でthrow()をつけるためのもので、今回は無視して大丈夫です。sys/cdefs.h参照。 ↩

9
3
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
9
3

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?