view release on metacpan or  search on metacpan

lib/App/Asciio/stripes/angled_arrow.pm  view on Meta::CPAN

package App::Asciio::stripes::angled_arrow ;

use base App::Asciio::stripes::stripes ;

use strict;
use warnings;

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

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

Readonly my $DEFAULT_GLYPHS=> 
	#name: => [$start, $body, $connection, $body_2, $end, $vertical, $diagonal_connection]
	{
	'origin' => [ '*', '?', '?', '?', '?', '?', '?'],
	'up'=> [ "'", '|', '?', '?', '.', '?', '?'],
	'down' => [ '.', '|', '?', '?', "'", '?', '?'],
	'left' => [ '-', '-', '?', '?', '-', '?', '?'],
	'right' => [ '-', '-', '?', '?', '-', '?', '?'],
	'upleft' => [ "'", '\\', '.', '-', '-', '|', "'"],
	'leftup' => [ '-', '\\', "'", '-', '.', '|', "'"],
	'downleft' => [ '.', '/', "'", '-', '-', '|', "'"],
	'leftdown' => [ '-', '/', '.', '-', "'", '|', "'"],
	'upright' => [ "'", '/', '.', '-', '-', '|', "'"],
	'rightup' => [ '-', '/', "'", '-', '.', '|', "'"],
	'downright' => [ '.', '\\', "'", '-', '-', '|', "'"],
	'rightdown' => [ '-', '\\', '.', '-', "'", '|', "'"],
	} ;

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

my $self = bless  {}, __PACKAGE__ ;
	
$self->setup
	(
	$element_definition->{GLYPHS} || $DEFAULT_GLYPHS,
	$element_definition->{END_X}, $element_definition->{END_Y},
	$element_definition->{DIRECTION},
	$element_definition->{EDITABLE},
	) ;

return $self ;
}

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

sub setup
{
my ($self, $glyphs, $end_x, $end_y, $direction, $editable) = @_ ;

(my ($stripes, $width, $height), $direction) = get_arrow($glyphs, $end_x, $end_y, $direction) ;

$self->set
	(
	GLYPHS => $glyphs,
	STRIPES => $stripes,
	WIDTH => $width,
	HEIGHT => $height,
	DIRECTION => $direction,
	END_X => $end_x,
	END_Y => $end_y,
	) ;
}

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

my %direction_to_arrow = 
	(
	'origin' => \&draw_origin,
	'up' => \&draw_up,
	'down' => \&draw_down,
	'left' => \&draw_left,
	'up-left' => \&draw_upleft,
	'left-up' => \&draw_leftup,
	'down-left' => \&draw_downleft,
	'left-down' => \&draw_leftdown, 
	'right' => \&draw_right,
	'up-right' => \&draw_upright,
	'right-up' => \&draw_rightup,
	'down-right' => \&draw_downright,
	'right-down' => \&draw_rightdown,
	) ;   

sub get_arrow
{
my ($glyphs, $end_x, $end_y, $direction) = @_ ;

use constant CENTER => 1 ;
use constant LEFT => 0 ;
use constant RIGHT => 2 ;
use constant UP => 0 ;
use constant DOWN => 2 ;

my @position_to_direction =
	(
	[$direction =~ /^up/ ? 'up-left' : 'left-up', 'left',  $direction =~ /^down/ ? 'down-left' : 'left-down'] ,
	['up', 'origin', 'down'],
	[$direction =~ /^up/ ? 'up-right' : 'right-up', 'right', $direction =~ /^down/ ? 'down-right' : 'right-down'],
	) ;

$direction = $position_to_direction
			[$end_x == 0 ? CENTER : $end_x < 0 ? LEFT : RIGHT]
			[$end_y == 0 ? CENTER : $end_y < 0 ? UP : DOWN] ;

my $drawing_sub = $direction_to_arrow{$direction} ;

return($drawing_sub->($glyphs, $end_x, $end_y), $direction) ;
}