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

# photos generated with the xplanet package 
# http://xplanet.sourceforge.net/ 

# the photos are available at 
# http://zentara.net/ztk-ocean/ztk-ocean.zip 
# 1.2 megs 

my $mw = MainWindow->new();
$mw->geometry("700x700+30+30");

my $c = $mw->Scrolled("Canvas",
           -bg=>'black',
           -width  => 650,
           -height => 650,
           -scrollregion=>[-300,-300,1000,1000],
           -scrollbars=>'osoe',
         )->pack();
my $canvas = $c->Subwidget("canvas");

my %zones;

my @pics= <g*.jpg>;

#36 segments 
foreach my $zone (0..35){
  $zones{$zone}{'map'} = $mw->Photo( -file => "g$zone.jpg" );
}

my $cur_zone = 0;
my $cur_map = $canvas->createImage( 0, 0, -image => $zones{ $cur_zone 
+}{'map'},
                                    -anchor => 'nw' );


my $bframe = $mw->Frame(-bg => 'black')->pack(-expand => 1, -fill=>'x'
+);

$bframe->Button(-text =>'Exit',
   -command => sub{ exit })->pack(-side => 'right', -padx => 5);

##--------------------------------- 
my $autospin = 0;
my $autospinner;
$bframe->Checkbutton(
        -text => 'AutoSpin',
        -bg => 'black',
        -fg => 'green',
        -activebackground => 'lightgreen',
        -selectcolor => 'hotpink',
        -variable => \$autospin,
        -command  => \&set_autospin,
            )->pack(-side => 'left', -padx => 5 );
##---------------------------------- 

########################################################### 
my $bcframe = $bframe->Frame(-bg => 'black')->pack(-side => 'left',-ex
+pand=>1);

$bcframe->Button( -text => '',
                 -bg=>'black',
                 -activebackground => 'lightslategrey',
                 -image => &getarrow('left'),
                 -command => sub{ spin(-1,1)
                                     },
                            )->pack(-side =>'left', -fill => 'both');

$bcframe->Button( -text => '',
                 -bg=>'black',
                 -activebackground => 'lightslategrey',
                 -image => &getarrow('right'),
                 -command => sub{ spin(1,1)
                                     },
                            )->pack(-side =>'right',-fill=>'both');

#connect in Left and Right Arrow buttons 
$mw->bind('<Left>', sub{ spin(-1,1) } );
$mw->bind('<Right>', sub{ spin(1,1) } );

MainLoop;
######################################################################
+###### 
sub spin{
my ($adj,$man) = @_;

if( $man && $autospin ){ $autospinner->cancel;
                         $autospin = 0;
                       }
                       
if( $adj  > 0){ $cur_zone++;
                  if($cur_zone == 36){ $cur_zone = 0;}
                      }
if( $adj  < 0){ $cur_zone--;
                  if($cur_zone == -1){$cur_zone = 35 }
                      }
                      
 $canvas->itemconfigure($cur_map, -image => $zones{$cur_zone}{'map'});

}
######################################################################
+### 
sub set_autospin{
     if($autospin){
         $autospinner = $mw->repeat(200, sub{ spin(-1,0) } );
     }else{$autospinner->cancel}
}
######################################################################
+## 
sub getarrow{
my $arrow = shift;

my $left = <<"EOD";
/* XPM */
static char * pixmap[] = {
/* width height num_colors chars_per_pixel */
"   16     12       3            1         ",
/* colors */
"   s None  c None",
".  c black",
"X  c yellow",
/* pixels */
"..........X.....",
"........XXX.....",
"......XXXXX.....",
"....XXXXXXX.....",
"..XXXXXXXXX.....",
"XXXXXXXXXXXXXXXX",
"XXXXXXXXXXXXXXXX",
"..XXXXXXXXX.....",
"....XXXXXXX.....",
"......XXXXX.....",
"........XXX.....",
"..........X....."};
EOD


my $right = <<"EOD";
/* XPM */
static char * pixmap[] = {
/* width height num_colors chars_per_pixel */
"   16     12       3            1         ",
/* colors */
"   s None  c None",
".  c black",
"X  c yellow",
/* pixels */
".....X..........",
".....XXX........",
".....XXXXX......",
".....XXXXXXX....",
".....XXXXXXXXX..",
"XXXXXXXXXXXXXXXX",
"XXXXXXXXXXXXXXXX",
".....XXXXXXXXX..",
".....XXXXXXX....",
".....XXXXX......",
".....XXX........",
".....X.........."};
EOD

my %arrow = ('left',$left,'right',$right);
return $mw->Pixmap(-data => $arrow{$arrow});
}
######################################################################
+#####
[download]