package Quiq::TreeFormatter;
use base qw/Quiq::Hash/;

use strict;
use warnings;
use v5.10.0;

our $VERSION = 1.133;

use Quiq::Option;

# -----------------------------------------------------------------------------

=encoding utf8

=head1 NAME

Quiq::TreeFormatter - Erzeugung von Baumdarstellungen

=head1 BASE CLASS

L<Quiq::Hash>

=head1 SYNOPSIS

Der Code

    use Quiq::TreeFormatter;
    
    my $t = Quiq::TreeFormatter->new([
        [0,'A'],
        [1,'B'],
        [2,'C'],
        [3,'D'],
        [2,'E'],
        [2,'F'],
        [3,'G'],
        [4,'H'],
        [1,'I'],
        [1,'J'],
        [2,'K'],
        [2,'L'],
        [1,'M'],
        [2,'N'],
    ]);
    
    print $t->asText;

produziert

    +--A
       |
       +--B
       |  |
       |  +--C
       |  |  |
       |  |  +--D
       |  |
       |  +--E
       |  |
       |  +--F
       |     |
       |     +--G
       |        |
       |        +--H
       |
       +--I
       |
       +--J
       |  |
       |  +--K
       |  |
       |  +--L
       |
       +--M
          |
          +--N

=head1 DESCRIPTION

Ein Objekt der Klasse repräsentiert einen Baum, der mit
Methoden der Klasse dargestellt (visualisiert) werden kann. Die
Baumstruktur wird als eine Liste von (minestens zweielementigen) Tupeln
[$level,$node,...] an den Konstruktor übergeben. Ein Tupel besteht aus der
Angabe der Ebene des Knotens, des Knotens selbst und optional weiteren
- frei definierbaren - Informationen, z.B. ob der Subbaum des Knotens
ausgeblendet wurde. Die zusätzliche Information kann in der
getText-Callback-Methode genutzt werden, um den betreffenden Knoten
besonders darzustellen. Der Knoten $node kann ein Objekt oder ein Text
sein. Die Ebene $level ist eine natürliche Zahl im Wertebereich von
0 (Wurzelknoten) bis n. Die Paar-Liste kann aus irgendeiner Baumstruktur
mit einer rekursiven Funktion erzeugt werden (siehe Abschnitt L</EXAMPLE>).

=head1 EXAMPLE

=head2 Baumknoten als Texte

Siehe SYNOPSIS.

=head2 Rekursive Methode mit Stop-Kennzeichen

Die folgende Methode erkennt, wenn ein Knoten wiederholt auftritt,
kennzeichnet diesen mit einem Stop-Kennzeichen und steigt dann
nicht in den Subbaum ab. Dies verhindert redundante Baumteile
und u.U. eine Endlos-Rekursion (wenn die Wiederholung auf einem
Pfad vorkommt).

    sub hierarchy {
        my $self = shift;
        my $stopH = shift || {};
    
        my $stop = $stopH->{$self}++;
        if (!$stop) {
            my @arr;
            for my $node ($self->subNodes) {
                push @arr,map {$_->[0]++; $_} $node->hierarchy($stopH);
            }
        }
        unshift @arr,[0,$self,$stop];
    
        return wantarray? @arr: \@arr;
    }

=head2 Baumknoten als Objekte

Hier ein Beispiel für eine rekursive Methode einer Anwendung, die
eine Klassenhierarchie für eine bestimmte Klasse ($self)
ermittelt. Die Methode liefert die Klassenhierarchie als
Paar-Liste für Quiq::TreeFormatter:

    sub classHierarchy {
        my $self = shift;
    
        my @arr;
        for my $cls ($self->subClasses) {
            push @arr,map {$_->[0]++; $_} $cls->classHierarchy;
        }
        unshift @arr,[0,$self];
    
        return wantarray? @arr: \@arr;
    }

Hier sind die Knoten $node Objekte, deren Text für die Darstellung
im Baum durch eine anonyme Subroutine produziert wird.
Die Subroutine wird mittels der Option C<-getText> an $t->asText()
übergeben:

    my $cls = $cop->findEntity('Quiq/ContentProcessor/Type');
    my $arrA = $cls->classHierarchy;
    print Quiq::TreeFormatter->new($arrA)->asText(
        -getText => sub {
            my ($cls,$stop) = @_;
    
            my $str = $cls->name."\n";
            for my $grp ($cls->groups) {
                $str .= sprintf ": %s\n",$grp->title;
                for my $mth ($grp->methods) {
                    $str .= sprintf ":   %s()\n",$mth->name;
                }
            }
    
            return $str;
        },
    );

Ein Ausschnitt aus der produzierten Ausgabe:

    +--Quiq/ContentProcessor/Type
       : Erzeugung
       :   create()
       : Objektmethoden
       :   entityFile()
       :   entityId()
       :   entityType()
       :   files()
       :   fileSource()
       :   fileSourceRef()
       :   appendFileSource()
       :   name()
       :   pureCode()
       : Intern
       :   needsTest()
       :   needsUpdate()
       |
       +--Yeah/Type
          |
          +--Yeah/Type/Export
          |  : Erzeugung
          |  :   create()
          |  : Entitäten
          |  :   entities()
          |  : Reguläre Ausdrücke
          |  :   excludeRegex()
          |  :   selectRegexes()
          |  : Verzeichnisse
          |  :   adminDirectories()
          |  :   rootDirectory()
          |  : Verzeichnisse
          |  :   subDirectories()
          |  : Export
          |  :   rewriteRules()
          |  :   export()
          |
          +--Yeah/Type/Language
          |
          +--Yeah/Type/Library
          |
          +--Yeah/Type/Package
          |  : Erzeugung
          |  :   create()
          |  : Eigenschaften
          |  :   level()
          |  :   levelName()
          |  : Entitäten
          |  :   entities()
          |  :   hierarchy()
          |  :   package()
          |  :   subPackages()
          |  : Reguläre Ausdrücke
          |  :   regexes()
          |
          ...

=head1 METHODS

=head2 Konstruktor

=head3 new() - Instantiiere Baum-Objekt

=head4 Synopsis

    $t = $class->new(\@tuples);

=head4 Arguments

=over 4

=item @tuples

Liste von Tripeln [$level, $node, ...]. Die Komponenten ... werden
transparent weitergereicht.

=back

=head4 Returns

Referenz auf Baum-Objekt.

=head4 Description

Instantiiere ein Baum-Objekt und liefere eine Referenz auf dieses
Objekt zurück.

=cut

# -----------------------------------------------------------------------------

sub new {
    my ($class,$tripleA) = @_;

    # Tupel in interne Liste umkopieren. Die interne Liste besitzt
    # am Anfang ein weiteres Feld mit einem "Verbindungskennzeichen". Die
    # Felder Verbindungskennzeichen, Level, Knoten (Objekt oder Text),
    # und sonstige Infomation. Das Verbindungskennzeichen gibt an, ob ein
    # Folgeknoten auf gleicher Ebene vorhanden ist. Wir initialisieren
    # dessen Wert hier auf 0.

    my @arr;
    for (@$tripleA) {
        # [$follow,$level,$node,...]
        push @arr,[0,@$_];
    }

    # Setze die Kolumne mit Verbindungs-Kennzeichen auf 1, wenn
    # ein Folgeknoten gleicher Ebene existiert, ohne dass ein
    # Knoten einer niedrigeren Ebene dazwischen liegt.

    for (my $i = 0; $i < @arr-1; $i++) {
        my $iLevel = $arr[$i][1];
        for (my $j = $i+1; $j < @arr; $j++) {
            my $jLevel = $arr[$j][1];
            if ($jLevel == $iLevel) {
               $arr[$i][0] = 1;
               last;
            }
            elsif ($jLevel < $iLevel) {
               last;
            }
        }
    }

    return $class->SUPER::new(
        lineA => \@arr,
    );
}

# -----------------------------------------------------------------------------

=head2 Darstellung

=head3 asText() - Erzeuge Text-Repräsentation des Baums

=head4 Synopsis

    $str = $t->asText(@opt);

=head4 Options

=over 4

=item -format => 'debug'|'compact'|'tree' (Default: 'tree')

Format der Ausgabe (s.u.)

=item -getText => sub { my ($node,@args) = @_; ... return $text }

Callback-Funktion zum Ermitteln des Textes des Knotens. Der Text
kann mehrzeilig sein.

=back

=head4 Returns

Baumdarstellung (String)

=head4 Description

Erzeuge eine Text-Repräsentation des Baums und liefere diese zurück.

B<debug>

    0 0 A
    1 1   B
    2 1     C
    3 0       D
    2 1     E
    2 0     F
    3 0       G
    4 0         H
    1 1   I
    1 1   J
    2 1     K
    2 0     L
    1 0   M
    2 0     N

B<compact>

    A
      B
        C
          D
        E
        F
          G
            H
      I
      J
        K
        L
      M
        N

B<tree>

    +--A
       |
       +--B
       |  |
       |  +--C
       |  |  |
       |  |  +--D
       |  |
       |  +--E
       |  |
       |  +--F
       |     |
       |     +--G
       |        |
       |        +--H
       |
       +--I
       |
       +--J
       |  |
       |  +--K
       |  |
       |  +--L
       |
       +--M
          |
          +--N

=cut

# -----------------------------------------------------------------------------

sub asText {
    my $self = shift;
    # @_: @opt

    my $format = 'tree';
    my $getText = sub {return shift};

    Quiq::Option->extract(\@_,
        -format => \$format,
        -getText => \$getText,
    );

    my $str = '';
    my $lineA = $self->get('lineA');

    if ($format eq 'tree') {
        # Array, das für jede Einrückungsspalte angibt, ob dort eine
        # Verbindungslinie geführt wird.
        my @follow;

        for (my $i = 0; $i < @$lineA; $i++) {
            my ($follow,$level,$node,@args) = @{$lineA->[$i]};
            $follow[$level] = $follow; # Verbindungskennzeichen für $level

            # Einrückungs-Block erzeugen. Der Einrückungs-Block
            # enthält für jede Ebene 0 bis $level-1 Leerraum oder
            # eine Verbindungslinie gemäß dem Verbindungskennzeichen
            # $follow der betreffenden Ebene. Die Einrückung je
            # Ebene beträgt 3 Zeichen.

            my $indent = '';
            for (my $j = 0; $j < $level; $j++) {
                $indent .= $follow[$j]? '|  ': '   ';
            }

            # Knoten-Block erzeugen. Der Knoten-Block hat den Aufbau
            #
            #     X
            #     +--$line1
            #     Y  $rest
            #
            # wobei "Y  $rest" nur bei einem mehrzeiligen Knoten-Text
            # existiert. Y ist dann ein |, wenn das Verbindugskennzeichen
            # für Ebene $level gesetzt ist, sonst ein Leerzeichen.
            # X existiert nicht beim ersten Knoten, sonst ist X
            # konstant ein |.

            my ($line1,$rest) = split /\n/,$getText->($node,@args),2;
            my $block = sprintf "%s+--%s\n",$i? "|\n": '',$line1;

            if ($rest) {
                if ($follow[$level]) {
                    $rest =~ s/^/|  /mg;
                }
                else {
                    $rest =~ s/^/   /mg;
                }
                $block .= $rest;
            }

            # Einrückungs-Block und Knoten-Block zusammenfügen

            $block =~ s/^/$indent/mg;
            $str .= $block;
        }
    }
    elsif ($format eq 'debug') {
        for (@$lineA) {
            my ($follow,$level,$node,@args) = @$_;
            $str .= sprintf "%d %d %s%s%s\n",
                $level,
                $follow,
                '  ' x $level,
                $node,
                @args? join(' ',@args): '';
        }
    }
    elsif ($format eq 'compact') {
        for (@$lineA) {
            my ($follow,$level,$node,@args) = @$_;
            my ($line1,$rest) = split /\n/,$getText->($node,@args),2;
            $str .= sprintf "%s%s\n",'  ' x $level,$line1;
        }
    }
    else {
        $self->throw(
            q~TREE-FORMATTER-00001: Unknown format~,
            Format => $format,
        );
    }
    
    return $str;
}

# -----------------------------------------------------------------------------

=head1 VERSION

1.133

=head1 AUTHOR

Frank Seitz, L<http://fseitz.de/>

=head1 COPYRIGHT

Copyright (C) 2019 Frank Seitz

=head1 LICENSE

This code is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

# -----------------------------------------------------------------------------

1;

# eof
