File Coverage

blib/lib/Compass/Points.pm
Criterion Covered Total %
statement 25 26 96.1
branch 3 4 75.0
condition 5 6 83.3
subroutine 6 6 100.0
pod 1 1 100.0
total 40 43 93.0


line stmt bran cond sub pod time code
1             package Compass::Points;
2              
3 3     3   2834 use strict;
  3         6  
  3         128  
4 3     3   46 use warnings;
  3         6  
  3         1734  
5              
6             our $VERSION = "0.02";
7              
8             our @FIELDS = qw( abbr name );
9             our @NAMES = (
10             [ N => "North" ],
11             [ NbE => "North by east" ],
12             [ NNE => "North-northeast" ],
13             [ NEbN => "Northeast by north" ],
14             [ NE => "Northeast" ],
15             [ NEbE => "Northeast by east" ],
16             [ ENE => "East-northeast" ],
17             [ EbN => "East by north" ],
18             [ E => "East" ],
19             [ EbS => "East by south" ],
20             [ ESE => "East-southeast" ],
21             [ SEbE => "Southeast by east" ],
22             [ SE => "Southeast" ],
23             [ SEbS => "Southeast by south" ],
24             [ SSE => "South-southeast" ],
25             [ SbE => "South by east" ],
26             [ S => "South" ],
27             [ SbW => "South by west" ],
28             [ SSW => "South-southwest" ],
29             [ SWbS => "Southwest by south" ],
30             [ SW => "Southwest" ],
31             [ SWbW => "Southwest by west" ],
32             [ WSW => "West-southwest" ],
33             [ WbS => "West by south" ],
34             [ W => "West" ],
35             [ WbN => "West by north" ],
36             [ WNW => "West-northwest" ],
37             [ NWbW => "Northwest by west" ],
38             [ NW => "Northwest" ],
39             [ NWbN => "Northwest by north" ],
40             [ NNW => "North-northwest" ],
41             [ NbW => "North by west" ],
42             );
43             our @GROUP; # separate groups to assign different degree values
44             our @INDEX; # index per group
45             our @MAP; # mapping for easy access
46              
47             for my $n ( 0 .. 3 ) {
48             my $slice = 360 / ( 2 ** ( 2 + $n ) ); # 90, 45, 22.5, 11.25
49             my $mod = 2 ** ( 3 - $n ); # 8, 4, 2, 1
50             my @offs = grep $_ % $mod == 0, 0 .. $#NAMES; # 0,8,16,24 0,4,8,12,...
51              
52             $GROUP[ $n ] = bless( [], __PACKAGE__ );
53              
54             for my $m ( 0 .. $#offs ) {
55             my @entry = @{ $NAMES[ $offs[ $m ] ] };
56              
57             for my $key ( map lc, @entry ) {
58             $key =~ s![^a-z]!!g;
59              
60             $INDEX[ $n ]{ $key } = \@entry;
61             }
62              
63             $entry[ 2 ] = $m * $slice;
64              
65             $GROUP[ $n ][ $m ] = \@entry;
66             }
67              
68             $MAP[ $_ ] = $n for @MAP .. $#offs;
69             }
70              
71             sub new
72             {
73 5     5 1 2109 my $class = shift;
74 5   100     31 my $number = shift || 16;
75              
76 0         0 $number = @{ $GROUP[ $#GROUP ] }
  5         37  
77 5 50       13 if $number > @{ $GROUP[ $#GROUP ] };
78              
79 5         24 return $GROUP[ $MAP[ $number - 1 ] ];
80             }
81              
82             for my $offset ( 0 .. $#FIELDS ) {
83             my $deg2sub = "deg2$FIELDS[ $offset ]";
84             my $sub2deg = "$FIELDS[ $offset ]2deg";
85              
86 3     3   36 no strict qw( refs );
  3         6  
  3         738  
87              
88             *$deg2sub = sub {
89 16     16   467 my $self = shift;
90 16   100     52 my $deg = abs( shift || 0 );
91              
92 16         47 $deg -= 360 while $deg > 360;
93              
94 16         29 my $slice = 360 / @$self;
95 16         29 my $index = ( $deg + $slice / 2 ) / $slice;
96              
97 16         72 return $self->[ $index ][ $offset ];
98             };
99              
100             *$sub2deg = sub {
101 6     6   17 my $self = shift;
102 6   50     26 my $key = lc( shift || "" );
103 6         14 my $index = $INDEX[ $MAP[ @$self - 1 ] ];
104              
105 6         35 $key =~ s![^a-z]!!g;
106              
107 6 100       42 return exists( $index->{ $key } )
108             ? $index->{ $key }[ 2 ]
109             : undef
110             ;
111             };
112             }
113              
114             1;
115              
116             __END__