view release on metacpan or  search on metacpan

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

  }

  return wantarray ? @result : \@result;
}

# synthesize a key glyph
sub keyglyph {
  my $self = shift;
  my $scale = 1/$self->scale;  # base pairs/pixel
  # two segments, at pixels 0->50, 60->80
  my $offset = $self->offset;
  my $feature = Ace::Graphics::Fk->new(-segments=>[ [ 0*$scale +$offset,50*$scale+$offset],
						    [60*$scale+$offset, 80*$scale+$offset]
						    ],
				       -name => $self->option('key'),
				       -strand => '+1');
  my $factory = $self->factory->clone;
  $factory->scale($self->scale);
  $factory->width($self->width);
  $factory->option(label=>1);  # turn on labels
  return $factory->glyph($feature);
}

# draw glyphs onto a GD object at the indicated position
sub draw {
  my $self = shift;
  my ($gd,$left,$top) = @_;
  $top  += 0;  $left += 0;
  my $glyphs = $self->layout;

  # draw background
  my $bgcolor = $self->factory->bgcolor;
  # $gd->filledRectangle($left,$top,$left+$self->width,$top+$self->height,$bgcolor);

  if (my $label = $self->factory->option('track_label')) {
    my $font = $self->factory->font;
    my $y = $top + ($self->height-$font->height)/2;
    my $x = $left - length($label) * $font->width;
    $gd->string($font,$x,$y,$label,$self->factory->fontcolor);
  }
  $_->draw($gd,$left,$top) foreach @$glyphs;

  if ($self->factory->option('connectgroups')) {
    $_->draw($gd,$left,$top) foreach @{$self->{groups}};
  }
}

# lay out -- this uses the infamous bump algorithm
sub layout {
  my $self = shift;
  my $force = shift || 0;
  return $self->{glyphs} if $self->{glyphs} && !$force;

  my $f = $self->{features};
  my $factory = $self->factory;
  $factory->scale($self->scale);  # set the horizontal scale
  $factory->width($self->width);

  # create singleton glyphs
  my @singletons = map { $factory->glyph($_) } @$f;

  # create linked groups of glyphs
  my @groups;
  if (my $groups = $self->{group_ids}) {
    my $groupfactory = Ace::Graphics::GlyphFactory->new('group');
    for my $g (values %$groups) {
      my @g = map { $factory->glyph($_) } @$g;
      push @groups,$groupfactory->glyph(\@g);
    }
  }

  return $self->{glyphs} = [] unless @singletons || @groups;

  # run the bumper on the groups
  $self->_bump([@singletons,@groups]) if $self->bump;

  # merge the singletons and groups and sort them horizontally
  my @glyphs = sort {$a->left <=> $b->left } @singletons,map {$_->members} @groups;

  # If -1 bumping was allowed, then normalize so that the top glyph is at zero
  my ($topmost) = sort {$a->top <=> $b->top} @glyphs;
  my $offset = 0 - $topmost->top;
  $_->move(0,$offset) foreach @glyphs;

  $self->{groups}        = \@groups;
  return $self->{glyphs} = \@glyphs;
}

# bumper - glyphs already sorted left to right
sub _bump {
  my $self   = shift;
  my $glyphs = shift;
  my $bump_direction = $self->bump;  # +1 means bump down, -1 means bump up

  my @occupied;
  my $rightmost = -2;
  for my $g (sort { $a->left <=> $b->left} @$glyphs) {

    my $pos = 0;
    while (1) {
      # look for collisions
      last if $g->left > $rightmost + 2;
      my $bottom = $pos + $g->height;

      my $collision = 0;
      for my $old (@occupied) {
	last if $old->right + 2 < $g->left;
	next if $old->bottom < $pos;
	next if $old->top > $bottom;
	$collision = $old;
	last;
      }
      last unless $collision;
      if ($bump_direction > 0) {
	$pos += $collision->height + 2;                    # collision, so bump
      } else {
	$pos -= $g->height + 2;
      }
    }

    $g->move(0,$pos);
    @occupied = sort { $b->right <=> $a->right } ($g,@occupied);
    $rightmost = $g->right if $g->right > $rightmost;
  }
}

# return list of glyphs -- only after they are laid out
sub glyphs { shift->{glyphs} }

# height is determined by the layout, and cannot be externally controlled
sub height {
  my $self = shift;
  return $self->{cache_height} if defined $self->{cache_height};

  $self->layout;
  my $glyphs = $self->{glyphs} or croak "Can't lay out";
  return 0 unless @$glyphs;