File Coverage

blib/lib/CXC/Astro/Regions/DS9.pm

Criterion	Covered	Total	%
statement	61	63	96.8
branch	5	6	83.3
condition	1	3	33.3
subroutine	18	19	94.7
pod	1	1	100.0
total	86	92	93.4

package CXC::Astro::Regions::DS9;

# ABSTRACT: DS9 Compatible Regions

use v5.20;
use warnings;
use experimental 'signatures', 'postderef', 'lexical_subs';

our $VERSION = '0.03';

package CXC::Astro::Regions::DS9::Role::Region {
    use Moo::Role;
}

use constant RegionRole => __PACKAGE__ . '::Role::Region';

use parent 'Exporter::Tiny';

use Import::Into;
use CXC::Astro::Regions::DS9::Types qw(
  Angle
  ArrayRef
  ConsumerOf
  CoordSys
  Enum
  Length
  LengthPair
  NonEmptyStr
  OneZero
  PointType
  PositiveInt
  RulerCoords
  Tuple
  Vertex
);

use CXC::Astro::Regions::DS9::Variant;
use List::Util ();

use namespace::clean;

my sub croak {
    require Carp;
    goto \&Carp::croak;
}

my sub pkgpath ( @paths ) {
    join q{::}, __PACKAGE__, map { ucfirst( $_ ) } @paths;
}

my sub args ( @args ) {
    return @args == 1 ? ( name => $args[0] ) : @args;
}

my sub format_text ( $type, $label, $values ) {
    return () unless $values->@*;
    return $type eq 'prop' && defined $label
      ? sprintf( '%s={%s}', $label, $values->@* )
      : sprintf( '{%s}', $values->@* );
}

my sub format_qstring ( $type, $label, $values ) {
    return () unless $values->@*;
    return $type eq 'prop' && defined $label
      ? sprintf( '%s="%s"', $label, $values->@* )
      : sprintf( '"%s"', $values->@* );
}

my sub format_tags ( $type, $label, $values ) {
    ( $values, my @rest ) = $values->@*;
    croak( 'too many values passed to tags' ) if @rest;
    return () unless $values->@*;
    return join q{ }, map { sprintf( '%s={%s}', $label, $_ ) } $values->@*;
}

my sub ANGLE            { { name => 'angle',  isa => Angle, args( @_ ) } }
my sub ANGLEPAIR        { { name => 'angles', isa => Tuple [ Angle, Angle ], args( @_ ) } }
my sub ARROW            { { name => 'arrow',  isa => OneZero, coerce => !!1, args( @_ ) } }
my sub ARROWS           { { name => 'arrows', isa => ArrayRef [ OneZero, 2 ], args( @_ ) } }
my sub BOOL             { { name => undef,    isa => OneZero,     coerce => !!1, args( @_ ) } }
my sub COORDS           { { name => 'coords', isa => CoordSys,    coerce => !!1, args( @_ ) } }
my sub FILL             { { name => 'fill',   isa => OneZero,     coerce => !!1, args( @_ ) } }
my sub FORMAT           { { name => 'format', isa => NonEmptyStr, args( @_ ) } }
my sub LENGTH           { { name => 'length', isa => Length,      args( @_ ) } }
my sub LENGTHPAIR       { { name => undef,    isa => LengthPair,  args( @_ ) } }
my sub LENGTHPAIR_ARRAY { { name => undef,    isa => ArrayRef [LengthPair], args( @_ ) } }
my sub LENGTH_ARRAY     { { name => undef,    isa => ArrayRef [Length],     args( @_ ) } }
my sub N                { { name => 'n',      isa => PositiveInt, args( @_ ) } }
my sub POINT { { name => 'symbol', isa => PointType, coerce => !!1, label => 'point', args( @_ ) } }
my sub POSINT  { { name => undef, isa => PositiveInt, args( @_ ) } }
my sub QSTRING { { name => undef, isa => NonEmptyStr, format => \&format_text, args( @_ ) } }
my sub RULERCOORDS {
    { name => 'coords', isa => RulerCoords, coerce => !!1, label => 'ruler', args( @_ ) };
}
my sub STRING { { name => undef, isa => NonEmptyStr, args( @_ ) } }
my sub TAGS {
    {
        name   => 'tags',
        isa    => ArrayRef [NonEmptyStr],
        format => \&format_tags,
        label  => 'tag',
        args( @_ ) };
}
my sub TEXT     { { name => 'text',     isa => NonEmptyStr, format => \&format_text, args( @_ ) } }
my sub VERTEX   { { name => undef,      isa => Vertex,      args( @_ ) } }
my sub VERTICES { { name => 'vertices', isa => ArrayRef [Vertex], args( @_ ) } }

my @CommonProps = (
    TEXT,
    ANGLE( 'textangle' ),
    STRING( 'color' ),
    { name => 'dashlist', isa => ArrayRef [PositiveInt] },
    POSINT( name => 'linewidth', label => 'width' ),
    QSTRING( 'font' ),
    BOOL( 'select' ),
    BOOL( 'highlite' ),
    BOOL( 'dash' ),
    BOOL( 'fixed' ),
    BOOL( 'edit' ),
    BOOL( 'move' ),
    BOOL( 'rotate' ),
    BOOL( 'delete' ),
    BOOL( name => 'include', default => !!1 ),
    { name => 'srctype', isa => Enum [ 'source', 'background' ], label => undef },
    TAGS,
);

use Package::Stash;
our @EXPORT_OK = ( 'mkregion' );

my $stash = Package::Stash->new( __PACKAGE__ );
my sub REGION ( $region, %spec ) {

    push( ( $spec{props} //= [] )->@*, @CommonProps );
    $spec{with} //= [RegionRole];
    my $package = pkgpath( $region );

    if ( exists $spec{name} && $spec{name} ne $region ) {
        my $parent = pkgpath( $spec{name} );
        Moo->import::into( $parent );
        $spec{extends} = [$parent];
    }

    my $variant = Variant( $region, %spec );
    Package::Stash->new( $variant )->add_symbol( q{@CARP_NOT}, [__PACKAGE__] );

    $stash->add_symbol( q{&} . $region, sub { $package->new( @_ ) } );
    push @EXPORT_OK, $region;
}



















# Annulus
# Usage: annulus x y inner outer n=#
REGION annulus_n => (
    name   => 'annulus',
    params => [ VERTEX( 'center' ), LENGTHPAIR( 'annuli' ), N( label => 'n' ) ],
);

# Annulus
# Usage: annulus x y r1 r2 r3...
REGION annulus_annuli => (
    name   => 'annulus',
    params => [ VERTEX( 'center' ), LENGTH_ARRAY( 'annuli' ) ],
);





























# Box
# Usage: box x y width height angle # fill=[0|1]
REGION box_plain => (
    name   => 'box',
    params => [ VERTEX( 'center' ), LENGTH( 'width' ), LENGTH( 'height' ), ANGLE( required => !!0 ) ],
    props  => [FILL],
);

# Box Annulus
# Usage: box x y w1 h1 w2 h2 n=# [angle]
REGION box_n => (
    name   => 'box',
    params => [
        VERTEX( 'center' ),
        LENGTHPAIR( 'inner' ),
        LENGTHPAIR( 'outer' ),
        N( label => 'n' ),
        ANGLE( required => !!0 ),
    ],
);

# Box Annulus
# Usage: box x y w1 h1 w2 h2 w3 h3 ... [angle]
REGION box_annuli => (
    name   => 'box',
    params => [ VERTEX( 'center' ), LENGTHPAIR_ARRAY( 'annuli' ), ANGLE( required => !!0 ), ],
);













# Bpanda
# Usage: bpanda x y startangle stopangle nangle inner outer nradius [angle]
REGION bpanda => (
    params => [
        VERTEX( 'center' ),
        ANGLEPAIR,
        N( 'nangles' ),
        LENGTHPAIR( 'inner' ),
        LENGTHPAIR( 'outer' ),
        N( 'nannuli' ),
        ANGLE( required => !!0 ),
    ],
);









# Circle
# Usage: circle x y radius # fill=[0|1]
REGION circle => (
    params => [ VERTEX( 'center' ), LENGTH( 'radius' ) ],
    props  => [FILL],
);






























# Compass
# Usage: compass x1 y1 length # compass=   [0|1] [0|1]
REGION compass => (
    params => [ VERTEX( 'base' ), LENGTH ],
    props  => [
        COORDS( label => 'compass', default => 'physical' ),
        TEXT( name => 'north', label => undef, default => 'N' ),
        TEXT( name => 'east',  label => undef, default => 'E' ),
        ARROWS( label => undef, default => sub { [ 1, 1 ] } ),
    ],
);
















# Composite
# Usage: # composite x y angle
REGION composite => (
    comment => !!1,
    with    => [],    # we're not a normal region, so don't compose with RegionRole
    params  => [
        VERTEX( 'center' ),
        ANGLE( required => !!0 ),
        {
            name   => 'regions',
            isa    => ArrayRef [ ConsumerOf [RegionRole] ],
            render => !!0,
        },
    ],
    around => [
        render => sub ( $orig, $self ) {
            return [ $self->$orig, map { $_->render } $self->regions->@* ];
        },
    ],
);





























# Ellipse
# Usage: ellipse x y radius radius angle # fill=[0|1]
REGION ellipse_plain => (
    name   => 'ellipse',
    params => [ VERTEX( 'center' ), LENGTHPAIR( 'radii' ), ANGLE( required => !!0 ) ],
    props  => [FILL],
);

# Ellipse Annulus
# Usage: ellipse x y r11 r12 r21 r22 n=# [angle]
REGION ellipse_n => (
    name   => 'ellipse',
    params => [
        VERTEX( 'center' ),
        LENGTHPAIR( 'inner' ),
        LENGTHPAIR( 'outer' ),
        N( label => 'n' ),
        ANGLE( required => !!0 ),
    ],
);

# Ellipse Annulus
# Usage: ellipse x y r11 r12 r21 r22 r31 r32 ... [angle]
REGION ellipse_annuli => (
    name   => 'ellipse',
    params => [ VERTEX( 'center' ), LENGTHPAIR_ARRAY( 'annuli' ), ANGLE( required => !!0 ), ],
);













# Epanda
# Usage: epanda x y startangle stopangle nangle inner outer nradius [angle]
REGION epanda => (
    params => [
        VERTEX( 'center' ),
        ANGLEPAIR,
        N( 'nangles' ),
        LENGTHPAIR( 'inner' ),
        LENGTHPAIR( 'outer' ),
        N( 'nannuli' ),
        ANGLE( required => !!0 ),
    ],
);











# Line
# Usage: line x1 y1 x2 y2 # line=[0|1] [0|1]
REGION line => (
    params => [ VERTEX( 'v1' ), VERTEX( 'v2' ) ],
    props  => [ ARROWS( label => 'line' ) ],
);











# Panda
# Usage: panda x y startangle stopangle nangle inner outer nradius
REGION panda => (
    params => [
        VERTEX( 'center' ),
        ANGLEPAIR,
        N( 'nangles' ),
        LENGTH( 'inner' ),
        LENGTH( 'outer' ),
        N( 'nannuli' ),
    ],
);

















# Point
# Usage: point x y # point=[circle|box|diamond|cross|x|arrow|boxcircle] [size]
#        circle point x y
REGION point => (
    params => [ VERTEX( 'center' ) ],
    props  => [ POINT, POSINT( name => 'size', label => undef ) ],
);








# Polygon
# Usage: polygon x1 y1 x2 y2 x3 y3 ...# fill=[0|1]
REGION polygon => (
    params => [VERTICES],
    props  => [FILL],
);









# Projection
# Usage: projection x1 y1 x2 y2 width
REGION projection => ( params => [ VERTEX( 'v1' ), VERTEX( 'v2' ), LENGTH( 'width' ) ], );













# Ruler
# Usage: ruler x1 y1 x2 y2 # ruler=[pixels|degrees|arcmin|arcsec] [format=]
REGION ruler => (
    params => [ VERTEX( 'v1' ), VERTEX( 'v2' ) ],
    props  => [ RULERCOORDS,    FORMAT ],
);







# Text
# Usage: text x y # text={Your Text Here}
#        text x y {Your Text Here}
REGION text => ( params => [ VERTEX( 'center' ), TEXT ], );













# Vector
# Usage: vector x1 y1 length angle # vector=[0|1]
REGION vector => (
    params => [ VERTEX( 'base' ), LENGTH, ANGLE ],
    props  => [ ARROW( label => 'vector' ) ],
);

# set up dispatch classes to handle the different types of annulus and ellipse regions

# The 'annulus' region can be
# * annuli with inner and outer radii and count
# * annuli with explicitly specified radii

# The 'ellipse' region can be
# * a simple ellipse;
# * elliptical annuli with inner and outer radii pairs and count
# * elliptical annuli with explicitly specified radii pairs

# The 'box' region can be
# * a simple box;
# * box annuli with inner and outer dims and count
# * box annuli with explicitly specified dims

my sub dispatch ( $package, %args ) {
    my $suffix
      = ( List::Util::any { exists $args{$_} } qw( inner outer n ) )
      ? 'n'
      : exists $args{annuli} ? 'annuli'
      # no such thing as annulus_plain; bounce to annulus_n and it'll
      # croak because of bad args
      : $package =~ /Annulus/ ? 'n'
      :                         'plain';

    return "${package}_${suffix}";
}

for my $region ( 'annulus', 'ellipse', 'box' ) {
    my $pkg = pkgpath( $region );
    Package::Stash->new( $pkg )->add_symbol(
        '&new',
        sub ( $, %args ) {
            my $class = dispatch( $pkg, %args );
            return $class->new( %args );
        } );
    $stash->add_symbol( q{&} . $region, sub { $pkg->new( @_ ) } );
    push @EXPORT_OK, $region;
}


# No longer need this; clean it up.
undef $stash;











sub mkregion ( $shape, @args ) {
    my $class = pkgpath( $shape );
    my $new   = $class->can( 'new' ) // croak( "unknown region: $shape" );
    $class->$new( @args );
}

1;

#
# This file is part of CXC-Astro-Regions
#
# This software is Copyright (c) 2023 by Smithsonian Astrophysical Observatory.
#
# This is free software, licensed under:
#
#   The GNU General Public License, Version 3, June 2007
#

__END__