view release on metacpan or  search on metacpan

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

package App::Guiio::stripes::section_wirl_arrow ;
use base App::Guiio::stripes::stripes ;

use strict;
use warnings;

use List::Util qw(min max) ;
use Readonly ;
use Clone ;

use App::Guiio::stripes::wirl_arrow ;

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

# 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) ;
		
	unless(($d1, $d2) = ($arrow->{DIRECTION} =~ /^([^-]+)-(.*)$/)) 
		{
		$d1 = $arrow->{DIRECTION};
		}

	if($self->{ALLOW_DIAGONAL_LINES} && $arrow->{WIDTH} == $arrow->{HEIGHT})
		{
		# this arrow is diagonal
		if
			(
			$previous_was_diagonal
			&& ($previous_was_diagonal eq $arrow->{DIRECTION} || $previous_was_diagonal eq "$d2-$d1")
			)
			{
			# two diagonals going in the same direction
			$connection = $diagonal_direction_to_overlay_character{$arrow->{DIRECTION}} ;
			}
		else
			{
			# previous non diagonal or two diagonals not going in the same direction
			$connection  = ($d1 eq 'up' || $d2 eq 'up') ?  q{'} : q{.} ;
			}
				
		$previous_was_diagonal = $arrow->{DIRECTION} ;
		}
	else
		{
		# straight or angled arrow
		if(defined $previous_was_diagonal)
			{
			$connection = $previous_was_diagonal =~ /down/ ? q{'} : q{.} ;
			}
		else
			{
			if($previous_direction ne $d1)
				{
				$connection = $self->{ARROW_TYPE}[$left_index][$body_index] ;  # for left and right, up down cases handled below
				
				if($d1 eq 'down')
					{
					$connection = $self->{ARROW_TYPE}[$leftdown_index][$connection_index] ;
					}
				elsif($d1 eq 'up')
					{
					$connection = $self->{ARROW_TYPE}[$leftup_index][$connection_index] ;
					}
				elsif($previous_direction eq 'down')
					{
					$connection = $self->{ARROW_TYPE}[$leftup_index][$connection_index] ;
					}
				elsif($previous_direction eq 'up')
					{
					$connection = $self->{ARROW_TYPE}[$leftdown_index][$connection_index] ;
					}
				}
			}
			
		$previous_direction = defined $d2 ? $d2 : $d1 ;
		$previous_was_diagonal = undef ;
		}
		
	if($arrow_index != 0 && defined $connection) # first character of the first section is always right
		{
		# overlay the first character of this arrow
		push @mask_and_element_stripes, 
			{
			X_OFFSET => $self->{POINTS_OFFSETS}[$arrow_index][0],
			Y_OFFSET => $self->{POINTS_OFFSETS}[$arrow_index][1],
			WIDTH => 1,
			HEIGHT => 1,
			TEXT => $connection,
			} ;
		}
		
	$arrow_index++ ;
	}

return(@mask_and_element_stripes) ;
}

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

sub get_selection_action
{
my ($self, $x, $y) = @_ ;

my $action = 'move' ;

my $arrow_index = 0 ;
for my $arrow(@{$self->{ARROWS}})
	{
	my ($start_connector, $end_connector) = $arrow->get_connector_points() ;
	
	$start_connector->{X} += $self->{POINTS_OFFSETS}[$arrow_index][0] ;
	$start_connector->{Y} += $self->{POINTS_OFFSETS}[$arrow_index][1] ;
		
	if($x == $start_connector->{X} && $y == $start_connector->{Y})
		{
		$action = 'resize' ;
		last ;
		}
		
	$end_connector->{X} += $self->{POINTS_OFFSETS}[$arrow_index][0] ;
	$end_connector->{Y} += $self->{POINTS_OFFSETS}[$arrow_index][1] ;
	
	if($x == $end_connector->{X} && $y == $end_connector->{Y})
		{
		$action = 'resize' ;
		last ;
		}
		
	$arrow_index++ ;
	}

return $action ;
}

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

sub is_autoconnect_enabled
{
my ($self) = @_ ;

return ! $self->{AUTOCONNECT_DISABLED} ;