# Copyright (c) 1997-2006
# Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Berlin, Germany)
# http://www.math.tu-berlin.de/polymake, mailto:polymake@math.tu-berlin.de
#
# This program is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 2, or (at your option) any
# later version: http://www.gnu.org/licenses/gpl.txt.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#-----------------------------------------------------------------------------
# $Project: polymake $$Id: Visual.pm 7540 2006-12-21 21:04:18Z gawrilow $
package Modules::common;
sub prepare_visual_objects {
my @args=@_;
for (my $i=0; $i<=$#args; ++$i) {
if (is_object($args[$i])) {
my $attached=$args[$i]->attached;
if (@{$attached}) {
splice @args, $i+1, 0, @$attached;
@$attached=();
}
if (instanceof Visual::Container($args[$i])) {
$args[$i]->propagate_defaults;
splice @args, $i, 1, @{$args[$i]->elements};
redo;
}
}
}
@args;
}
# Viewer, VisualObject, ... =>
sub visualize_with($@) {
my $viewer_pkg=shift;
my $viewer;
foreach my $vis (@_) {
my $title=defined($vis->Title) ? $vis->Title : $vis->Name;
$viewer=$viewer_pkg->new_drawing($title);
foreach my $obj (prepare_visual_objects($vis)) {
if (is_object($obj)) {
$viewer->draw($obj);
} elsif (@$obj) {
my $method=$viewer->can("draw", $obj->[0], undef)
or die "no matching method ", ref($viewer), "::draw(", ref($obj->[0]), ")\n";
foreach my $elem (@$obj) {
$method->($viewer,$elem);
}
}
}
}
$viewer;
}
sub start_deferred_visualizer {
my ($pkg, $title)=@_;
my $viewer=($main::scope->deferred->{$pkg} ||= $pkg->new);
$viewer->new_drawing($title);
}
#
# the central dispatching function
#
sub visualize($) {
my $first=shift;
return $first if defined wantarray;
my @args=prepare_visual_objects($first);
my $title=defined($first->Title) ? $first->Title : $first->Name;
my ($method, $obj);
if (@args==1) {
eval {
if (is_object($args[0])) {
# a single object to draw - can use the overloading directly
$method=Poly::Overload::Global::draw($args[0]);
$method->(start_deferred_visualizer(method_owner($method),$title), $args[0]);
} else {
return undef if !@{$args[0]};
# should be a homogeneous array of drawables - resolve only once
$method=Poly::Overload::Global::draw($args[0]->[0]);
my $vis=start_deferred_visualizer(method_owner($method),$title);
foreach $obj (@{$args[0]}) {
$method->($vis, $obj, undef);
}
}
};
if ($@) {
if ($@ =~ /no matching overloaded instance of Poly::Overload::Global::draw/) {
die "do not know how to visualize ", ref($args[0]) eq "ARRAY" ? ref($args[0]->[0]) : ref($args[0]),
"\nprobably you should install some missing visualization packages\n";
}
if ($@ =~ /Undefined subroutine &Poly::Overload::Global::draw/) {
die "cannot visualize anything: no visualization packages installed\n";
}
die $@;
}
} else {
# several drawable objects:
# first obtain all viable visualizers, even if not preferred
$obj=$args[0];
my @methods;
if (defined (my $list=resolve Poly::Overload "Poly::Overload::Global::draw",
is_object($obj) ? $obj : $obj->[0], undef)) {
# must try all visualizers in the preference order until find such a one
# that can cope with all drawable objects
TRY:
foreach my $sub (is_ARRAY($list) ? Poly::Preference::Label::get_items($list) : ($list)) {
$method=&$sub;
@methods=($method);
my $vis=method_owner($method);
foreach $obj (@args[1..$#args]) {
if (my $method_next=$vis->can("draw", is_object($obj) ? $obj : $obj->[0], undef)) {
push @methods, $method_next;
} else {
@methods=();
next TRY;
}
}
last;
}
}
if (@methods) {
my $vis=start_deferred_visualizer(method_owner($methods[0]),$title);
foreach $obj (@args) {
$method=shift @methods;
foreach my $elem (is_object($obj) ? ($obj) : @$obj) {
$method->($vis, $elem, undef);
}
}
} else {
croak( "do not know how to visualize (",
join(", ", map { ref($_) eq "ARRAY" ? "ARRAY<".ref($_->[0]).">" : ref($_) || $_ } @args), ") together" );
}
}
}
############################################################################
# the common part of explicit visualization functions
# Visual::Object, { options }, "Package" =>
sub visualize_explicit {
my ($opts, $Package)=splice @_, -2;
my $to_file=$opts->{File};
my $viewer;
if (defined($to_file)) {
my $file_package="$Package\::File::Writer";
if ($to_file eq "AUTO") {
$viewer=Visual::FileWriter::Auto->new($file_package);
} else {
if (@_>1 && ! $file_package->multiple) {
my $caller_sub=(caller(1))[3];
$caller_sub=~s/.*::([^:]+)$/$1/;
$caller_sub=~s/^__(\w+)__OV__.*/$1/;
die << ".";
The file format for $Package does not support multiple independent scenes.
If you really want to create several pictures, you should either specify
File => "AUTO", or call $caller_sub with each object (and different file names)
separately.
If you intended to put the objects together in one drawing instead,
bundle them with compose() like this: $caller_sub(compose(VISUAL1, VISUAL2, ...))
.
}
if ($to_file !~ /^[-&|]/ && $to_file !~ /\.\w+$/) {
$to_file.=$file_package->suffix;
}
$viewer=$file_package->new($to_file);
}
} else {
$viewer="$Package\::Viewer"->new;
}
visualize_with($viewer, @_)->proceed;
() # empty return value
}
package Visual;
############################################################################
# useful regex for parsing the styles
# $1=!fill $2=NAME $3="R G B" $4=R $5=G $6=B
my $color_re=qr{(?: \b(?: solid | (border) )\s+)? (?: \b([a-zA-Z]\w+) | ((\d+) \s+ (\d+) \s+ (\d+)) )}x;
my %RGBtxt;
sub loadRGBtxt {
die "color list rgb.txt not found, can't use symbolic color names\n"
unless $Visual::Color::RGBtxt_path;
open my $RGB, $Visual::Color::RGBtxt_path
or die "can't parse color list $Visual::Color::RGBtxt_path: $!\n";
local $/="\n";
local ($_, $1, $2);
while (<$RGB>) {
next if /^\s* (?: ! | $ )/x;
if (/^ \s* (\d+) \s+ (\d+) \s+ (\d+) \s+ ([a-zA-Z]\w+ (?:\s+ [a-zA-Z]\w+)*) \s* $/x) {
$RGBtxt{$4}=[ "$1 $2 $3", $1, $2, $3 ];
}
}
}
# => (!fill, "R G B", R, G, B)
sub parse_color {
my $color=shift;
if ($color =~ $color_re) {
if ($2) {
loadRGBtxt unless keys %RGBtxt;
my $list=$RGBtxt{$2};
$list ? ($1, @$list) : ();
} else {
($1, $3, $4, $5, $6)
}
} else {
()
}
}
# $1=linewidth
declare $thickness_re=qr{\bthickness \s+ ([.\d]+)}x;
declare $transparency_re=qr{\btransparency \s+ ([.\d]+)}x;
declare $hidden_re=qr{\bhidden\b};
sub hsv2rgb {
my ($h, $s, $v) = @_;
my ($i, $f, $p, $q, $t,$r,$g,$b);
if ($s == 0) {
$r = $b = $g = $v;
} else {
$h /= 60;
$i = int $h;
$f = $h - $i;
$p = $v * (1 - $s);
$q = $v * (1 - $s * $f);
$t = $v * (1 - $s * (1 - $f));
SWITCH: {
if ($i == 0) {
$r = $v;
$g = $t;
$b = $p;
last SWITCH;
}
if ($i == 1) {
$r = $q;
$g = $v;
$b = $p;
last SWITCH;
}
if ($i == 2) {
$r = $p;
$g = $v;
$b = $t;
last SWITCH;
}
if ($i == 3) {
$r = $p;
$g = $q;
$b = $v;
last SWITCH;
}
if ($i == 4) {
$r = $t;
$g = $p;
$b = $v;
last SWITCH;
}
$r = $v;
$g = $p;
$b = $q;
}
}
return ($r, $g, $b);
}
###############################################################################
#
# Basic visual object
#
package Visual::Object;
use Struct (
[ new => '%' ],
'$Name',
[ '$Title' => 'undef' ],
[ '@attached' => '##' ],
);
sub check_points {
my ($name, $pts)=@_;
if (is_object($pts) && $pts->isa("Visual::Embedding")
|| is_array($pts)) {
$pts;
} else {
croak( "$name neither an array nor a Visual::Embedding" );
}
}
sub unify_labels {
my ($name, $labels)=@_;
if (defined $labels) {
if (is_code($labels)) {
$labels
} elsif (is_array($labels)) {
sub { $labels->[shift] }
} elsif ($labels eq "hidden") {
undef
} else {
$labels=split_labels($labels);
sub { $labels->[shift] }
}
} else {
sub { shift }
}
}
sub unify_decor {
my ($name, $decor)=@_;
is_code($decor)
? $decor :
is_array($decor)
? sub { $decor->[$_[0]] } :
is_hash($decor)
? sub { $decor->{$_[0]} }
: $decor
}
sub merge_decor : method {
my ($self, $attr, $new_decor)=@_;
my $base_decor=$self->$attr;
$new_decor=unify_decor($attr, $new_decor);
if (ref($new_decor)) {
if (ref($base_decor)) {
$self->$attr = sub { $new_decor->($_[0]) || $base_decor->($_[0]) };
} elsif ($base_decor) {
$self->$attr = sub { $new_decor->($_[0]) || $base_decor };
} else {
$self->$attr = $new_decor;
}
} elsif (ref($base_decor)) {
$self->$attr = sub { $base_decor->($_[0]) || $new_decor };
} else {
$self->$attr = $new_decor;
}
}
sub clone {
my $src=shift;
my $self=bless [ @$src ], ref($src);
while (my ($key, $value)=splice @_, 0, 2) {
$self->$key=$value;
}
$self;
}
###############################################################################
#
# Container for several visualization objects - to be derived from
#
package Visual::Container;
use Struct (
[ new => '%@' ],
[ '@ISA' => 'Visual::Object' ],
[ '@elements' => '@' ],
'%defaults',
);
sub propagate_defaults {
my $self=shift;
while (my ($name, $val)=each %{$self->defaults}) {
my $applied;
foreach my $c (@{$self->elements}) {
my $obj=is_object($c) ? $c : $c->[0];
if (my $access_method=UNIVERSAL::can($obj,$name)) {
my $filter=Struct::get_field_filter($access_method);
foreach my $vis ($c==$obj ? ($obj) : @$c) {
if (Struct::is_default($access_method->($vis))) {
if ($filter) {
$val=$filter->($name,$val);
undef $filter;
}
$access_method->($vis)=$val;
}
}
$applied=1;
} elsif (instanceof Container($obj)) {
foreach my $vis ($c==$obj ? ($obj) : @$c) {
$vis->defaults->{$name} ||= $val;
}
}
}
croak( "default attribute $name is not applicable to any element of the ", ref($self) ) unless $applied;
}
}
###############################################################################
package Visual::Embedding;
sub new {
my $class=shift;
bless [ @_ ], $class;
}
use overload 'bool' => sub { 1 },
'==' => \&refcmp,
'!=' => sub { !&refcmp },
'@{}' => "compute";
sub push {
my $self=shift;
defuse_magic($self);
push @$self, @_;
}
sub splice {
my ($self, $at)=splice @_, 0, 2;
defuse_magic($self);
splice @$self, $at, 0, @_;
}
###########################################################################################
#
# Direct writing to a file without starting a GUI
#
package Visual::FileWriter;
sub import {
(undef, my %params)=@_;
my $pkg=caller;
my ($top_pkg)= $pkg =~ /^([^:]+)/;
my $suffix=$params{suffix} or croak( "default file suffix not specified" );
my $multiple=$params{multiple};
my $symtab=get_pkg($pkg);
define_function($symtab, "graphics", \&self);
define_function($symtab, "proceed", \&proceed);
define_function($symtab, "suffix", sub { $suffix });
define_function($symtab, "multiple", sub { $multiple });
no strict 'refs';
@{"$pkg\::ISA"}=( "$top_pkg\::File", "$top_pkg\::Viewer" );
}
sub self : method { shift }
sub proceed : method { shift->print_it; }
###########################################################################################
#
# Generator of file names
#
package Visual::FileWriter::Auto;
use Struct (
[ new => '$' ],
[ '$Package' => '#1' ],
[ '$viewer' => 'undef' ],
);
sub new_drawing {
my ($self, $title)=@_;
if ($self->viewer) {
# write previous file
$self->viewer->proceed;
}
# eliminate dangerous characters in the file name
(my $filename=$title) =~ s|[ /.]|_|g;
$filename .= $self->Package->suffix;
print STDERR "writing to file $filename\n" if $Switches::v;
($self->viewer=$self->Package->new($filename))->new_drawing($title);
}
1
# Local Variables:
# c-basic-offset:3
# End:
syntax highlighted by Code2HTML, v. 0.9.1