diff options
author | Yorhel <git@yorhel.nl> | 2020-04-06 18:22:47 +0200 |
---|---|---|
committer | Yorhel <git@yorhel.nl> | 2020-04-06 18:22:47 +0200 |
commit | 7cfc606c4ae05814fb4dde6fce90dcb09cb93679 (patch) | |
tree | 5be04b0c10e7f2e676bd6d8cb57d7eb51f590fd2 /lib/Multi/RG.pm | |
parent | 91c5ca72e9c90c5a60f71e53a68c980094a59da8 (diff) |
Delete old relation graph generating and caching machinery
Diffstat (limited to 'lib/Multi/RG.pm')
-rw-r--r-- | lib/Multi/RG.pm | 352 |
1 files changed, 0 insertions, 352 deletions
diff --git a/lib/Multi/RG.pm b/lib/Multi/RG.pm deleted file mode 100644 index 57722c9c..00000000 --- a/lib/Multi/RG.pm +++ /dev/null @@ -1,352 +0,0 @@ - -# -# Multi::RG - Relation graph generator -# - -# XXX: The producer graphs generated here are not used at the moment, that's -# now done on demand in VNWeb::Producers::Graph. If that's successful, the same -# approach will be applied to VN graphs and this module can be removed -# entirely. - -package Multi::RG; - -use strict; -use warnings; -use Multi::Core; -use AnyEvent::Util; -use Encode 'encode_utf8'; -use XML::Parser; -use TUWF::XML; -use VNDB::Types; - - -my %O = ( - font => 'Arial', - fsize => [ 9, 7, 10 ], # nodes, edges, node_title - dot => '/usr/bin/dot', - check_delay => 3600, -); - - -my %C; - - -sub run { - shift; - %O = (%O, @_); - push_watcher schedule 0, $O{check_delay}, \&check_rg; - push_watcher pg->listen(relgraph => on_notify => \&check_rg); -} - - -sub check_rg { - # Only process one at a time, we don't know how many other entries the - # current graph will affect. - return if $C{id}; - - AE::log debug => 'Checking for new graphs to create.'; - pg_cmd q| - SELECT 'v', v.id FROM vn v JOIN vn_relations vr ON vr.id = v.id WHERE v.rgraph IS NULL AND v.hidden = FALSE - UNION - SELECT 'p', p.id FROM producers p JOIN producers_relations pr ON pr.id = p.id WHERE p.rgraph IS NULL AND p.hidden = FALSE - LIMIT 1|, undef, sub { - my($res, $time) = @_; - return if pg_expect $res, 1 or !$res->rows; - creategraph(scalar $res->value(0, 0), scalar $res->value(0, 1), 0, $time); - } -} - - -sub creategraph { - my($type, $id, $official, $sqlt) = @_; - - %C = ( - start => scalar AE::time(), - type => $type, - id => $id, - sqlt => $sqlt, - offi => $official, - rels => {}, # relations (key=id1-id2, value=[relation,official]) - nodes => {}, # nodes (key=id, value= 0:found, 1:processed) - ); - - AE::log debug => "Generating graph for $C{type}$C{id}"; - getrelid($C{id}); -} - - -sub getrelid { - my $id = shift; - AE::log debug => "Fetching relations for $C{type}$id"; - pg_cmd $C{type} eq 'p' - ? 'SELECT pid, relation FROM producers_relations WHERE id = $1' - : $C{offi} ? 'SELECT vid, relation, official FROM vn_relations WHERE id = $1 AND official' - : 'SELECT vid, relation, official FROM vn_relations WHERE id = $1', - [ $id ], sub { getrel($id, @_) }; -} - - -sub getrel { # id, res, time - my($id, $res, $time) = @_; - return if pg_expect $res, 1, $id; - - $C{sqlt} += $time; - $C{nodes}{$id} = 1; - - for($res->rows) { - my($xid, $xrel, $xoff) = @$_; - $xoff = 0 if $xoff && $xoff =~ /^f/; - - $C{rels}{$id.'-'.$xid} = [ ($C{type} eq 'v' ? \%VN_RELATION : \%PRODUCER_RELATION)->{$xrel}{reverse}, $xoff ] if $id < $xid; - $C{rels}{$xid.'-'.$id} = [ $xrel, $xoff ] if $id > $xid; - - # New node? Get its relations too. - if(!exists $C{nodes}{$xid}) { - $C{nodes}{$xid} = 0; - getrelid $xid; - } - } - - # Wait for other node relations to come in. - return if grep !$_, values %{$C{nodes}}; - - # For VNs: If the graph has more than 30 nodes and there are unofficial - # links, start again, this time throwing away the unofficial links. - # XXX: This is an ugly hack. - # - This would remove unofficial links between VNs that are in the graph anyway. - # - It can result in graphs with just a single VN node and no links. - # - How well does this work together with the current caching mechanism? It's - # possible that a distant VN doesn't get its relation graph updated because - # it's being excluded here. - if($C{type} eq 'v' && scalar keys %{$C{nodes}} > 30 && grep !$_->[1], values %{$C{rels}}) { - AE::log info => "Graph for $C{type}$C{id} is too large, re-creating graph without unofficial links"; - return creategraph v => $C{id}, 1, $C{sqlt}; - } - - # do we have all relations now? get node info - my @ids = keys %{$C{nodes}}; - my $ids = join(', ', map '$'.$_, 1..@ids); - AE::log debug => "Fetching node information for $C{type}:".join ', ', @ids; - pg_cmd $C{type} eq 'v' - ? "SELECT id, title, c_released AS date, array_to_string(c_languages, '/') AS lang FROM vn WHERE id IN($ids) ORDER BY c_released" - : "SELECT id, name, lang, type FROM producers WHERE id IN($ids) ORDER BY name", - [ @ids ], \&builddot; -} - - -sub builddot { - my($res, $time) = @_; - return if pg_expect $res, 1, $C{id}; - $C{sqlt} += $time; - - my $gv = - qq|graph rgraph {\n|. - qq|\tnode [ fontname = "$O{font}", shape = "plaintext",|. - qq| fontsize = $O{fsize}[0], fontcolor = "#333333", color = "#111111" ]\n|. - qq|\tedge [ labeldistance = 2.5, labelangle = -20, labeljust = 1, minlen = 2, dir = "both",|. - qq| fontname = $O{font}, fontsize = $O{fsize}[1], arrowsize = 0.7, color = "#111111", fontcolor = "#333333" ]\n|; - - # insert all nodes and relations - my %nodes = map +($_->{id}, $_), $res->rowsAsHashes; - $gv .= $C{type} eq 'v' ? gv_vnnode($nodes{$_}) : gv_prodnode($nodes{$_}) for keys %nodes; - $gv .= $C{type} eq 'v' ? gv_vnrels($C{rels}, \%nodes) : gv_prodrels($C{rels}, \%nodes); - - $gv .= "}\n"; - - rundot($gv); -} - - -sub gv_vnnode { - my $n = shift; - - my $date = sprintf '%08d', $n->{date}; - $date =~ s{^([0-9]{4})([0-9]{2})([0-9]{2})$}{ - $1 == 0 ? 'unknown' - : $1 == 9999 ? 'TBA' - : $2 == 99 ? $1 - : $3 == 99 ? "$1-$2" : "$1-$2-$3" - }e; - - my $title = $n->{title}; - $title = substr($title, 0, 27).'...' if length($title) > 30; - $title =~ s/&/&/g; - $title =~ s/>/>/g; - $title =~ s/</</g; - - my $tooltip = $n->{title}; - $tooltip =~ s/\\/\\\\/g; - $tooltip =~ s/"/\\"/g; - - return sprintf - qq|\tv%d [ id = "node_v%1\$d", URL = "/v%1\$d", tooltip = "%s", label=<|. - q|<TABLE CELLSPACING="0" CELLPADDING="1" BORDER="0" CELLBORDER="1" BGCOLOR="#222222">|. - q|<TR><TD COLSPAN="2" ALIGN="CENTER" CELLPADDING="2"><FONT POINT-SIZE="%d"> %s </FONT></TD></TR>|. - q|<TR><TD> %s </TD><TD> %s </TD></TR>|. - qq|</TABLE>> ]\n|, - $n->{id}, encode_utf8($tooltip), $O{fsize}[2], encode_utf8($title), $date, $n->{lang}||'N/A'; -} - - -sub gv_vnrels { - my($rels, $vns) = @_; - my $r = ''; - - # @rels = ([ vid1, vid2, relation, official, date1, date2 ], ..), for easier processing - my @rels = map { - /^([0-9]+)-([0-9]+)$/; - [ $1, $2, @{$rels->{$_}}, $vns->{$1}{date}, $vns->{$2}{date} ] - } keys %$rels; - - # insert all edges, ordered by release date - for (sort { ($a->[4]>$a->[5]?$a->[5]:$a->[4]) <=> ($b->[4]>$b->[5]?$b->[5]:$b->[4]) } @rels) { - # [older game] -> [newer game] - if($_->[5] > $_->[4]) { - ($_->[0], $_->[1]) = ($_->[1], $_->[0]); - $_->[2] = $VN_RELATION{$_->[2]}{reverse}; - } - my $rel = $VN_RELATION{$_->[2]}{txt}; - my $rev = $VN_RELATION{ $VN_RELATION{$_->[2]}{reverse} }{txt}; - my $style = $_->[3] ? '' : ', style="dotted"'; - my $label = $rev ne $rel - ? qq|headlabel = "$rel" taillabel = "${rev}" $style| - : qq|label = "$rel" $style|; - $r .= qq|\tv$$_[1] -- v$$_[0] [ $label ]\n|; - } - $r; -} - - -sub gv_prodnode { - my $n = shift; - - my $name = $n->{name}; - $name = substr($name, 0, 27).'...' if length($name) > 30; - $name =~ s/&/&/g; - $name =~ s/>/>/g; - $name =~ s/</</g; - - my $tooltip = $n->{name}; - $tooltip =~ s/\\/\\\\/g; - $tooltip =~ s/"/\\"/g; - - return sprintf - qq|\tp%d [ id = "node_p%1\$d", URL = "/p%1\$d", tooltip = "%s", label=<|. - q|<TABLE CELLSPACING="0" CELLPADDING="1" BORDER="0" CELLBORDER="1" BGCOLOR="#222222">|. - q|<TR><TD COLSPAN="2" ALIGN="CENTER" CELLPADDING="2"><FONT POINT-SIZE="%d"> %s </FONT></TD></TR>|. - q|<TR><TD ALIGN="CENTER"> %s </TD><TD ALIGN="CENTER"> %s </TD></TR>|. - qq|</TABLE>> ]\n|, - $n->{id}, encode_utf8($tooltip), $O{fsize}[2], encode_utf8($name), - $LANGUAGE{$n->{lang}}, $PRODUCER_TYPE{$n->{type}}; -} - - -sub gv_prodrels { - my($rels, $prods) = @_; - my $r = ''; - - for (keys %$rels) { - /^([0-9]+)-([0-9]+)$/; - my $p1 = $prods->{$1}; - my $p2 = $prods->{$2}; - - my $rel = $PRODUCER_RELATION{$rels->{$_}[0]}{txt}; - my $rev = $PRODUCER_RELATION{ $PRODUCER_RELATION{$rels->{$_}[0]}{reverse} }{txt}; - my $label = $rev ne $rel - ? qq|headlabel = "$rev", taillabel = "$rel"| - : qq|label = "$rel"|; - $r .= qq|\tp$p1->{id} -- p$p2->{id} [ $label ]\n|; - } - $r; -} - - -sub rundot { - my $gv = shift; - AE::log trace => "Running graphviz, dot:\n$gv"; - - my $svg; - my $cv = run_cmd [ $O{dot}, '-Tsvg' ], - '<', \$gv, - '>', \$svg, - '2>', sub { AE::log warn => "STDERR from graphviz: $_[0]" if $_[0]; }; - - $cv->cb(sub { - return AE::log warn => 'graphviz failed' if shift->recv; - processgraph($svg); - }); -} - - -sub processgraph { - my $data = shift; - - # Before saving the SVG output, we'll modify it a little: - # - Remove comments - # - Remove <title> elements (unused) - # - Remove id attributes (unused) - # - Remove first <polygon> element (emulates the background color) - # - Replace stroke and fill attributes with classes (so that coloring is done in CSS) - my $svg = ''; - my $w = TUWF::XML->new(write => sub { $svg .= shift }); - my $p = XML::Parser->new; - $p->setHandlers( - Start => sub { - my($expat, $el, %attr) = @_; - return if $el eq 'title' || $expat->in_element('title'); - return if $el eq 'polygon' && $expat->depth == 2; - - $attr{class} = 'border' if $attr{stroke} && $attr{stroke} eq '#111111'; - $attr{class} = 'nodebg' if $attr{fill} && $attr{fill} eq '#222222'; - - delete @attr{qw|stroke fill|}; - delete $attr{id} if $attr{id} && $attr{id} !~ /^node_[vp]\d+$/; - $w->tag($el, %attr, $el eq 'path' || $el eq 'polygon' ? undef : ()); - }, - End => sub { - my($expat, $el) = @_; - return if $el eq 'title' || $expat->in_element('title'); - return if $el eq 'polygon' && $expat->depth == 2; - $w->end($el) if $el ne 'path' && $el ne 'polygon'; - }, - Char => sub { - my($expat, $str) = @_; - return if $expat->in_element('title'); - $w->txt($str) if $str !~ /^[\s\t\r\n]*$/s; - } - ); - $p->parsestring($data); - - # save the processed SVG in the database and fetch graph ID - AE::log trace => "Processed SVG:\n$svg"; - pg_cmd 'INSERT INTO relgraphs (svg) VALUES ($1) RETURNING id', [ $svg ], \&save_rgraph; -} - - -sub save_rgraph { - my($res, $time) = @_; - return if pg_expect $res, 1; - $C{sqlt} += $time; - - my $graphid = $res->value(0,0); - my @ids = sort keys %{$C{nodes}}; - my $ids = join ',', map '$'.$_, 2..@ids+1; - my $table = $C{type} eq 'v' ? 'vn' : 'producers'; - - pg_cmd "UPDATE $table SET rgraph = \$1 WHERE id IN($ids)", - [ $graphid, @ids ], - sub { - my($res, $time) = @_; - return if pg_expect $res, 0; - $C{sqlt} += $time; - - AE::log info => sprintf 'Generated relation graph #%d in %.2fs (%.2fs SQL), %s: %s', - $graphid, AE::time-$C{start}, $C{sqlt}, $C{type}, join ',', @ids; - - %C = (); - check_rg; - }; -} - - -1; |