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

my $width = 400;
my $height = 600;

my %tgroups;
my %scrollers;

my $mw = MainWindow->new;
$mw->protocol('WM_DELETE_WINDOW' => sub { &clean_exit });
$mw->geometry($width.'x'.$height);
$mw->configure(-background => 'black');
$mw->resizable(0,0);

$mw->fontCreate('medium',
   -family=>'courier',
   -weight=>'bold',
   -size=>int(-14*14/10));

my $zinc = $mw->Zinc(-width => $width, -height => $height,
                -backcolor => 'black',
        -borderwidth => 0, 
        -relief => 'sunken',
        -cursor => "top_left_arrow",
        )->pack;

#create a group with it's origin at 0,0 upper left corner 
$tgroups{0}= $zinc->add('group',1,-visible=> 1);
$zinc->scale( $tgroups{0}, 1, -1); #reverse direction of y axis so
                                   # numbers increase going down 

#create some vertical text 
my @letters;
 foreach my $i(33..126,161..255){
   push @letters, chr($i);   
 }

my @shuffled = map {$_->[0]}
               sort { $a->[1] <=> $b->[1]}
               map {[$_, rand(1)]} @letters;

my $position = 0;
foreach my $letter( @shuffled ){
  $zinc->add( 'text', $tgroups{0} ,
     -position => [ 0, $position ],
     -text     => $letter,
     -font     => 'medium',
     -color => 'green',
     -priority => 2,
    );
   $position += 15;
}

###################################################
#clone and translate
# get width of column considering font
my @pos = $zinc->bbox( $tgroups{0} ); #(corner coords x,y,x1,y1)
my $widthcol = $pos[2] - $pos[0] + 10;    # add a 5 pixel border
my $numcols = int($width/$widthcol) + 1;  #20 cols 

foreach my $j(1..$numcols){
  $tgroups{$j} = $zinc->clone( $tgroups{0} );
  $zinc->translate($tgroups{$j}, $j * $widthcol, int rand($height/8) )
+;
}

#start scroll
&scroll;

MainLoop;
##########################################################
sub clean_exit{

foreach my $scroller(keys %scrollers){
         $scrollers{$scroller}->cancel;
       }

undef $zinc;
$mw->destroy;
Tk::exit;
}
########################################################
sub scroll {

$scrollers{0} =  $mw->repeat(25,sub {
                 foreach my $key(0,5,10,15,20 ){
                 $zinc->translate($tgroups{ $key },0, 5 );
                 my @pos = $zinc->bbox( $tgroups{$key} ); #(corner coo
+rds x,y,x1,y1)
              if($pos[1] > $height/2){
              $zinc->itemconfigure($tgroups{$key}, -visible => 0);
              $zinc->translate($tgroups{$key}, 0, (-$pos[3] ));
              $zinc->itemconfigure($tgroups{$key}, -visible => 1);
              }              
              }
           
           }       
    );

$scrollers{1} =  $mw->repeat(20,sub {
                 foreach my $key(1,4,6,11,16,19){
                    $zinc->translate($tgroups{ $key },0,5);
                 my @pos = $zinc->bbox( $tgroups{$key} ); #(corner coo
+rds x,y,x1,y1)
              if($pos[1] > $height){
              $zinc->itemconfigure($tgroups{$key}, -visible => 0);
              $zinc->translate($tgroups{$key}, 0, (-$pos[3] ));
              $zinc->itemconfigure($tgroups{$key}, -visible => 1);
              }              
              }
           
           }       
    );

$scrollers{2} =  $mw->repeat(30,sub {
                 foreach my $key(2,7,9,12,14,17){
                    $zinc->translate($tgroups{ $key },0,5);
                 my @pos = $zinc->bbox( $tgroups{$key} ); #(corner coo
+rds x,y,x1,y1)
              if($pos[1] > $height){
              $zinc->itemconfigure($tgroups{$key}, -visible => 0);
              $zinc->translate($tgroups{$key}, 0, (-$pos[3] ));
              $zinc->itemconfigure($tgroups{$key}, -visible => 1);
              }              
              }
           
           }       
    );

$scrollers{3} =  $mw->repeat(36,sub {
                 foreach my $key(3,8,13,18){
                    $zinc->translate($tgroups{ $key },0,5);
                 my @pos = $zinc->bbox( $tgroups{$key} ); #(corner coo
+rds x,y,x1,y1)
              if($pos[1] > $height){
              $zinc->itemconfigure($tgroups{$key}, -visible => 0);
              $zinc->translate($tgroups{$key}, 0, (-$pos[3] - $height)
+);
              $zinc->itemconfigure($tgroups{$key}, -visible => 1);
              }              
              }
           
           }       
    );

return;
}
[download]