はじめに

「Javaで湯婆婆を実装してみる」に端を発し，様々なプログラミング言語やプラットフォームで湯婆婆が実装されている．
そこで，Fortran により UTF-8 文字列を入出力する湯婆婆を実装した．
なお，Shift_JIS を用いる環境については先駆者が存在するのでそちらを参照されたい．

実行環境

MacOS Catalina 10.15.7
GNU Fortran (Homebrew GCC 9.3.0_1) 9.3.0
ifort (IFORT) 19.1.3.301 20200925

Fortran における UTF-8 の文字列操作

Fortran はマルチバイト文字の扱いが不得手である．
マルチバイト文字を含む文字列について，長さを調べたり部分文字列を切り出したりするのは容易ではない．

GNU Fortran と IFORT におけるデフォルトの文字型は，1 バイトを 1 文字として扱うような挙動を見せる．
len("いろは") は 9 を返すし，"いろは"(1:2) は "い" の第 1 バイトと第 2 バイトが並んだ文字列らしきものになる．

そこで，贅沢な名が入力されたとき，文字の区切りがどこに・いくつあるかを調べることにする．
それにより，特定の 1 文字を表す部分を切り出し，それを新しい名前として出力することが可能となる．

なお，後述するが UCS-4 文字列をサポートする処理系ならばもっと楽な方法がある．

文字区切り位置と文字数の取得

UTF-8 における文字の表現は以下のパターンに従う：

バイト長	第 1 バイト	第 2 バイト	第 3 バイト	第 4 バイト
1	`0xxx xxxx`
2	`110x xxxx`	`10xx xxxx`
3	`1110 xxxx`	`10xx xxxx`	`10xx xxxx`
4	`1111 0xxx`	`10xx xxxx`	`10xx xxxx`	`10xx xxxx`

ただし x は文字によって異なる．
上位 2 ビットが 10 であるバイトは何らかの文字の第 2 バイト以降であり，それ以外は何らかの文字の第 1 バイトである．
したがって，文字列中にある 10 で始まらないバイトの位置をすべて把握すれば，文字の区切り位置と文字数が分かったことになる．

コード

「character 型が 1 文字を 8 ビットで表す」という前提で書いているが，Fortran の規格はそれを保証していない気がするので処理系依存になる．

yubaba.f90

module utf8
    use, intrinsic :: iso_fortran_env
    implicit none
    
contains
    pure function find_first_byte_positions(str) result (positions)
        ! List the first byte position (in bytes) of each character
        character(*), intent(in)  :: str
        integer     , allocatable :: positions(:)
        
        integer(INT8) :: byte
        
        integer :: i
        
        allocate (positions(0))
        do i = 1, len(str)
            byte = ichar(str(i:i), INT8)
            if (shiftr(byte, 6) /= B'10') positions = [positions, i]
        end do
    end function find_first_byte_positions
end module utf8

program yubaba
    use utf8
    implicit none
    
    integer, parameter :: BUF_SIZE_BYTES = 8
    
    character(BUF_SIZE_BYTES) :: buf
    character(:), allocatable :: pretty_name
    character(:), allocatable :: new_name
    integer     , allocatable :: first_byte_positions(:)
    
    integer :: byte_length
    integer :: char_count
    
    integer :: new_name_index
    integer :: first, last     ! Range (in bytes) of the character chosen for the new name
    
    real    :: random
    integer :: iostat = 0 ! Required to handle end-of-record conditions in read statements
    
    print '(A)', "契約書だよ。そこに名前を書きな。"
    
    ! Read an input string of arbitrary length
    pretty_name = ""
    do while (iostat == 0)
        read (*, '(A)', advance = 'no', iostat = iostat) buf
        pretty_name = pretty_name // buf
    end do
    
    pretty_name = trim(pretty_name)
    byte_length =  len(pretty_name)
    
    if (byte_length > 0) first_byte_positions = find_first_byte_positions(pretty_name)
    char_count = size(first_byte_positions)
    
    ! Choose a character randomly from the pretty name
    call random_seed
    call random_number(random)
    new_name_index = floor(random * char_count) + 1
    
    ! Extract the character chosen
    first    = first_byte_positions(new_name_index)
    last     = merge(byte_length, first_byte_positions(new_name_index+1) - 1, new_name_index == char_count)
    new_name = pretty_name(first:last)
    
    print '(*(A))', "フン。", pretty_name, "というのかい。贅沢な名だねぇ。"
    print '(*(A))', "今からお前の名前は", new_name, "だ。いいかい、", new_name, "だよ。", &
    &               "分かったら返事をするんだ、", new_name, "!!"
end program yubaba

コードの解説

契約書

湯婆婆はまず契約書を渡してくる．

    print '(A)', "契約書だよ。そこに名前を書きな。"
    
    ! Read an input string of arbitrary length
    pretty_name = ""
    do while (iostat == 0)
        read (*, '(A)', advance = 'no', iostat = iostat) buf
        pretty_name = pretty_name // buf
    end do
    
    pretty_name = trim(pretty_name)
    byte_length =  len(pretty_name)

贅沢な名の長さが不明であるため，一度 buf に一定の長さだけ格納してから pretty_name（贅沢な名）に追記していくことを入力終端まで繰り返す．

名前を奪う

次に湯婆婆は名前を奪う．

    if (byte_length > 0) first_byte_positions = find_first_byte_positions(pretty_name)
    char_count = size(first_byte_positions)

    pure function find_first_byte_positions(str) result (positions)
        ! List the first byte position (in bytes) of each character
        character(*), intent(in)  :: str
        integer     , allocatable :: positions(:)
        
        integer(INT8) :: byte
        
        integer :: i
        
        allocate (positions(0))
        do i = 1, len(str)
            byte = ichar(str(i:i), INT8)
            if (shiftr(byte, 6) /= B'10') positions = [positions, i]
        end do
    end function find_first_byte_positions

贅沢な名から 1 文字だけ取り出したいが，この湯婆婆は文字列を 1 バイトずつしか読めないので，まず文字区切り位置と文字数を調べる．
find_first_byte_positions 関数は，（UTF-8 の）文字列を渡されると整数型の配列を返す．
この配列の長さは文字列中の文字数に等しく，$i$ 番目の要素は「$i$ 番目の文字の第 1 バイトが文字列先頭から数えて何バイト目か」を表す．
他の文字符号化方式を使いたいときはこの関数を差し替えることでたぶん対応可能．

    ! Choose a character randomly from the pretty name
    call random_seed
    call random_number(random)
    new_name_index = floor(random * char_count) + 1

そして擬似乱数を生成し，何番目の文字を新しい名前に使うか決める．
random_number を呼ぶと $0$ 以上 $1$ 未満の一様乱数が得られる．
ちなみに IFORT では random_seed を呼ばないと実行の度に同じ乱数列が生成される．

    ! Extract the character chosen
    first    = first_byte_positions(new_name_index)
    last     = merge(byte_length, first_byte_positions(new_name_index+1) - 1, new_name_index == char_count)
    new_name = pretty_name(first:last)
    
    print '(*(A))', "フン。", pretty_name, "というのかい。贅沢な名だねぇ。"
    print '(*(A))', "今からお前の名前は", new_name, "だ。いいかい、", new_name, "だよ。", &
    &               "分かったら返事をするんだ、", new_name, "!!"

選ばれた 1 文字を表す部分文字列（というより実質的に部分バイト列）を切り出し，新しい名前として与える．

実行結果

GNU Fortran または IFORT でコンパイルする．

% gfortran yubaba.f90

$ ifort yubaba.f90

実行して名前を入力する．

% ./a.out            
契約書だよ。そこに名前を書きな。
荻野千尋
フン。荻野千尋というのかい。贅沢な名だねぇ。
今からお前の名前は千だ。いいかい、千だよ。分かったら返事をするんだ、千!!

このときは運よく「千」が選ばれた．

% ./a.out
契約書だよ。そこに名前を書きな。
寿限無寿限無五劫のすりきれ　海砂利水魚の水行末雲来末風来末　食う寝るところに住むところ　やぶらこうじのぶらこうじ　パイポパイポパイポのシューリンガン　シューリンガンのグーリンダイ　グーリンダイのポンポコピーのポンポコナの長久命の長助
フン。寿限無寿限無五劫のすりきれ　海砂利水魚の水行末雲来末風来末　食う寝るところに住むところ　やぶらこうじのぶらこうじ　パイポパイポパイポのシューリンガン　シューリンガンのグーリンダイ　グーリンダイのポンポコピーのポンポコナの長久命の長助というのかい。贅沢な名だねぇ。
今からお前の名前は無だ。いいかい、無だよ。分かったら返事をするんだ、無!!

贅沢と言われても仕方なさそうな長さの名前も入力できる．そして無になった．

% ./a.out
契約書だよ。そこに名前を書きな。
Lorem Ipsum Dolor Sit Amet
フン。Lorem Ipsum Dolor Sit Ametというのかい。贅沢な名だねぇ。
今からお前の名前はiだ。いいかい、iだよ。分かったら返事をするんだ、i!!

1 バイト文字だけを入力したときも新しい名前は 1 文字になる．
この入力は半角スペースを含んでいるため，新しい名前が半角スペースになることもある．

% ./a.out
契約書だよ。そこに名前を書きな。
AあBいCうDえEお
フン。AあBいCうDえEおというのかい。贅沢な名だねぇ。
今からお前の名前はえだ。いいかい、えだよ。分かったら返事をするんだ、え!!

異なるバイト長の文字が混合していても 1 文字だけ取り出す．

% ./a.out
契約書だよ。そこに名前を書きな。
🍩🍪🍫🍬
フン。🍩🍪🍫🍬というのかい。贅沢な名だねぇ。
今からお前の名前は🍫だ。いいかい、🍫だよ。分かったら返事をするんだ、🍫!!

贅沢だったのでチョコレート以外は没収された．

% ./a.out
契約書だよ。そこに名前を書きな。


Program received signal SIGSEGV: Segmentation fault - invalid memory reference.

Backtrace for this error:
#0  0x107b368cd
#1  0x107b35cdd
#2  0x7fff6e0f65fc
#3  0x107b2f840
#4  0x107b2fbde
zsh: segmentation fault  ./a.out

例のアレ．
GNU Fortran で表示されるエラーメッセージを載せたが，IFORT でも実行時エラーとなる．
本家とは異なり，「フン。というのかい。贅沢な名だねぇ。」と言うより前（署名欄が空白のまま契約書を提出された時点？）にクラッシュさせてみた．

UCS-4 文字列と UTF-8 入出力を扱える場合

UCS-4 は 1 文字を 4 バイトの固定長で表す方式らしい．

処理系によっては character 型で UCS-4 文字列を扱うことができ，入出力で UTF-8 文字列を使える．
このときはいくらかまともにマルチバイト文字を扱うことができ，下記のコードで湯婆婆できる．

これは GNU Fortran では動作する．
IFORT では UCS-4 文字列をサポートしておらずコンパイルエラーとなる．

yubaba_ucs4.f90

program yubaba_ucs4
    use, intrinsic :: iso_fortran_env
    implicit none
    
    integer, parameter :: UCS4 = selected_char_kind('ISO_10646')
    
    integer, parameter :: BUF_SIZE_CHARS = 8
    
    character(BUF_SIZE_CHARS, UCS4) :: buf
    
    character(:, UCS4), allocatable :: pretty_name
    character(1, UCS4)              :: new_name
    
    integer :: char_count
    integer :: new_name_index
    
    real    :: random
    integer :: iostat = 0  ! Required to handle end-of-record conditions in read statements
    
    ! Use UTF-8 for stdin and stdout
    open ( INPUT_UNIT, encoding = 'UTF-8')
    open (OUTPUT_UNIT, encoding = 'UTF-8')
    
    write (OUTPUT_UNIT, '(A)') "契約書だよ。そこに名前を書きな。"
    
    ! Read an input string of arbitrary length
    pretty_name = ""
    do while (iostat == 0)
        read (INPUT_UNIT, '(A)', advance = 'no', iostat = iostat) buf
        pretty_name = pretty_name // buf
    end do
    
    pretty_name = trim(pretty_name)
    char_count  =  len(pretty_name)
    if (char_count == 0) deallocate (pretty_name)
    
    ! Choose a character randomly from the pretty name
    call random_seed
    call random_number(random)
    new_name_index = floor(random * char_count) + 1
    new_name       = pretty_name(new_name_index:new_name_index)
    
    write (OUTPUT_UNIT, '(*(A))') "フン。", pretty_name, "というのかい。贅沢な名だねぇ。"
    write (OUTPUT_UNIT, '(*(A))') "今からお前の名前は", new_name, "だ。",      &
    &                             "いいかい、", new_name, "だよ。",            &
    &                             "分かったら返事をするんだ、", new_name, "!!"
end program yubaba_ucs4

おまけ

真面目にソースコードを読むと，入力バイト長がゼロのときに

if (byte_length > 0) first_byte_positions = find_first_byte_positions(pretty_name)

という文で何も起こらず，first_byte_positions にメモリが割り当てられないことに気付くだろう．
これによって，空文字列を入力するとセグメンテーション違反で~~正常に~~異常終了することになる．

if (byte_length > 0) の部分を取っ払うと，空文字列を入力したときも次のように正常終了してしまうときがある．

% ./a.out
契約書だよ。そこに名前を書きな。

フン。というのかい。贅沢な名だねぇ。
今からお前の名前はだ。いいかい、だよ。分かったら返事をするんだ、!!

最後に

「千と千尋の神隠し」をまともに見たことがない…ブタの描写（最序盤）が苦手だったので…