Visualisierungsprototyp hochgeladen.
This commit is contained in:
Stephan Barth
parent
cf7dcf58c5
commit
43ad0da50e
138
tools/visualize/Graphy.pm
Normal file
138
tools/visualize/Graphy.pm
Normal file
@ -0,0 +1,138 @@
|
||||
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;
|
||||
90
tools/visualize/WFparse.pm
Normal file
90
tools/visualize/WFparse.pm
Normal file
@ -0,0 +1,90 @@
|
||||
package WFparse;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
sub parsefile {
|
||||
my $fn = shift;
|
||||
my $fh = undef;
|
||||
open($fh, '<', $fn) or die "Could not read '$fn', because: $!\n";
|
||||
my @cont = <$fh>;
|
||||
chomp for @cont;
|
||||
return parselines(@cont);
|
||||
}
|
||||
|
||||
sub parselines {
|
||||
my @cont = @_;
|
||||
my %node = ();
|
||||
my $name = undef;
|
||||
my $edgeto = undef;
|
||||
my $state = "init";
|
||||
my $source = undef;
|
||||
my @linebuffer_master = ();
|
||||
my @linebuffer_edges = ();
|
||||
my %edges = ();
|
||||
my $consumeedge = sub {
|
||||
return if $state eq 'node-edges';
|
||||
return unless $state =~ m/^node-edges/;
|
||||
$edges{$edgeto} = {lines=>[@linebuffer_edges],source=>$source};
|
||||
$source = undef;
|
||||
@linebuffer_edges = ();
|
||||
$edgeto = undef;
|
||||
};
|
||||
my $finalizenode = sub {
|
||||
return if $state eq 'init';
|
||||
$consumeedge->();
|
||||
$node{$name}={
|
||||
lines=>[@linebuffer_master],
|
||||
edges=>{%edges},
|
||||
};
|
||||
@linebuffer_master = ();
|
||||
%edges = ();
|
||||
$name=undef;
|
||||
};
|
||||
for my $i(0..$#cont) {
|
||||
my $l = $cont[$i];
|
||||
do {push @linebuffer_master, $l;next} if $l=~m/^\s*(?:#.*)?$/;
|
||||
$l=~m#^"(.*)":$# and do {
|
||||
$finalizenode->();
|
||||
$state = 'node-master';
|
||||
$name = $1;
|
||||
next;
|
||||
};
|
||||
$state eq 'node-master' && $l=~m#^ edges:$# and do {
|
||||
$state = 'node-edges';
|
||||
next;
|
||||
};
|
||||
$state=~m/^node-edges/ && $l=~m/^ "(.*)":/ and do {
|
||||
my $ename = $1;
|
||||
$consumeedge->();
|
||||
$edgeto = $ename;
|
||||
$state = "node-edges-inedge";
|
||||
next;
|
||||
};
|
||||
$state=~m/node-edges/ && $l=~m/^ source: "(.*)"/ and do {
|
||||
$source = $1;
|
||||
next;
|
||||
};
|
||||
$state=~m/node-edges/ && $l=~m/^ (.*)/ and do {
|
||||
push @linebuffer_edges, $1;
|
||||
next;
|
||||
};
|
||||
$state=~m/node-edges/ && $l=~m/^ (.*)/ and do {
|
||||
my $read = $1;
|
||||
$consumeedge->();
|
||||
$state = "node-master";
|
||||
push @linebuffer_master, $read;
|
||||
next;
|
||||
};
|
||||
$state=~m/node-master/ && $l=~m/^ (.*)/ and do {
|
||||
push @linebuffer_master, $1;
|
||||
next;
|
||||
};
|
||||
die "Unexpeced line in state $state: $l (line ".($i+1).")\n";
|
||||
}
|
||||
return (\%node);
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
219
tools/visualize/gui.pl
Executable file
219
tools/visualize/gui.pl
Executable file
@ -0,0 +1,219 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use YAML::XS;
|
||||
use Data::Dumper;
|
||||
use Tk;
|
||||
use Math::Trig;
|
||||
|
||||
BEGIN {
|
||||
my $pwd = $0;
|
||||
$pwd=~s#/[^/]+$##;
|
||||
push @INC, $pwd;
|
||||
};
|
||||
|
||||
use Graphy;
|
||||
use WFparse;
|
||||
|
||||
my $fn = shift;
|
||||
die unless -e $fn;
|
||||
|
||||
my $maindata = WFparse::parsefile($fn);
|
||||
|
||||
#my $fh = undef;
|
||||
#open($fh, '<', $fn) or die "Could not open $fn, as: $!";
|
||||
#my $data = join '', <$fh>;
|
||||
#close $fh;
|
||||
#
|
||||
#my $yaml = Load($data);
|
||||
#
|
||||
##print "<<<<<<< ", ref $yaml;
|
||||
#
|
||||
#$yaml = {nodes => $yaml}
|
||||
# unless
|
||||
# 1 == %$yaml and exists $yaml->{nodes}
|
||||
# #'HASH' eq ref $yaml
|
||||
# ;
|
||||
#
|
||||
#print Dumper($yaml);
|
||||
#
|
||||
#print "Analyze \$yaml\n";
|
||||
#for my $k(keys %$yaml) {
|
||||
# print " Key found: $k\n";
|
||||
#}
|
||||
#
|
||||
#my $nodes = $yaml->{nodes};
|
||||
#
|
||||
#print "Analyze \$nodes\n";
|
||||
#for my $k(keys %$nodes) {
|
||||
# print " Key found: $k\n";
|
||||
#}
|
||||
#
|
||||
#print Dumper($nodes->{antrag});
|
||||
#
|
||||
#my $onenode = $nodes->{antrag};
|
||||
#
|
||||
#print "Analyze \$onenode\n";
|
||||
#for my $k(keys %$onenode) {
|
||||
# print " Key found: $k\n";
|
||||
#}
|
||||
#
|
||||
#my $edges = $onenode->{edges};
|
||||
#
|
||||
#print Dumper($edges);
|
||||
#
|
||||
#
|
||||
#for my $nk(sort keys %$nodes) {
|
||||
# my $ed = $nodes->{$nk}->{edges};
|
||||
# for my $ek(sort keys %$ed) {
|
||||
# my $src = ' (thin air)';
|
||||
# $src = $ed->{$ek}->{source} if $ed->{$ek}->{source};
|
||||
# print "$src --$ek--> $nk\n";
|
||||
# }
|
||||
# #print " Key found: $k\n";
|
||||
#}
|
||||
|
||||
my %xy = (); # xy-extradata, where it is not stated in the yaml
|
||||
|
||||
my %nodes = %$maindata;
|
||||
|
||||
my %layout = (
|
||||
width=>800,
|
||||
height=>800,
|
||||
horsplit=>0.5,
|
||||
vertsplit=>0.5,
|
||||
);
|
||||
|
||||
my @nodekeys = sort keys %nodes;
|
||||
for my $i(0..$#nodekeys) {
|
||||
my $nk = $nodekeys[$i];
|
||||
my $phi = ($i/@nodekeys) * 2 * pi;
|
||||
my $x = 400 + 300*sin $phi;
|
||||
my $y = 400 + 300*cos $phi;
|
||||
#$x = $nodes->{$nk}->{x}*800 if $nodes->{$nk}->{x};
|
||||
#$y = $nodes->{$nk}->{y}*800 if $nodes->{$nk}->{y};
|
||||
$xy{$nk} = [$x,$y];
|
||||
}
|
||||
|
||||
my $main = MainWindow->new();
|
||||
my $can = $main->Canvas(-width=>800,-height=>800,-background=>'#000000')->pack(-side=>'left');
|
||||
my $texte = $main->Frame->pack(-side=>'left');
|
||||
my $knotentext = $texte->Text->pack;
|
||||
my $knotenwahl = $texte->Frame->pack(-expand=>1,-fill=>'x');
|
||||
my $kantentext = $texte->Text->pack;
|
||||
|
||||
my $zentrierer = $knotenwahl->Canvas(-width=>80,-height=>80,-background=>'#000044')->pack(-side=>'left');
|
||||
my $filler = $knotenwahl->Frame->pack(-side=>'left',-expand=>1,-fill=>'x');
|
||||
#$knotenwahl->Label(-text=>'Foo')->pack(-side=>'left',-expand=>1,-fill=>'x');
|
||||
|
||||
my $picker = sub {return undef};
|
||||
|
||||
my @hl = ();
|
||||
|
||||
$can->Tk::bind('<1>' => [sub {
|
||||
my (undef, $x, $y) = @_;
|
||||
my $got = $picker->($x,$y);
|
||||
if(defined $got) {
|
||||
push @hl, $got;
|
||||
shift @hl if @hl > 2;
|
||||
show();
|
||||
}
|
||||
}, Ev('x'), Ev('y')]);
|
||||
|
||||
$can->Tk::bind('<3>' => [sub {
|
||||
my (undef, $x, $y) = @_;
|
||||
@hl = ();
|
||||
show();
|
||||
}, Ev('x'), Ev('y')]);
|
||||
|
||||
|
||||
show();
|
||||
|
||||
MainLoop;
|
||||
|
||||
sub show {
|
||||
$can->delete('all');
|
||||
my %pts = ();
|
||||
my @trans = ();
|
||||
for my $nk(sort keys %nodes) {
|
||||
my $ed = $nodes{$nk}->{edges};
|
||||
for my $ek(sort keys %$ed) {
|
||||
my ($xt,$yt) = @{$xy{$nk}};
|
||||
my $src = ' (thin air)';
|
||||
my ($xs,$ys) = ($xt,$yt);
|
||||
if($ed->{$ek}->{source}) {
|
||||
$src = $ed->{$ek}->{source};
|
||||
print "$src --$ek--> $nk\n";
|
||||
($xs,$ys) = @{$xy{$src}};
|
||||
} else {
|
||||
$_ = $_-400 for $xs,$ys;
|
||||
$_ = $_*1.3 for $xs,$ys;
|
||||
my $dx = $ys*0.3;
|
||||
my $dy = -$xs*0.3;
|
||||
$xs += $dx;
|
||||
$ys += $dy;
|
||||
$_ = $_+400 for $xs,$ys;
|
||||
$src = "$nk (thin~ air)";
|
||||
$pts{$src} = {x=>$xs,y=>$ys,col=>'#8888aa'};
|
||||
}
|
||||
#$can->createLine($xs,$ys,$xt,$yt,-fill=>'#ffffff',-width=>3);
|
||||
push @trans, {from=>$src, to=>$nk, col=>'#ffffff'}
|
||||
}
|
||||
#print " Key found: $k\n";
|
||||
my ($x,$y) = @{$xy{$nk}};
|
||||
$pts{$nk} = {x=>$x,y=>$y,col=>'#8888aa'};
|
||||
}
|
||||
$picker = Graphy::display(
|
||||
$can,
|
||||
\%pts,
|
||||
\@trans,
|
||||
[],
|
||||
{circr=>42, linescale=>5}
|
||||
);
|
||||
{
|
||||
my ($x0,$y0,$x1,$y1) = ();
|
||||
if($hl[0]) {
|
||||
my $o = $nodes{$hl[0]};
|
||||
($x0, $y0) = @{$xy{$hl[0]}};
|
||||
my $r = 46;
|
||||
$can->createOval($x0-$r,$y0-$r,$x0+$r,$y0+$r,-fill=>undef,-outline=>'#ff00ff',-width=>6);
|
||||
}
|
||||
if($hl[1]) {
|
||||
my $o = $nodes{$hl[1]};
|
||||
($x1, $y1) = @{$xy{$hl[1]}};
|
||||
my $r = 50;
|
||||
$can->createOval($x1-$r,$y1-$r,$x1+$r,$y1+$r,-fill=>undef,-outline=>'#ff00ff',-width=>9);
|
||||
my $minr = 12;
|
||||
$can->createOval($x1-$minr,$y1-$minr,$x1+$minr,$y1+$minr,-fill=>'#8800ff',-outline=>'#ffffff');
|
||||
$can->createLine($x0,$y0,$x1,$y1,-fill=>'#8800ff',-width=>$minr);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub show_ {
|
||||
$can->delete('all');
|
||||
for my $nk(sort keys %nodes) {
|
||||
my $ed = $nodes{$nk}->{edges};
|
||||
for my $ek(sort keys %$ed) {
|
||||
my ($xt,$yt) = @{$xy{$nk}};
|
||||
my $src = ' (thin air)';
|
||||
my ($xs,$ys) = ($xt,$yt);
|
||||
if($ed->{$ek}->{source}) {
|
||||
$src = $ed->{$ek}->{source};
|
||||
print "$src --$ek--> $nk\n";
|
||||
($xs,$ys) = @{$xy{$src}};
|
||||
} else {
|
||||
$_ = ($_-400)*1.2+400 for $xs,$ys;
|
||||
}
|
||||
$can->createLine($xs,$ys,$xt,$yt,-fill=>'#ffffff',-width=>3);
|
||||
}
|
||||
#print " Key found: $k\n";
|
||||
}
|
||||
for my $nk(sort keys %nodes) {
|
||||
my ($x,$y) = @{$xy{$nk}};
|
||||
$can->createOval($x-7,$y-7,$x+7,$y+7,-fill=>'#ffffff');
|
||||
$can->createText($x,$y,-fill=>'#8888ff',-text=>$nk);
|
||||
}
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user