view release on metacpan or  search on metacpan

lib/App/Guiio/stripes/section_wirl_arrow.pm  view on Meta::CPAN

#-----------------------------------------------------------------------------

# the idea is to reuse wirl arrow implementation as much as possible

#-----------------------------------------------------------------------------

Readonly my $DEFAULT_ARROW_TYPE =>
			[
			['origin', '', '*', '', '', '', 1],
			['up', '|', '|', '', '', '^', 1],
			['down', '|', '|', '', '', 'v', 1],
			['left', '-', '-', '', '', '<', 1],
			['upleft', '|', '|', '.', '-', '<', 1],
			['leftup', '-', '-', '\'', '|', '^', 1],
			['downleft', '|', '|', '\'', '-', '<', 1],
			['leftdown', '-', '-', '.', '|', 'v', 1],
			['right', '-', '-','', '', '>', 1],
			['upright', '|', '|', '.', '-', '>', 1],
			['rightup', '-', '-', '\'', '|', '^', 1],
			['downright', '|', '|', '\'', '-', '>', 1],
			['rightdown', '-', '-', '.', '|', 'v', 1],
			['45', '/', '/', '', '', '^', 1, ],
			['135', '\\', '\\', '', '', 'v', 1, ],
			['225', '/', '/', '', '', 'v', 1, ],
			['315', '\\', '\\', '', '', '^', 1, ],
			] ;

# constants for connector overlays
Readonly my $body_index => 2 ;
Readonly my $connection_index => 3 ;

Readonly my $up_index=> 1 ;
Readonly my $left_index=> 3 ;
Readonly my $leftup_index => 5 ;
Readonly my $leftdown_index => 7 ;

sub new
{
my ($class, $element_definition) = @_ ;

my $self = bless  {}, __PACKAGE__ ;
	
$self->setup
	(
	$element_definition->{ARROW_TYPE} || Clone::clone($DEFAULT_ARROW_TYPE),
	$element_definition->{POINTS},
	$element_definition->{DIRECTION},
	$element_definition->{ALLOW_DIAGONAL_LINES},
	$element_definition->{EDITABLE},
	$element_definition->{NOT_CONNECTABLE_START},
	$element_definition->{NOT_CONNECTABLE_END},
	) ;

return $self ;
}

#-----------------------------------------------------------------------------

sub setup
{
my ($self, $arrow_type, $points, $direction, $allow_diagonal_lines, $editable, $not_connectable_start, $not_connectable_end) = @_ ;

if('ARRAY' eq ref $points && @{$points} > 0)
	{
	my ($start_x, $start_y, $arrows) = (0, 0, []) ;
	
	my $points_offsets ;
	my $arrow_index = 0 ; # must have a numeric index or 'undo' won't work
	
	for my $point (@{$points})
		{
		my ($x, $y, $point_direction) = @{$point} ;
		
		my $arrow = new App::Guiio::stripes::wirl_arrow
					({
					ARROW_TYPE => $arrow_type,
					END_X => $x - $start_x,
					END_Y => $y - $start_y,
					DIRECTION => $point_direction || $direction,
					ALLOW_DIAGONAL_LINES => $allow_diagonal_lines,
					EDITABLE => $editable,
					}) ;
						
		$points_offsets->[$arrow_index++] = [$start_x, $start_y] ;
		
		push @{$arrows},  $arrow ;
		($start_x, $start_y) = ($x, $y) ;
		}
		
	$self->set
		(
		POINTS_OFFSETS => $points_offsets,
		ARROWS => $arrows,
		
		# keep data to allow section insertion later
		ARROW_TYPE => $arrow_type,
		DIRECTION => $direction,
		ALLOW_DIAGONAL_LINES => $allow_diagonal_lines,
		EDITABLE => $editable,
		NOT_CONNECTABLE_START => $not_connectable_start,
		NOT_CONNECTABLE_END => $not_connectable_end,
		) ;
		
	my ($width, $height) = $self->get_width_and_height() ;
	$self->set
			(
			WIDTH => $width,
			HEIGHT => $height,
			) ;
	}
else
	{
	die "Bad 'section wirl arrow' defintion! Expecting points array." ;
	}
}

#-----------------------------------------------------------------------------

my %diagonal_direction_to_overlay_character =
	(
	(map {$_ => q{\\}} qw( down-right right-down up-left left-up)), 
	(map {$_ => q{/}} qw( down-left left-down up-right right-up)), 
	) ;

my %diagonal_non_diagonal_to_overlay_character =
	(
	(map {$_ => q{.}} qw( down-right right-down up-left left-up)), 
	(map {$_ => q{'}} qw( down-left left-down up-right right-up)), 
	) ;
	
sub get_mask_and_element_stripes
{
my ($self) = @_ ;

my @mask_and_element_stripes ;

my $arrow_index = 0 ;
for my $arrow(@{$self->{ARROWS}})
	{
	push @mask_and_element_stripes, 
		map 
		{
		$_->{X_OFFSET} += $self->{POINTS_OFFSETS}[$arrow_index][0] ;
		$_->{Y_OFFSET} += $self->{POINTS_OFFSETS}[$arrow_index][1];
		$_ ;
		} $arrow->get_mask_and_element_stripes() ;
		
	$arrow_index++ ;
	}

# handle connections
my ($previous_direction) = ($self->{ARROWS}[0]{DIRECTION} =~ /^([^-]+)-/) ;
$previous_direction ||= $self->{ARROWS}[0]{DIRECTION} ;
my $previous_was_diagonal ;

$arrow_index = 0 ;
for my $arrow(@{$self->{ARROWS}})
	{
	# the whole computation can be skipped if a single section is present
	
	my ($connection, $d1, $d2) ;