summaryrefslogtreecommitdiff
path: root/lib/VNWeb/Producers/Graph.pm
blob: 005a2492dde11a25482c0ab13b698654b745de3b (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
package VNWeb::Producers::Graph;

use VNWeb::Prelude;
use VNWeb::Graph;


TUWF::get qr{/$RE{pid}/rg}, sub {
    my $id = tuwf->capture(1);
    my $num = tuwf->validate(get => num => { uint => 1, onerror => 15 })->data;
    my $p = tuwf->dbRowi('SELECT id, name, original, hidden AS entry_hidden, locked AS entry_locked FROM producers WHERE id =', \$id);

    # Big list of { id0, id1, relation } hashes.
    # Each relation is included twice, with id0 and id1 reversed.
    my $rel = tuwf->dbAlli(q{
        WITH RECURSIVE rel(id0, id1, relation) AS (
            SELECT id, pid, relation FROM producers_relations WHERE id =}, \$id, q{
            UNION
            SELECT id, pid, pr.relation FROM producers_relations pr JOIN rel r ON pr.id = r.id1
        ) SELECT * FROM rel ORDER BY id0
    });
    return tuwf->resNotFound if !@$rel;

    # Fetch the nodes
    my $nodes = gen_nodes $id, $rel, $num;
    enrich_merge id => 'SELECT id, name, lang, type FROM producers WHERE id IN', values %$nodes;

    my $total_nodes = keys { map +($_->{id0},1), @$rel }->%*;
    my $visible_nodes = keys %$nodes;

    my @lines;
    my $params = $num == 15 ? '' : "?num=$num";
    for my $n (sort { idcmp $a->{id}, $b->{id} } values %$nodes) {
        my $name = val_escape shorten $n->{name}, 27;
        my $tooltip = val_escape $n->{name};
        my $nodeid = $n->{distance} == 0 ? 'id = "graph_current", ' : '';
        push @lines,
            qq|n$n->{id} [ $nodeid URL = "/$n->{id}", tooltip = "$tooltip", label=<|.
            qq|<TABLE CELLSPACING="0" CELLPADDING="2" BORDER="0" CELLBORDER="1" BGCOLOR="#222222">|.
            qq|<TR><TD COLSPAN="2" ALIGN="CENTER" CELLPADDING="3"><FONT POINT-SIZE="9">  $name  </FONT></TD></TR>|.
            qq|<TR><TD ALIGN="CENTER"> $LANGUAGE{$n->{lang}} </TD><TD ALIGN="CENTER"> $PRODUCER_TYPE{$n->{type}} </TD></TR>|.
            qq|</TABLE>> ]|;

        push @lines, node_more $n->{id}, "/$n->{id}/rg$params", scalar grep !$nodes->{$_}, $n->{rels}->@*;
    }

    $rel = [ grep $nodes->{$_->{id0}} && $nodes->{$_->{id1}}, @$rel ];
    my $dot = gen_dot \@lines, $nodes, $rel, \%PRODUCER_RELATION;

    framework_ title => "Relations for $p->{name}", type => 'p', dbobj => $p, tab => 'rg',
    sub {
        div_ class => 'mainbox', style => 'float: left; min-width: 100%', sub {
            h1_ "Relations for $p->{name}";
            p_ sub {
                txt_ sprintf "Displaying %d out of %d related producers.", $visible_nodes, $total_nodes;
                debug_ +{ nodes => $nodes, rel => $rel };
                br_;
                txt_ "Adjust graph size: ";
                join_ ', ', sub {
                    if($_ == min $num, $total_nodes) {
                        txt_ $_ ;
                    } else {
                        a_ href => "/$id/rg?num=$_", $_;
                    }
                }, grep($_ < $total_nodes, 10, 15, 25, 50, 75, 100, 150, 250, 500, 750, 1000), $total_nodes;
                txt_ '.';
            } if $total_nodes > 10;
            p_ class => 'center', sub { lit_ dot2svg $dot };
        };
        clearfloat_;
    };
};

1;