5chビューワーにおけるレス間構造の習得とその表現

# 要旨
以下の5chビューワーのように、アンカーによってツリー構造を成す文章構造を見える化する。
![upthis.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/2781693/6fcf1367-6dc9-9fca-8625-8b366102c929.jpeg)



# コードの要点
レスが削除されたり過去レスをコピペする人もいたので、念入にチェックしたコードになっている。
だが要点はアンカーによるレス番号どうしの関係の構築と出力である。
構築自体は簡単である。```%anchor_towerd```に84=>[70],や85=>[83,84],といったものを詰めていく。
60行目あたりの```LINE:while(<>){}```で1行ずつ本文を読んでいきながら正規表現で```push```していくだけだ。
ノードとエッジで表現される有向グラフとしてはこれで完成だが、人間には判りにくい状態である。
機械にとっては十分了解可能なそのデータを人の視点では少なくとも直感的ではないと捉えたので、```searchAnchor``` というサブルーチンを書いた。

これが返す```%anchor_tree_of```はレス番号70ではこういうレスの木構造である
以下、レス番号70を中心に解説する。
```perl:
### %anchor_tree_of: {
###                    73 => {},
###                    82 => {},
###                    84 => {
###                            85 => {}
###                          }
###                  }
```
```$current_ordinal``` にはアンカーされる 70 が
```$anchor_from``` にはアンカーをする 73 や 82、84等が入る
未来に向かって誤爆するレスが散見されるのを無効としたいので```next if $anchor_from <= $current_ordinal;```である。こうして```%anchor_towerd```をほとんど裏返して木目構造にした```%anchor_tree_of```のリファレンスを返してサブルーチン```searchAnchor```は仕事を終える。
人にとって構造が判りやすいのでデバッグも、機能追加も容易になる。
木目構造のアンカーレベルなど情報を更新しながら幹から枝に向かって出力していく```describe_deep_tree_using```によってレスの前に黒背景で情報を出力したり、
そのサブルーチンから呼びだされる```describe_ordinal_tree_using```によってアンカー深度レベルに応じたインデントを追加して出力する。(呈色コードは外部スクリプトに記述)


# コード
```perl:
#!/usr/bin/env perl
use strict;
use warnings;
use Smart::Comments;
use Encode;
use utf8;
use Time::Piece;
use feature 'state';

my %anchor_towerd;

sub searchAnchor {
    my $current_ordinal = shift;
    my %anchor_tree_of;
    for my $anchor_from ( sort { $a <=> $b } keys %anchor_towerd ) {
        next if $anchor_from <= $current_ordinal; # ignore void anchor that to nobody
        for my $anchor_to ( @{ $anchor_towerd{$anchor_from} } ) {
            if ( $anchor_to == $current_ordinal ) {
                $anchor_tree_of{$anchor_from} = searchAnchor($anchor_from);
            }
        }
    }
    return \%anchor_tree_of;
}

sub examing_number_of {
    # detect correct header_with_body_of number under stalin sort
    my($previous_ordinal, $current_ordinal) = @_;
    my $consecutive_digits = length ++$previous_ordinal;
    $current_ordinal =~ m( \d{$consecutive_digits} )xms; # digits check
    $&;
}

sub convert_to_seconds {
    my $YMDhms = shift =~ s/\D//gr;
    Time::Piece->strptime( $YMDhms, '%Y%m%d%H%M%S' );
}

sub is_regular_time {
    # Check time stamp because all paste header_with_body_of are old,
    # while new header_with_body_of is going to future
    state $previous_time_stamp;
    my $examing_time_stamp = convert_to_seconds(shift);
    if (defined $previous_time_stamp && $examing_time_stamp < $previous_time_stamp) {
        return 0;
    }
    else {
        $previous_time_stamp = $examing_time_stamp;
        return 1;
    }
}

my $time_stamp_format # 2023/07/20 03:06:29.88 
    = qr( .* \d{4} . \d{2} . \d{2} .* \d{2} : \d{2} : \d{2} )x;
my $ordinal_number_format = qr{\d{1,4}}; # 1 .. 1000
my ( $ordinal_number, $previous_ordinal, $stucked_header_with_body ) = ( 0, 1 );
my %header_with_body_of;

LINE:
while (<>) {
    my $texts = Encode::decode( 'UTF8', $_ );
    if (/\A ($ordinal_number_format) .* ($time_stamp_format)/xms) {
        my ($current_ordinal, $time_stump) = ($1, $2);
        if ( is_regular_time($time_stump) ) {
            $header_with_body_of{$ordinal_number} = $stucked_header_with_body;

            $previous_ordinal = $ordinal_number;
            $ordinal_number   = examing_number_of($previous_ordinal, $current_ordinal);
            $stucked_header_with_body = $texts;
            next LINE;
        }
    }

    # others are body to cash
    $stucked_header_with_body .= $texts;
    $texts =~ s[.*? >> (?<response_number> \d+ (?> , \d+)*)
        (?{ push @{ $anchor_towerd{$ordinal_number} }, split( /\D+/, $+{response_number} ) })
    ][]xg;
}
SAVE_FINAL_BUFFER:
do { $header_with_body_of{$ordinal_number} = $stucked_header_with_body };

my $padding = q(| );

sub describe_ordinal_tree_using {
    my $texts = shift;
    my $depth = shift;
    for my $texts ( split( /\R/, $texts ) ) {
        print Encode::encode( 'utf-8', $padding x $depth . $texts . "\n" );
    }
}

sub be_ordinally {
    my $number = shift;
    my %ordinal_number_of = (
        1 => "1st",
        2 => "2nd",
        3 => "3rd",
        4 => "4th",
        5 => "5th",
        6 => "6th",
        7 => "7th",
        8 => "8th",
        9 => "9th",
        0 => "0th",
    );
    $number =~ /\d\z/;
    return $` . $ordinal_number_of{$&};
}

my %talked;
my $response_count;
sub describe_deep_tree_using {
    my $tree  = shift;
    my $I     = shift;
    my $depth = shift;
    ++$depth;
    my $response_sequence  = shift;
    $response_count = shift;


    for my $speaker ( sort { $a <=> $b } keys %$tree ) {
        ++$response_count;
        printf Encode::encode( 'utf-8', "$response_sequence/$speaker Lv$depth %s\n" ),
            be_ordinally($response_count);
        next unless $header_with_body_of{$speaker};
        describe_ordinal_tree_using( $header_with_body_of{$speaker}, $depth );
        unless ($talked{$speaker}++) {
            describe_deep_tree_using( searchAnchor($speaker) , 
                $speaker                   , 
                $depth                     , 
                "$response_sequence/$speaker"           , 
                $response_count
            );
        }
    }
}

sub search_erased {
    # 89872022/07/06(水) 13:14:53.43ID:sA8jktzE0 => 89 user named 87
    my($previous_number, $num) = @_;
    return 0 unless (defined $previous_number && defined $num);
    return 1 if ++$previous_number == $num;
    print "@{ [($previous_number .. --$num)] } COULD NOT BE FOUND\n";
}


# %header_with_body_of has all texts.
my $previous_number;
MAIN:
for my $num ( sort { $a <=> $b } keys %header_with_body_of ) {
    next if $num == 0;       # ignore header
    search_erased($previous_number, $num);
    $previous_number = $num;
    next if $talked{$num};
    print "-" x 80 . "\n";
    print Encode::encode( 'utf-8', "$header_with_body_of{$num}" );
    my $result = searchAnchor( $num, "$num/" );
    describe_deep_tree_using( $result, $num, 0, "$num", 1 );
}
=head1 ABSTRUCT
This program parse such a 5ch into tree style
=cut

```