#!/usr/bin/perl
use warnings;
use strict;
use Tk;
use Tk::Zinc;

my $mw = tkinit;

my $heightmw = 260;
my $width = 700;
my $height = $heightmw - 60;

$mw->geometry($width.'x'.$heightmw .'+100+100');

my $zinc = $mw->Zinc(-width => $width,
 -height => $height,
 -backcolor => 'black')->pack(-fill=>'both',-expand => 1);

my $angle = 0;
my $angle_init = 0;
my $px0 = 0;
my $py0 = 0;
my $px_new = 180;
my $py_new = $height;
my ($dx0,$dy0,$dx1,$dy1,$dx2,$dy2);
my $motion = 0;
my $timer;
my $toggle = -1;
my $selset = 0;  #has a number selection been made
my @setleft =();
my @setright =();
my @movers =();
my $drag = undef;
my @tog_left;
my @tog_right;

my %pends;
#make and tag the pendulum groups
my @pends = (0..7);
for(@pends){
$pends{$_}{'pendulum'} = $zinc->add('group',1,-visible=> 1);

# all lines are curves....of course!! it's relativity :-)
$pends{$_}{'line'} = $zinc->add('curve',$pends{$_}{'pendulum'},
[0 ,0, 0 ,$py_new],
 -linewidth => 1,
 -tags => ['line'],
 -fillcolor => 'white',
 -linecolor => 'white',
 -smoothrelief => 1,
);

$pends{$_}{'ball'} = $zinc->add('arc',$pends{$_}{'pendulum'},
[-15,$py_new,15,$py_new+30],
 -tags => ['ball','move'],
 -filled=> 1,
 -fillcolor => 'orange',
);

$zinc->translate($pends{$_}{'pendulum'}, 245 + $_*30, 0);
$pends{$_}{'center_rot'} = [245 + $_ * 30 ,0];
$zinc->addtag($_,'withtag',$pends{$_}{'ball'}); #add a tag number to g
+roup
#save initial matrix settings for zeroing out, compatible with tset
$pends{$_}{'init'} =   $zinc->tget( $pends{$_}{'pendulum'} );
}
# for(@pends){ print join ' ',@{$pends{$_}{'init'}},"\n";} }

my $bframe = $mw->Frame()->pack(-fill =>'both');

my $restartbut = $bframe->Button(
 -text=>'Restart',
 -background => 'lightyellow',
 -activebackground => 'yellow',
 -command =>sub{
$timer->cancel;
for(@pends){
$zinc->tset($pends{$_}{'pendulum'}, @{ $pends{$_}{'init'}} );
$zinc->dtag($pends{$_}{'ball'},'move'); # prevent double move tags
$zinc->addtag('move','withtag','ball'); # restore move tags
}
$angle = 0;
$angle_init = 0;
$motion = 0;
$toggle = -1;
$selset = 0;
@setleft =();
@setright =();
@movers =();
$drag = undef;
@tog_left = ();
@tog_right = ();

&addbindings;
})->pack(-side => 'left');

$bframe->Label(-text=>'Drag balls left or right with' .
' left mouse button and release',
 -background => 'black',
 -foreground => 'lightgreen',

)->pack(-side => 'left',-padx => 0,
-expand => 1,-fill =>'both',);


$bframe->Button(-text=>'Quit',
 -background =>'pink',
 -activebackground => 'red',
-command =>sub{exit})->pack(-side => 'right');

&addbindings;

MainLoop;
######################################################
sub addbindings{
$zinc->bind('move', '<1>', sub { &mobileStart(); });
$zinc->bind('move', '<B1-Motion>', sub {&mobileMove();});
$zinc->bind('move', '<ButtonRelease>', sub {&mobileStop();});
}
#########################################################
sub mobileStart {
my $ev = $zinc->XEvent;
($dx0, $dy0) = ($ev->x,$ev->y);
$zinc->raise('current');
}
######################################################
sub mobileMove {
return if $selset;
my $ev = $zinc->XEvent;
my ($dx1, $dy1) = ($ev->x ,$ev->y);
($dx2,$dy2) = ( $dx1 - $dx0, $dy1 - $dy0 );
my @tags = $zinc->gettags('current');
my ($pennum) = grep /\d+/, @tags;

if( !defined $drag ){
my @stats;
if($dx2 > 0){
(@setright) = grep{ $_ >= $pennum} @pends;
(@setleft) = grep{ $_ < $pennum} @pends;
@movers = @setright;
@stats = @setleft;
$drag = 'right';
}else{
(@setleft) = grep{ $_ <= $pennum} @pends;
(@setright) = grep{ $_ > $pennum} @pends;
@movers = @setleft;
@stats = @setright;
$drag = 'left';
}

for(@stats){
$zinc->dtag($pends{$_}{'ball'},'move');
}
}

$angle_init +=  -$dx2/150;   #chosen just as an easy value in the righ
+t range

if($drag eq 'right'){
if( $angle_init <= -1.57 ){ $angle_init = -1.57; $dx2 = 0 }
if( $angle_init >= 0 ){$angle_init = 0; $dx2 = 0}
}

if($drag eq 'left'){
if( $angle_init >= 1.57 ){ $angle_init = 1.57; $dx2 = 0 }
if( $angle_init <= 0 ){$angle_init = 0; $dx2 = 0}
}

for(@movers){
$zinc->rotate($pends{$_}{'pendulum'},-$dx2/150,@{$pends{$_}{'center_ro
+t'}});
}

($dx0, $dy0) =  ($dx1, $dy1);

}
#######################################################

sub mobileStop{
$selset = 1;
$zinc->bind('move', '<1>', sub { });
$zinc->bind('move', '<B1-Motion>', sub { });
$zinc->bind('move', '<ButtonRelease>', sub { });
#compute @toggle sets
my $count = scalar @movers;
my @temp = @pends;
@tog_left = splice( @temp, 0, $count );
@temp = @pends;
@tog_right = splice( @temp, -$count);
#print "left->@tog_left\tright->@tog_right\n";
&start;
}
#################################################
######################################################
sub start{
# print "\t\tangle_init->$angle_init\n";
$angle = $angle_init;
$timer = $zinc->repeat(20,sub{
&swing(.017453); # 1 degree
});
}
######################################################
sub swing{
my $angle_old = $angle;
my $rads = shift;
$rads = $toggle*$rads;
$angle = $angle - $rads;
$angle = sprintf("%.4f", $angle);

#zero out, removes inaccuracies of rotations and rads
if( abs($angle) < .0174 ){  #fudge factor for zeroing better
#       print "zero -> $angle\n";
for(@pends){
$zinc->tset($pends{$_}{'pendulum'}, @{ $pends{$_}{'init'}} );
}
$angle_old = 0;
$angle = 0;
$rads = 0;
return;
}

if($angle < 0){ @movers = @tog_right;}
if($angle > 0){ @movers = @tog_left;}

# print "$angle\t$rads\n";
for(@movers){  # rotate( item, rads, [center of rotation ])
$zinc->rotate($pends{$_}{'pendulum'},
-$rads,
@{$pends{$_}{'center_rot'}});
}

if( abs ($angle) > abs($angle_init) ) {
#                 print "flip at $angle\n";
$toggle *= -1
}

}

#################################################################
[download]