143 lines
4.3 KiB
Perl
143 lines
4.3 KiB
Perl
# SPDX-FileCopyrightText: 2022 Stephan Barth <barths@gate2.tcs.ifi.lmu.de>
|
|
#
|
|
# SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
package Graphy;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use Tk;
|
|
use Data::Dumper;
|
|
|
|
# show the graph on a canvas and generate click hook (x,y -> name)
|
|
sub display {
|
|
my ($can, # canvas
|
|
$vertices, # hash ref; name -> x=>..,y=>..,col?=>..
|
|
$edges, # array ref; {from=>..,to=>..,col=>..}
|
|
$selected, # array ref, what to highlight
|
|
$config, # display configuration
|
|
) = @_;
|
|
my $keysstring = join ' ', keys %$vertices;
|
|
my $sep = '#';
|
|
$sep.=('#',':',',')[int rand 3] while $keysstring=~m/$sep/;
|
|
my %edgecollect = ();
|
|
for my $con(@$edges) {
|
|
my $u = $con->{from};
|
|
my $v = $con->{to};
|
|
next if $u eq $v; # XXX self loops thrown away, do not work, yet
|
|
my $dir = 1;
|
|
if($u gt $v) {
|
|
($u,$v) = ($v,$u);
|
|
$dir = -1;
|
|
}
|
|
my $at = "$u$sep$v";
|
|
push @{$edgecollect{$at}}, {u=>$u,v=>$v,dir=>$dir,con=>$con};
|
|
}
|
|
for my $k(keys %edgecollect) {
|
|
my %has = ();
|
|
my ($u,$v) = ();
|
|
for(@{$edgecollect{$k}}) { $has{$_->{dir}} = 1; ($u,$v) = @{$_}{'u','v'}}
|
|
if(keys %has > 1) {
|
|
push @{$edgecollect{$k}}, {u=>$u,v=>$v,dir=>0,con=>undef}
|
|
}
|
|
$edgecollect{$k} = [sort {
|
|
$a->{dir} <=> $b->{dir} ||
|
|
$a->{con}->{col} cmp $b->{con}->{col}
|
|
} @{$edgecollect{$k}}]
|
|
}
|
|
for my $conr(values %edgecollect) {
|
|
#print ">> $conr\n";
|
|
#print Data::Dumper::Dumper($conr);
|
|
my ($u,$v) = ();
|
|
for(@{$conr}) { ($u,$v) = @{$vertices}{@{$_}{'u','v'}} }
|
|
#print "<<$u $v>>\n";
|
|
my ($x0,$y0) = @{$u}{'x','y'};
|
|
my ($x1,$y1) = @{$v}{'x','y'};
|
|
my $dx = $x1-$x0;
|
|
my $dy = $y1-$y0;
|
|
my $normsq = $dx*$dx + $dy*$dy;
|
|
my $norm = sqrt $normsq;
|
|
my $rx = $dx/$norm*$config->{circr};
|
|
my $ry = $dy/$norm*$config->{circr};
|
|
my $horx = -$dy/$norm*$config->{linescale}*1.4;
|
|
my $hory = $dx/$norm*$config->{linescale}*1.4;
|
|
for(0..$#$conr) {
|
|
my $con = $conr->[$_];
|
|
#print Data::Dumper::Dumper($con);
|
|
if($con->{dir} != 0) {
|
|
my $col = $con->{con}->{col};
|
|
my $hor = $_-$#$conr/2;
|
|
my $smallrad = $config->{linescale}*1.5;
|
|
my $tx0 = $x0 + $horx*$hor;
|
|
my $ty0 = $y0 + $hory*$hor;
|
|
my $tx1 = $x1 + $horx*$hor;
|
|
my $ty1 = $y1 + $hory*$hor;
|
|
my ($hx,$hy) = ($tx0+$rx,$ty0+$ry);
|
|
($hx,$hy) = ($tx1-$rx,$ty1-$ry) if $con->{dir} > 0;
|
|
$can->createOval($hx-$smallrad,$hy-$smallrad,$hx+$smallrad,$hy+$smallrad,-fill=>$col);
|
|
$can->createLine(
|
|
$tx0, $ty0,
|
|
$tx1, $ty1,
|
|
-width=>$config->{linescale},
|
|
-fill=>$col,
|
|
);
|
|
}
|
|
}
|
|
}
|
|
# for my $con(@$edges) {
|
|
# my ($x0,$y0) = @{$vertices->{$con->{from}}}{'x','y'};
|
|
# my ($x1,$y1) = @{$vertices->{$con->{to}}}{'x','y'};
|
|
# my $dx = $x1-$x0;
|
|
# my $dy = $y1-$y0;
|
|
# my $normsq = $dx*$dx + $dy*$dy;
|
|
# my $norm = sqrt $normsq;
|
|
# my $rx = $dx/$norm*$config->{circr};
|
|
# my $ry = $dy/$norm*$config->{circr};
|
|
# my $hx = $x1-$rx;
|
|
# my $hy = $y1-$ry;
|
|
# $can->createOval($hx-8,$hy-8,$hx+8,$hy+8,-fill=>$con->{col});
|
|
# $can->createLine(
|
|
# $x0, $y0,
|
|
# $x1, $y1,
|
|
# -width=>5,
|
|
# -fill=>$con->{col},
|
|
# );
|
|
# }
|
|
for my $k(keys %$vertices) {
|
|
my $v = $vertices->{$k};
|
|
my $text = $k;
|
|
$text=~s/&/&\n/gs;
|
|
$text=~s/\s+/\n/gs;
|
|
$text=~s/~\s+/ /gs;
|
|
$text=~s/~~/~/g;
|
|
$can->createOval($v->{x}-$config->{circr},$v->{y}-$config->{circr},$v->{x}+$config->{circr},$v->{y}+$config->{circr},-fill=>$v->{col});
|
|
$can->createText($v->{x}-1,$v->{y}-1,-fill=>'#ffffff',-text=>$text);
|
|
$can->createText($v->{x}+1,$v->{y}-1,-fill=>'#ffffff',-text=>$text);
|
|
$can->createText($v->{x}-1,$v->{y}+1,-fill=>'#ffffff',-text=>$text);
|
|
$can->createText($v->{x}+1,$v->{y}+1,-fill=>'#ffffff',-text=>$text);
|
|
$can->createText($v->{x}+2,$v->{y},-fill=>'#ffffff',-text=>$text);
|
|
$can->createText($v->{x}-2,$v->{y},-fill=>'#ffffff',-text=>$text);
|
|
$can->createText($v->{x},$v->{y},-fill=>'#000000',-text=>$text);
|
|
}
|
|
|
|
return sub {
|
|
my ($x,$y) = @_;
|
|
my $ret = undef;
|
|
my $bestd = -2;
|
|
for my $k(keys %$vertices) {
|
|
my $v = $vertices->{$k};
|
|
my $dx = $x-$v->{x};
|
|
my $dy = $y-$v->{y};
|
|
my $distsq = $dx*$dx + $dy*$dy;
|
|
if($bestd < -1 || $distsq < $bestd) {
|
|
$bestd = $distsq;
|
|
$ret = $k;
|
|
}
|
|
}
|
|
return $ret;
|
|
};
|
|
}
|
|
|
|
1;
|