File Coverage

blib/lib/Tk/MTDial.pm
Criterion Covered Total %
statement 14 14 100.0
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 19 19 100.0


line stmt bran cond sub pod time code
1             package Tk::MTDial;
2              
3              
4 1     1   13328 use 5.006;
  1         3  
5 1     1   3 use strict;
  1         1  
  1         13  
6 1     1   3 use warnings;
  1         7  
  1         66  
7              
8             =encoding UTF-8
9              
10             =head1 NAME
11              
12             Tk::MTDial - A MTDial Tk widget that can turn indefinitely in any direction.
13              
14             =head1 VERSION
15              
16             Version 0.001
17              
18             =cut
19              
20             $Tk::MTDial::VERSION=0.001;
21              
22             =head1 SYNOPSIS
23              
24             use Tk;
25             use Tk::MTDial;
26             my $value=0;
27             my $svalue="";
28             my $mw=Tk::MainWindow->new(-title=>"MTDial test");
29             my $kf=$mw->Frame->pack;
30             $kf->MTDial( -width=>100,
31             -height=>100,
32             -dialsize=>49,
33             -dialrovariable=>\$v,
34             -dialcommand=>\&cmd,
35             )->pack->createMTDial;
36              
37             sub cmd {
38             $value=$v;
39             $svalue=sprintf "Value: %.2f Hz", $value;
40             $svalue.=" OUT OF RANGE (0-10)", if $value>10 or $value < 0;
41             $value=0 if $value<0;
42             $value=10 if $value > 10;
43             }
44            
45             Creates a circular MTDial that can be turned continuously and
46             indefinitely in any direction
47              
48             =head1 DESCRIPTION
49              
50             MTDial Widget that allows the creation of circular dials that can turn
51             indefinitely to produce arbitrary positive or negative values.
52              
53             =head1 FUNCTIONS
54              
55              
56             =head2 MTDial
57              
58             Make a MTDial object and pass it initialization parameters. They may
59             also be set and interrogated with Tk's 'configure' and 'cget'.
60              
61             =head 3 Parameters (defaults)
62             =over 4
63              
64             =item -width (500)
65              
66             =item -height (500)
67              
68             =item -dialsize (250)
69            
70             =item -dialvalue (0)
71              
72             =item -dialcolor ('DarkGrey')
73              
74             =item -dialborder (2)
75              
76             =item -dialbordercolor1 ('grey38')
77              
78             =item -dialbordercolor2 ('grey99')
79              
80             =item -dialrovariable (undef)
81              
82             =item -dialcommand (sub {return})
83              
84             =back
85              
86             =head2 createMTDial
87              
88             Displays the dial, sets its initial parameters, binds the callback
89             routines.
90              
91             =head2 Not to be called by the user directly
92              
93             =head3 ClassInit
94              
95             Calls the base class initializer
96              
97             =head3 Populate
98              
99             Sets default values for the class parameters.
100              
101             =head3 pushed
102              
103             Routine called when button 1 is pushed
104              
105             =head3 rotate
106              
107             Routine called to rotate dial when the mouse moves
108              
109             =head1 AUTHOR
110              
111             W. Luis Mochán, Instituto de Ciencias Físicas, UNAM, México
112             C
113              
114             =head1 ACKNOWLEDGMENTS
115              
116             This work was partially supported by DGAPA-UNAM under grants IN108413
117             and IN113016.
118              
119             =cut
120              
121              
122             use constant {
123 1         75 PI=>4*atan2(1,1),
124             id=>0.85, # indicator distance from center
125             ir=>0.05, # indicator radius
126 1     1   3 };
  1         1  
127              
128 1     1   3 use base qw/Tk::Derived Tk::Canvas/;
  1         1  
  1         422  
129             use strict;
130             use warnings;
131              
132             Construct Tk::Widget 'MTDial';
133              
134              
135             sub ClassInit {
136             my($class, $mw) = @_;
137             $class->SUPER::ClassInit($mw);
138             }
139              
140             sub Populate {
141             my($self, $args)=@_;
142             my %args=%$args;
143             $self->SUPER::Populate($args);
144             #$self->Advertise();
145             $self->ConfigSpecs(
146             -width => [qw(SELF width Width), 500],
147             -height=> [qw(SELF heigh Height), 500],
148             -dialsize=>[qw(PASSIVE dialsize MTDialsize), 250],
149             -dialvalue=>[qw(PASSIVE dialvalue MTDialvalue), 0],
150             -dialcolor=>[qw(PASSIVE dialcolor MTDialcolor), 'DarkGrey'],
151             -dialborder=>[qw(PASSIVE dialborder MTDialborder), 2],
152             -dialbordercolor1=>[qw(PASSIVE dialbordercolor1 MTDialbordercolor1),
153             'grey38'],
154             -dialbordercolor2=>[qw(PASSIVE dialbordercolor2 MTDialbordercolor2),
155             'grey99'],
156             -dialrovariable=>[qw(PASSIVE dialrovariable MTDialrovariable), undef],
157             -dialcommand=>[qw(CALLBACK dialbordercolor2 MTDialbordercolor2),
158             sub {return}],
159             DEFAULT => ['SELF']
160             );
161             $self->Delegates();
162             }
163              
164             sub createMTDial {
165             my ($self)=@_;
166             my $ks=$self->cget(-dialsize);
167             my $kc=$self->cget(-dialcolor);
168             my $w=$self->cget(-width);
169             my $h=$self->cget(-height);
170             my $kb=$self->cget(-dialborder);
171             my $kbc1=$self->cget(-dialbordercolor1);
172             my $kbc2=$self->cget(-dialbordercolor2);
173             $self->configure(-dialvalue=>${$self->cget(-dialrovariable)})
174             if ref $self->cget(-dialrovariable);
175             my $a=2*PI*$self->cget(-dialvalue);
176             my $ca=cos($a);
177             my $sa=sin($a);
178             $self->create('oval', $w/2-$ks, $h/2-$ks, $w/2+$ks, $h/2+$ks,
179             -fill=>$kc, -width=>0, -tags=>[qw(dial)]);
180             $self->create('arc', $w/2-$ks, $h/2-$ks, $w/2+$ks, $h/2+$ks,
181             -style=>'arc', -start=>-135, -extent=>180, -width=>$kb,
182             -outline=>$kbc1 );
183             $self->create('arc', $w/2-$ks, $h/2-$ks, $w/2+$ks, $h/2+$ks,
184             -style=>'arc', -start=>45, -extent=>180, -width=>$kb,
185             -outline=>$kbc2);
186             $self->create('arc', $w/2+(id*$ca - ir)*$ks, $h/2+(id*$sa - ir)*$ks,
187             $w/2+(id*$ca+ir)*$ks, $h/2+(id*$sa+ir)*$ks,
188             -style=>'pie', -start=>-135, -extent=>180,
189             -fill=>$kbc2, -outline=>undef, -tags=>[qw(dial indicator)]);
190             $self->create('arc', $w/2+(id*$ca - ir)*$ks, $h/2+(id*$sa - ir)*$ks,
191             $w/2+(id*$ca+ir)*$ks, $h/2+(id*$sa+ir)*$ks,
192             -style=>'pie', -start=>45, -extent=>180,
193             -fill=>$kbc1, -outline=>undef, -tags=>[qw(dial indicator)]);
194             $self->bind("dial", '<1>', [\&pushed, Tk::Ev('x'), Tk::Ev('y')]);
195             $self->bind("dial", '', [\&rotate, Tk::Ev('x'), Tk::Ev('y')]);
196             return $self;
197             }
198              
199             sub pushed {
200             my ($self, $x, $y)=@_;
201             $self->{angle}=atan2($y-$self->cget(-height)/2, $x-$self->cget(-width)/2);
202             }
203              
204             sub rotate {
205             my ($self, $x, $y)=@_;
206             my $angle=atan2($y-$self->cget(-height)/2, $x-$self->cget(-width)/2);
207             my $angle0=$self->{'angle'};
208             my $ks=$self->cget(-dialsize);
209             $angle-=2*PI while $angle-$angle0>PI;
210             $angle+=2*PI while $angle-$angle0<= - PI;
211             my $kangle=2*PI*$self->cget(-dialvalue);
212             my $nkangle=$kangle+$angle-$angle0;
213             my $nval=$nkangle/(2*PI);
214             $self->configure(-dialvalue=>$nval);
215             ${$self->cget(-dialrovariable)}=$nval if ref $self->cget(-dialrovariable);
216             my $deltax=id*$ks*cos($nkangle) - id*$ks*cos($kangle);
217             my $deltay=id*$ks*sin($nkangle) - id*$ks*sin($kangle);
218             $self->{angle}=$angle;
219             $self->move('indicator', $deltax, $deltay);
220             $self->Callback(-dialcommand=> $self->cget(-dialvalue));
221             #my $command=$self->cget(-dialcommand);
222             #$command->($self) if defined $command;
223             }
224              
225              
226             1;
227