[system] / trunk / pg / lib / Label.pm Repository:
ViewVC logotype

View of /trunk/pg/lib/Label.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 6346 - (download) (as text) (annotate)
Sat Jul 10 12:39:40 2010 UTC (9 years, 7 months ago) by gage
File size: 4750 byte(s)
Merging changes gage branch  gage_dev/pg

removed dependence on AUTOLOAD	which does not work well with newer versions of Safe.pm.  It wasn't needed 
in any case.  There remain other incompatibilies of WeBWorK with Safe.pm 2.27

Added more support for WARN_MESSAGE  and DEBUG_MESSAGE

Changed List.pm to ChoiceList.pm  to remove confusion with MathObjects List object

Additional support for geogebra applets



    1 =head1 NAME
    2 
    3   Label
    4 
    5 
    6 =head1 SYNPOSIS
    7 
    8   use Carp;
    9   use GD;
   10   use WWPlot;
   11   use Fun;
   12 
   13 
   14 =head1 DESCRIPTION
   15 
   16 This module defines labels for the graph objects (WWPlot).
   17 
   18 
   19 =head2 Usage
   20 
   21   $label1 = new Label($x_value, $y_value, $label_string, $label_color, @justification)
   22   $justification   =   one of ('left', 'center', 'right) and ('bottom', 'center', 'top')
   23                        describes the position of the ($x_value, $y_value) within the string.
   24                        The default is 'left', 'top'
   25 
   26 
   27 
   28 =head2  Example
   29 
   30   $new_label = new Label ( 0,0, 'origin','red','left', 'top')
   31   @labels    = $graph->lb($new_label);
   32 
   33 
   34 
   35 =cut
   36 
   37 
   38 BEGIN {
   39   be_strict(); # an alias for use strict.  This means that all global variable must contain main:: as a prefix.
   40 }
   41 package Label;
   42 use strict;
   43 #use Exporter;
   44 #use DynaLoader;
   45 #use GD;   # this is needed to be able to define GD::gdMediumBoldFont and other terms used by GD
   46 #          # however  constants from GD need to be addressed fully, they have not been imported.
   47 #use  "WWPlot.pm";
   48 #Because of the way problem modules are loaded 'use' is disabled.
   49 
   50 
   51 @Label::ISA = qw(WWPlot);
   52 
   53 my %fields =(
   54     'x'   =>  0,
   55     'y'   =>  0,
   56     color =>  'black',
   57     font  =>  GD::gdMediumBoldFont,    #gdLargeFont
   58     # constants from GD need to be addressed fully, they have not been imported.
   59     str   =>  "",
   60     lr_nudge => 0, #justification parameters
   61     tb_nudge => 0,
   62 );
   63 
   64 
   65 sub new {
   66   my $class         = shift;
   67   my $self      = {
   68         %fields,
   69   };
   70 
   71   bless $self, $class;
   72   $self->_initialize(@_);
   73   return $self;
   74 }
   75 
   76 sub _initialize {
   77   my $self        = shift;
   78   my ($x,$y,$str,$color,@justification) =   @_;
   79   $self -> x($x);
   80   $self -> y($y);
   81   $self -> str($str);
   82   $self -> color($color) if defined($color);
   83   my $j;
   84   foreach $j (@justification)  {
   85     $self->lr_nudge( - length($self->str) )   if $j eq 'right';
   86     $self->tb_nudge( - 1            )   if $j eq 'bottom';
   87     $self->lr_nudge( - ( length($self->str) )/2)if $j eq 'center';
   88     $self->tb_nudge(-0.5)                     if $j eq 'middle';
   89 #   print "\njustification=$j",$self->lr_nudge,$self->tb_nudge,"\n";
   90   }
   91 }
   92 sub draw {
   93   my $self = shift;
   94   my $g = shift;   #the containing graph
   95     $g->im->string( $self->font,
   96             $g->ii($self->x)+int( $self->lr_nudge*($self->font->width) ),
   97             $g->jj($self->y)+int( $self->tb_nudge*($self->font->height) ),
   98             $self->str,
   99             ${$g->colors}{$self->color}
  100           );
  101 
  102 }
  103 
  104 sub AUTOLOAD {
  105   my $self = shift;
  106   my $type = ref($self) || die "$self is not an object";
  107   my $name = $Label::AUTOLOAD;
  108   $name =~ s/.*://;  # strip fully-qualified portion
  109   unless (exists $self->{'_permitted'}->{$name} ) {
  110     die "Can't find '$name' field in object of class $type";
  111   }
  112   if (@_) {
  113     return $self->{$name} = shift;
  114   } else {
  115     return $self->{$name};
  116   }
  117 
  118 }
  119 
  120 ##########################
  121 # Access methods
  122 ##########################
  123 sub x {
  124   my $self = shift;
  125   my $type = ref($self) || die "$self is not an object";
  126   unless (exists $self->{x} ) {
  127     die "Can't find x field in object of class $type";
  128   }
  129 
  130   if (@_) {
  131     return $self->{x} = shift;
  132   } else {
  133     return $self->{x}
  134   }
  135 }
  136 
  137 sub y {
  138   my $self = shift;
  139   my $type = ref($self) || die "$self is not an object";
  140   unless (exists $self->{y} ) {
  141     die "Can't find y field in object of class $type";
  142   }
  143 
  144   if (@_) {
  145     return $self->{y} = shift;
  146   } else {
  147     return $self->{y}
  148   }
  149 }
  150 
  151 sub color {
  152   my $self = shift;
  153   my $type = ref($self) || die "$self is not an object";
  154   unless (exists $self->{color} ) {
  155     die "Can't find color field in object of class $type";
  156   }
  157 
  158   if (@_) {
  159     return $self->{color} = shift;
  160   } else {
  161     return $self->{color}
  162   }
  163 }
  164 sub font {
  165   my $self = shift;
  166   my $type = ref($self) || die "$self is not an object";
  167   unless (exists $self->{font} ) {
  168     die "Can't find font field in object of class $type";
  169   }
  170 
  171   if (@_) {
  172     return $self->{font} = shift;
  173   } else {
  174     return $self->{font}
  175   }
  176 }
  177 sub str {
  178   my $self = shift;
  179   my $type = ref($self) || die "$self is not an object";
  180   unless (exists $self->{str} ) {
  181     die "Can't find str field in object of class $type";
  182   }
  183 
  184   if (@_) {
  185     return $self->{str} = shift;
  186   } else {
  187     return $self->{str}
  188   }
  189 }
  190 sub lr_nudge {
  191   my $self = shift;
  192   my $type = ref($self) || die "$self is not an object";
  193   unless (exists $self->{lr_nudge} ) {
  194     die "Can't find lr_nudge field in object of class $type";
  195   }
  196 
  197   if (@_) {
  198     return $self->{lr_nudge} = shift;
  199   } else {
  200     return $self->{lr_nudge}
  201   }
  202 }
  203 
  204 sub tb_nudge {
  205   my $self = shift;
  206   my $type = ref($self) || die "$self is not an object";
  207   unless (exists $self->{tb_nudge} ) {
  208     die "Can't find tb_nudge field in object of class $type";
  209   }
  210 
  211   if (@_) {
  212     return $self->{tb_nudge} = shift;
  213   } else {
  214     return $self->{tb_nudge}
  215   }
  216 }
  217 sub DESTROY {
  218   # doing nothing about destruction, hope that isn't dangerous
  219 }
  220 
  221 1;
  222 
  223 
  224 

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9