Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"
 
PerlMonks  

comment on

( [id://3333]=superdoc: print w/replies, xml ) Need Help??
    0: package CGI::Imagemap;
    1: 
    2: use Carp;
    3: use strict;
    4: use vars qw( $VERSION );
    5: 
    6: $VERSION = '0.01';
    7: 
    8: 
    9: sub new {
    10:   my $class = shift;
    11:   my $self = bless { SHAPES => [], POINTS => [], }, $class;
    12:   croak "odd number of parameters to CGI::Imagemap::new" if @_ % 2;
    13:   while (@_) {
    14:     my $type = shift;
    15:     my $config = shift;
    16:     croak "configuration not an array reference in CGI::Imagemap::new"
    17:       if ref($config) ne "ARRAY";
    18:     my $shape = CGI::Imagemap::Shape->new($type,$config);
    19:     $self->{DEFAULT} = $shape, next if $type eq 'DEFAULT';
    20:     push @{ $self->{SHAPES} }, $shape unless @{ $self->{POINTS} };
    21:     push @{ $self->{POINTS} }, $shape if $type eq 'POINT';
    22:   }
    23:   return $self;
    24: }
    25: 
    26: 
    27: sub query_eval {
    28:   my ($self, $query, $field) = @_;
    29:   croak "query must be CGI object in CGI::Imagemap::query_eval"
    30:     unless UNIVERSAL::isa($query, 'CGI');
    31:   my ($x,$y) = ($query->param("$field.x"), $query->param("$field.y"));
    32:   $self->manual_eval($x,$y);
    33: }
    34: 
    35: 
    36: sub manual_eval {
    37:   my ($self, $x, $y) = @_;
    38:   for (@{ $self->{SHAPES} }) {
    39:     if ($_->type('POINT')) {
    40:       my ($min,$shape) = ($_->proximity($x,$y),$_);
    41:       for (@{ $self->{POINTS} }) {
    42:         my $dst = $_->proximity($x,$y);
    43:         $dst < $min and ($min,$shape) = ($dst,$_);
    44:       }
    45:       $shape->execute() and return 1;
    46:     }
    47:     $_->proximity($x,$y) and $_->execute() and return 1;
    48:   }
    49:   $self->{DEFAULT} and $self->{DEFAULT}->execute();
    50:   return 0;
    51: }
    52: 
    53: 
    54: 
    55: package CGI::Imagemap::Shape;
    56: 
    57: use Carp;
    58: 
    59: my %types;
    60: @types{qw( CIRCLE OVAL RECT POLY POINT DEFAULT )} = ();
    61: 
    62: sub new {
    63:   my ($class, $type, $config) = @_;
    64:   croak "invalid shape (must be @{[ keys %types ]}) '$type'"
    65:     unless exists $types{uc $type};
    66:   croak "handler must be code ref" if ref($config->[0]) ne 'CODE';
    67:   my $self = bless {}, $class . "::" . uc($type);
    68:   $self->{HANDLER} = shift @$config;
    69:   $self->{COORDS} = $config;
    70:   return $self;
    71: }
    72: 
    73: 
    74: sub coords { return @{ $_[0]{COORDS} } }
    75: 
    76: 
    77: sub execute { $_[0]{HANDLER}->() }
    78: 
    79: 
    80: 
    81: package CGI::Imagemap::Shape::CIRCLE;
    82: 
    83: use vars '@ISA';
    84: @ISA = qw( CGI::Imagemap::Shape );
    85: 
    86: sub proximity {
    87:   my ($shape, $x, $y) = @_;
    88:   my ($Cx, $Cy, $r) = $shape->coords;
    89:   return ($x - $Cx)**2 + ($y - $Cy)**2 <= $r**2; 
    90: }
    91: 
    92: 
    93: 
    94: package CGI::Imagemap::Shape::OVAL;
    95: 
    96: use vars '@ISA';
    97: @ISA = qw( CGI::Imagemap::Shape );
    98: 
    99: sub proximity {
    100:   my ($shape, $x, $y) = @_;
    101:   my ($Cx, $Cy, $a, $b) = $shape->coords;
    102:   return (($x - $Cx)/$a)**2 + (($y - $Cy)/$b)**2 <= 1;
    103: }
    104: 
    105: 
    106: 
    107: package CGI::Imagemap::Shape::RECT;
    108: 
    109: use vars '@ISA';
    110: @ISA = qw( CGI::Imagemap::Shape );
    111: 
    112: sub proximity {
    113:   my ($shape, $x, $y) = @_;
    114:   my ($ULx, $ULy, $LRx, $LRy) = $shape->coords;
    115:   return ($ULx <= $x) && ($x <= $LRx) && ($ULy <= $y) && ($y <= $LRy);
    116: }
    117: 
    118: 
    119: 
    120: package CGI::Imagemap::Shape::POLY;
    121: 
    122: use vars '@ISA';
    123: @ISA = qw( CGI::Imagemap::Shape );
    124: 
    125: sub coords {
    126:   my ($shape) = @_;
    127:   my @x = map $shape->{COORDS}[$_ * 2], 0 .. $#{ $shape->{COORDS} }/2;
    128:   my @y = map $shape->{COORDS}[$_ * 2 + 1], 0 .. $#{ $shape->{COORDS} }/2;
    129:   return (\@x, \@y);
    130: }
    131: 
    132: 
    133: sub proximity {
    134:   my ($shape, $x, $y) = @_;
    135:   my ($Xc, $Yc) = $shape->coords;
    136:   my @X = @$Xc;
    137:   my @Y = @$Yc;
    138:   my $n = @X;
    139:   my ($i,$j);
    140:   my $inside = 0;
    141:   # thanks to "Mastering Algorithms in Perl" (pg. 444-5)
    142:   # point_in_ploygon derived from Wm. Randolph Franklin
    143: 
    144:   for ($i = 0, $j = $n - 1; $i < $n; $j = $i++) {
    145:     if (
    146:          (
    147:            (($Y[$i] <= $y) && ($y < $Y[$j])) ||
    148:            (($Y[$j] <= $y) && ($y < $Y[$i]))
    149:          )
    150:          and
    151:          ($x <
    152:            ($X[$j] - $X[$i]) *
    153:            ($y - $Y[$i]) /
    154:            ($Y[$j] - $Y[$i]) +
    155:            $X[$i]
    156:          )
    157:        ) { $inside = !$inside }
    158:   }
    159: 
    160:   return $inside;
    161: }
    162: 
    163: 
    164: 
    165: package CGI::Imagemap::Shape::POINT;
    166: 
    167: use vars '@ISA';
    168: @ISA = qw( CGI::Imagemap::Shape );
    169: 
    170: sub proximity {
    171:   my ($shape, $x, $y) = @_;
    172:   my ($Px, $Py) = $shape->coords;
    173:   return sqrt(($Px - $x)**2 + ($Py - $y)**2);
    174: }
    175: 
    176: 
    177: 1;
    178: 
    179: 
    180: __END__
    181: 
    182: =head1 NAME
    183: 
    184: CGI::Imagemap - program-handling of X,Y coordinates in an
    185: image
    186: 
    187: =head1 SYNOPSIS
    188: 
    189:   use CGI::Imagemap;
    190:   $request = CGI::Imagemap->new(
    191:     CIRCLE => [\&handler, $center_x, $center_y, $radius],
    192:     OVAL => [\&handler, $axis_x, $axis_y, $den_x, $den_y],
    193:     RECT => [\&handler, $upleft_x, $upleft_y, $lowright_x, $lowright_y],
    194:     POLY => [\&handler, $x0, $y0, $x1, $y1, ..., $xN, $yN],
    195:     POINT => [\&handler, $x, $y],
    196:     DEFAULT => [\&handler],
    197:   );
    198:   $found = $request->query_eval($CGIobj, $fieldname);
    199:   $found = $request->manual_eval($px, $py);
    200:   if (!$found) {
    201:     # resorted to DEFAULT handler
    202:   }
    203: 
    204: =head1 DESCRIPTION
    205: 
    206: Basically, you make a CGI::Imagemap object, and list (in
    207: order of precedence) the zones that the imagemap should map
    208: to.  The shape names are CIRCLE, OVAL, RECT, POLY, POINT,
    209: and DEFAULT.  All POINT shapes will be compared at the same
    210: time, and they should be left for last.
    211: 
    212: The query_eval method takes a CGI query object and a
    213: fieldname, and gets the fieldname.x and fieldname.y values
    214: from the query object.  Then it calls manual_eval.  This
    215: just takes the (x,y) pair of coordinates.
    216: 
    217: The shapes take a handler (code reference) as their first
    218: argument, and this handler will be executed if the point is
    219: within the bounds of the shape.  If the default handler is
    220: resorted to, the query_eval and manual_eval methods will
    221: return 0.  Otherwise, they'll return 1.
    222: 
    223: That's about it.
    224: 
    225: =head1 AUTHOR
    226: 
    227:   Jeff "japhy" Pinyan
    228:   CPAN ID: PINYAN
    229:   japhy@pobox.com
    230: 
    231: =cut

In reply to CGI::Imagemap by japhy

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others taking refuge in the Monastery: (5)
As of 2024-03-28 23:08 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found