view release on metacpan or  search on metacpan

Ace/Graphics/Panel.pm  view on Meta::CPAN

package Ace::Graphics::Panel;
# This embodies the logic for drawing multiple tracks.

use Ace::Graphics::Track;
use GD;
use Carp 'croak';
use strict;
use constant KEYLABELFONT => gdSmallFont;
use constant KEYSPACING   => 10; # extra space between key columns
use constant KEYPADTOP    => 5;  # extra padding before the key starts
use constant KEYCOLOR     => 'cornsilk';

*push_track = \&add_track;

# package global
my %COLORS;

# Create a new panel of a given width and height, and add lists of features
# one by one
sub new {
  my $class = shift;
  my %options = @_;

  $class->read_colors() unless %COLORS;

  my $length = $options{-length} || 0;
  my $offset = $options{-offset} || 0;
  my $spacing = $options{-spacing} || 5;
  my $keycolor = $options{-keycolor} || KEYCOLOR;
  my $keyspacing = $options{-keyspacing} || KEYSPACING;

  $length   ||= $options{-segment}->length  if $options{-segment};
  $offset   ||= $options{-segment}->start-1 if $options{-segment};

  return bless {
		tracks => [],
		width  => $options{-width} || 600,
		pad_top    => $options{-pad_top}||0,
		pad_bottom => $options{-pad_bottom}||0,
		pad_left   => $options{-pad_left}||0,
		pad_right  => $options{-pad_right}||0,
		length => $length,
		offset => $offset,
		height => 0, # AUTO
		spacing => $spacing,
		keycolor => $keycolor,
		keyspacing => $keyspacing,
	       },$class;
}

sub width {
  my $self = shift;
  my $d = $self->{width};
  $self->{width} = shift if @_;
  $d + $self->pad_left + $self->pad_right;
}

sub spacing {
  my $self = shift;
  my $d = $self->{spacing};
  $self->{spacing} = shift if @_;
  $d;
}

sub length {
  my $self = shift;
  my $d = $self->{length};
  if (@_) {
    my $l = shift;
    $l = $l->length if ref($l) && $l->can('length');
    $self->{length} = $l;
  }
  $d;
}

sub pad_top {
  my $self = shift;
  my $d = $self->{pad_top};
  $self->{pad_top} = shift if @_;
  $d || 0;
}

sub pad_bottom {
  my $self = shift;
  my $d = $self->{pad_bottom};
  $self->{pad_bottom} = shift if @_;
  $d || 0;
}

sub pad_left {
  my $self = shift;
  my $d = $self->{pad_left};
  $self->{pad_left} = shift if @_;
  $d || 0;
}

sub pad_right {
  my $self = shift;
  my $d = $self->{pad_right};
  $self->{pad_right} = shift if @_;
  $d || 0;
}

sub add_track {
  my $self = shift;

  # due to indecision, we accept features
  # and/or glyph types in the first two arguments
  my ($features,$glyph_name) = ([],'generic');
  while ( $_[0] !~ /^-/) {
    my $arg = shift;
    $features   = $arg and next if ref($arg);
    $glyph_name = $arg and next unless ref($arg);
  }

  $self->_add_track($glyph_name,$features,+1,@_);
}

sub unshift_track {
  my $self = shift;
  # due to indecision, we accept features
  # and/or glyph types in the first two arguments
  my ($features,$glyph_name) = ([],'generic');
  while ( (my $arg = shift) !~ /^-/) {
    $features   = $arg and next if ref($arg);
    $glyph_name = $arg and next unless ref($arg);
  }

  $self->_add_track($glyph_name,$features,-1,@_);
}

sub _add_track {
  my $self = shift;
  my ($glyph_type,$features,$direction,@options) = @_;

  unshift @options,'-offset' => $self->{offset} if defined $self->{offset};
  unshift @options,'-length' => $self->{length} if defined $self->{length};

  $features = [$features] unless ref $features eq 'ARRAY';
  my $track  = Ace::Graphics::Track->new($glyph_type,$features,@options);
  $track->set_scale(abs($self->length),$self->{width});
  $track->panel($self);
  if ($direction >= 0) {
    push @{$self->{tracks}},$track;
  } else {
    unshift @{$self->{tracks}},$track;
  }

  return $track;
}

sub height {
  my $self = shift;
  my $spacing    = $self->spacing;
  my $key_height = $self->format_key;
  my $height = 0;
  $height += $_->height + $spacing foreach @{$self->{tracks}};
  $height + $key_height + $self->pad_top + $self->pad_bottom;
}

sub gd {
  my $self = shift;

  return $self->{gd} if $self->{gd};

  my $width  = $self->width;
  my $height = $self->height;
  my $gd = GD::Image->new($width,$height);
  my %translation_table;
  for my $name ('white','black',keys %COLORS) {
    my $idx = $gd->colorAllocate(@{$COLORS{$name}});
    $translation_table{$name} = $idx;
  }

  $self->{translations} = \%translation_table;
  $self->{gd}                = $gd;
  my $offset = 0;
  my $pl = $self->pad_left;
  my $pt = $self->pad_top;

  for my $track (@{$self->{tracks}}) {
    $track->draw($gd,$pl,$offset+$pt);
    $offset += $track->height + $self->spacing;
  }

  $self->draw_key($gd,$pl,$offset);
  return $self->{gd} = $gd;
}

sub draw_key {
  my $self = shift;
  my ($gd,$left,$top) = @_;
  my $key_glyphs = $self->{key_glyphs} or return;

  my $color = $self->translate($self->{keycolor});
  $gd->filledRectangle($left,$top,$self->width,$self->height,$color);
  $gd->string(KEYLABELFONT,$left,KEYPADTOP+$top,"KEY:",1);
  $top += KEYLABELFONT->height + KEYPADTOP;

  $_->draw($gd,$left,$top) foreach @$key_glyphs;
}

# Format the key section, and return its height
sub format_key {
  my $self = shift;

  return $self->{key_height} if defined $self->{key_height};

  my ($height,$width) = (0,0);
  my %tracks;
  my @glyphs;

  # determine how many glyphs become part of the key
  # and their max size
  for my $track (@{$self->{tracks}}) {
    next unless $track->option('key');
    my $glyph = $track->keyglyph;
    $tracks{$track} = $glyph;
    my ($h,$w) = ($glyph->height,
		  $glyph->right-$glyph->left);
    $height = $h if $h > $height;
    $width  = $w if $w > $width;
    push @glyphs,$glyph;
  }

  $width += $self->{keyspacing};

  # no key glyphs, no key
  return $self->{key_height} = 0 unless @glyphs;

  # now height and width hold the largest glyph, and $glyph_count
  # contains the number of glyphs.  We will format them into a
  # box that is roughly 3 height/4 width (golden mean)
  my $rows = 0;
  my $cols = 0;
  while (++$rows) {
    $cols = @glyphs / $rows;
    $cols = int ($cols+1) if $cols =~ /\./;  # round upward for fractions
    my $total_width  = $cols * $width;
    my $total_height = $rows * $width;
    last if $total_width <= $self->width;
  }

  # move glyphs into row-major format
  my $spacing = $self->spacing;
  my $i = 0;
  for (my $c = 0; $c < $cols; $c++) {
    for (my $r = 0; $r < $rows; $r++) {
      my $x = $c * ($width  + $spacing);
      my $y = $r * ($height + $spacing);
      next unless defined $glyphs[$i];
      $glyphs[$i]->move($x,$y);
      $i++;
    }
  }

  $self->{key_glyphs} = \@glyphs;     # remember our key glyphs
  # remember our key height
  return $self->{key_height} = ($height+$spacing) * $rows + KEYLABELFONT->height +KEYPADTOP;
}

# reverse of translate(); given index, return rgb triplet
sub rgb {
  my $self = shift;
  my $idx  = shift;
  my $gd = $self->{gd} or return;
  return $gd->rgb($idx);
}

sub translate {
  my $self = shift;

  if (@_ == 3) { # rgb triplet
    my $gd = $self->gd or return 1;
    return $gd->colorClosest(@_);
  }

  # otherwise...
  my $color = shift;
  if ($color =~ /^\#([0-9A-F]{2})([0-9A-F]{2})([0-9A-F]{2})$/i) {
    my $gd = $self->gd or return 1;
    my ($r,$g,$b) = (hex($1),hex($2),hex($3));
    return $gd->colorClosest($r,$g,$b);
  } else {
    my $table = $self->{translations} or return $self->fgcolor;
    return $table->{$color} || 1;
  }
}

sub set_pen {
  my $self = shift;
  my ($linewidth,$color) = @_;
  return $self->{pens}{$linewidth} if $self->{pens}{$linewidth};

  my $pen = $self->{pens}{$linewidth} = GD::Image->new($linewidth,$linewidth);
  my @rgb = $self->rgb($color);
  my $bg = $pen->colorAllocate(255,255,255);
  my $fg = $pen->colorAllocate(@rgb);
  $pen->fill(0,0,$fg);
  $self->{gd}->setBrush($pen);
}

sub png {
  my $gd = shift->gd;
  $gd->png;
}

sub boxes {
  my $self = shift;
  my @boxes;
  my $offset = 0;
  my $pl = $self->pad_left;
  my $pt = $self->pad_top;
  for my $track (@{$self->{tracks}}) {
    my $boxes = $track->boxes($pl,$offset+$pt);
    push @boxes,@$boxes;
    $offset += $track->height + $self->spacing;
  }
  return wantarray ? @boxes : \@boxes;
}

sub read_colors {
  my $class = shift;
  while (<DATA>) {
    chomp;
    last if /^__END__/;
    my ($name,$r,$g,$b) = split /\s+/;
    $COLORS{$name} = [hex $r,hex $g,hex $b];
  }
}

sub color_names {
    my $class = shift;
    $class->read_colors unless %COLORS;
    return wantarray ? keys %COLORS : [keys %COLORS];
}


1;

__DATA__
white                FF           FF            FF
black                00           00            00
aliceblue            F0           F8            FF
antiquewhite         FA           EB            D7
aqua                 00           FF            FF
aquamarine           7F           FF            D4
azure                F0           FF            FF
beige                F5           F5            DC
bisque               FF           E4            C4
blanchedalmond       FF           EB            CD
blue                 00           00            FF
blueviolet           8A           2B            E2
brown                A5           2A            2A
burlywood            DE           B8            87
cadetblue            5F           9E            A0
chartreuse           7F           FF            00
chocolate            D2           69            1E
coral                FF           7F            50
cornflowerblue       64           95            ED
cornsilk             FF           F8            DC
crimson              DC           14            3C
cyan                 00           FF            FF
darkblue             00           00            8B
darkcyan             00           8B            8B
darkgoldenrod        B8           86            0B
darkgray             A9           A9            A9
darkgreen            00           64            00
darkkhaki            BD           B7            6B
darkmagenta          8B           00            8B
darkolivegreen       55           6B            2F
darkorange           FF           8C            00
darkorchid           99           32            CC
darkred              8B           00            00
darksalmon           E9           96            7A
darkseagreen         8F           BC            8F
darkslateblue        48           3D            8B
darkslategray        2F           4F            4F
darkturquoise        00           CE            D1
darkviolet           94           00            D3
deeppink             FF           14            100
deepskyblue          00           BF            FF
dimgray              69           69            69
dodgerblue           1E           90            FF
firebrick            B2           22            22
floralwhite          FF           FA            F0
forestgreen          22           8B            22
fuchsia              FF           00            FF
gainsboro            DC           DC            DC
ghostwhite           F8           F8            FF
gold                 FF           D7            00
goldenrod            DA           A5            20