#!/usr/bin/perl
use warnings;
use Tk;
use PDL::LiteF;
use PDL::Graphics::TriD;

# this is the old TriD::Tk.pm from earlier PDL
# releases, slightly modified to use the new OpenGL module
# It works on linux only
package PDL::Graphics::TriD::Tk;
use Tk;
use PDL::Core;
use PDL::Graphics::TriD;
use PDL::Graphics::OpenGLQ;
use OpenGL;
use strict;
no warnings ('redefine'); # redefine MainLoop

@PDL::Graphics::TriD::Tk::ISA = qw(Tk::Frame);

$PDL::Graphics::TriD::Tk::verbose=0;

Tk::Widget->Construct('Tk');

# Populate is used for widget initialization by Tk,
# this function should never be called directly

sub Populate {
my($TriD, $args) = @_;

if(defined $PDL::Graphics::TriD::cur){
print "Current code limitations prevent TriD:Tk from being loaded afte
+r ";
print "another TriD graphics window has been defined.  If you are runn
+ing the ";
print "PDL demo package, please start it again and run this demo first
+.\n";
exit;
}

$args->{-height}=300 unless defined $args->{-height};
$args->{-width}=300 unless defined $args->{-width};

$TriD->SUPER::Populate($args);
# This bind causes GL to be initialized after the
# Tk frame is ready to accept it
$TriD->bind("<Configure>", [ \&GLinit ]);
print "Populate complete\n" if($PDL::Graphics::TriD::Tk::verbose);
}

=head2 MainLoop

=for ref

Should be used in place of the Tk MainLoop.  Handles all of the Tk
callbacks and calls the appropriate TriD display functions.

=cut

sub MainLoop
{
my ($self) = @_;

unless ($Tk::inMainLoop)
{
local $Tk::inMainLoop = 1;
while (Tk::MainWindow->Count)
{
DoOneEvent(Tk::DONT_WAIT());

if(defined $self->{GLwin}){
if( &XPending()){
my @e = &glpXNextEvent();
#  if($e[0] == &ConfigureNotify) {
#    print "CONFIGNOTIFE\n" if($PDL::Graphics::TriD::verbose);
#    $self->reshape($e[1],$e[2]);
#  }

$self->refresh();
}
my $job=shift(@{$self->{WorkQue}});
if(defined $job){
my($cmd,@args) = @$job;
&{$cmd}(@args);
    }
   }
  }
 }
}

=head2 GLinit

=for ref

GLinit is called internally by a Configure callback in Populate.  This
+ insures
that the required Tk::Frame is initialized before the TriD::GL window 
+that will go inside.

=cut

sub GLinit{
my($self,@args) = @_;

if(defined $self->{GLwin}){
#    print "OW= ",$self->width," OH= ",$self->height,"\n";
#    $self->update;
#    print "NW= ",$self->width," NH= ",$self->height,"\n";
$self->{GLwin}{_GLObject}->XResizeWindow($self->width ,$self->height);

$self->{GLwin}->reshape($self->width,$self->height);
$self->refresh();
}else{
# width and height represent the largest size on my screen so that the
# graphics window always fills the frame.
my $options={parent=> ${$self->WindowId},
width=> $self->width,
height=>$self->height};
$options->{mask} = ( ExposureMask );

$self->{GLwin} = PDL::Graphics::TriD::get_current_window($options);

$self->{GLwin}->reshape($self->width,$self->height);

#
# This is an array for future expansion beyond the twiddle call.
#
$self->{WorkQue}= [];
$self->refresh();

$self->bind("<Button1-Motion>",[ \&buttonmotion, 1, Ev('x'),Ev('y')]);
$self->bind("<Button2-Motion>",[ \&buttonmotion, 2, Ev('x'),Ev('y')]);
$self->bind("<Button3-Motion>",[ \&buttonmotion, 3, Ev('x'),Ev('y')]);
}

}

=head2 refresh

=for ref

refresh() causes a display event to be put at the top of the TriD work
+ que.
This should be called at the end of each user defined TriD::Tk callbac
+k.

=cut

sub refresh{
my($self) = @_;
return unless defined $self->{GLwin};
# put a redraw command at the top of the work queue
my $dcall=ref($self->{GLwin})."::display";
unshift(@{$self->{WorkQue}}, [\&{$dcall},$self->{GLwin}]);
}

=head2 AUTOLOAD

=for ref

Trys to find a subroutine in PDL::Graphics::TriD when it is
not found in this package.

=cut

#
#  This AUTOLOAD allows the PDL::Graphics::TriD::Tk object to act as t
+he PDL::Graphics::TriD
#  object which it contains.  It seems slow and may not be a good idea
+.
#

sub AUTOLOAD {
my ($self,@args)=@_;
use vars qw($AUTOLOAD);
my $sub = $AUTOLOAD;
# get subroutine name

#  print "In AutoLoad $self $sub\n";
if(defined($self->{GLwin})){
$sub =~ s/.*:://;
return($self->{GLwin}->$sub(@args));
}
}


=head2 buttonmotion

=for ref

Default bindings for mousemotion with buttons 1 and 3

=cut

sub buttonmotion{
my($self,$but,$x,$y)=@_;

$but--;

foreach my $vp (@{$self->viewports()}){
#    use Data::Dumper;
#    my $out = Dumper($vp);
#    print "$out\n";
#    exit;
next unless $vp->{Active};
next unless defined $vp->{EHandler}{Buttons}[$but];
$vp->{EHandler}{Buttons}[$but]->mouse_moved($vp->{EHandler}{X},
$vp->{EHandler}{Y}, $x,$y);
$vp->{EHandler}{X} = $x;
$vp->{EHandler}{Y} = $y;
}

$self->refresh();
}

=head1 Author

B<James P. Edwards, Instituto Nacional de Meteorologia Brasil>

jedwards@inmet.gov.br

=cut

1;

package main;

# some default settings
my %var =(
's'=> 40,
'o'=> .5,
'i'=> .1,
'r' => .5,
'g' => .5,
'b' => .25
);

my $mw = MainWindow->new(-bg => 'white');

my $TriDW = $mw->Tk(-width => 500, -height => 500 )->pack(-side => 'le
+ft', -expand=>1, -fill=>'both');
# needed to make sure GL window sets up
$TriDW->waitVisibility;

my $button = $mw->Button(-text=>'Quit',
     -command => sub{ exit })->pack();


my $button2 = $mw->Button(-text=>'interesting quark-like effect',
    -command => sub{
     $var{'s'} = 50;
     $var{'o'} = .17;
     $var{'i'} = 1.85;
     $var{'r'} = .5;
     $var{'g'} = .5;
     $var{'b'} = .25;

  &Torusdemos();
})->pack();

my $tframe1 = $mw->Frame()->pack(-side=>'right',-padx=>0);

my %scale;

for ('s','o','i','r','g','b'){

my $tframea = $tframe1->Frame(-bg =>'black')->pack(-side=>'left',-padx
+=>0);

$tframea->Label(-text => " $_   ")->pack(-side=>'top');

my $range0 = .1;
my $range1 = 5;

if( $_ eq 's'){ $range0 = 5; $range1 = 100 }
if( $_ =~ /[r|g|b]/ ){ $range0 = 0; $range1 = 10 }


$scale{$_} = $tframea->Scale(
 -from    => $range0,
 -to    => $range1,
 -length => 500,
 -orient    => 'vertical',
 -variable    => \$var{$_},
 -resolution => .01,
 -borderwidth =>0,
 -foreground => 'white',
 -background => 'lightslategrey',
 -troughcolor => 'powderblue',
 )->pack(-side => 'left', -padx=>10);

$scale{$_}->bind('<ButtonRelease-1>', sub{ &Torusdemos() } );
 
}

&Torusdemos();

my $vp = $TriDW->{ GLwin }->current_viewport;
$vp->setview([3,3,3]);

$TriDW->MainLoop;


sub Torusdemos {

# seems to work to release the old data set
$TriDW->clear_viewports();

my $graph = $TriDW->{ GLwin }->current_viewport->graph();
$graph = new PDL::Graphics::TriD::Graph();
$graph->default_axes();

#   $graph->delete_data( "TorusColors" );
#   $graph->delete_data( "TorusLighting" );

my $data;
my $s = $var{'s'};
my $a = zeroes 2 * $s, $s / 2;
my $t = $a->xlinvals( 0, 6.284 );
my $u = $a->ylinvals( 0, 6.284 );
my $o = $var{'o'};
my $i = $var{'i'};
my $v = $o + $i * sin $u;

my $x = $v * sin $t;
my $y = $v * cos $t;
my $z = $i * cos( $u ) + $o * sin( 3 * $t );

# color

my $r = $var{'r'};
my $g = $var{'g'};
my $b = $var{'b'};

$data = new PDL::Graphics::TriD::SLattice(
[ $x, $y, $z ],
[
$r *  ( 1 + sin $t ),
$g *  ( 1 + cos $t ),
$b * ( 2 + cos( $u ) + sin( 3 * $t ) )
]
);

#  black and white
#     $data = new PDL::Graphics::TriD::SLattice_S( [ $x, $y, $z ] );
$graph->add_dataseries( $data, "demo" );

$graph->scalethings();

$TriDW->current_viewport()->graph( $graph );
$TriDW->refresh();

}
__END__
[download]