#!/usr/local/bin/perl5 -w

package Turtle;

use strict;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK
    $main $canvas
);

require Exporter;
require AutoLoader;

@ISA = qw(Exporter AutoLoader 
);

@EXPORT = qw( );

$VERSION = "0.1";

use Tk;
use Carp;


$main = '';
$canvas = '';

sub create {
    my $type = shift;
    my ($self) = @_;
    $self = {} if (!defined($self)) ;
    bless $self,$type;
    $self->{-x} = 0;
    $self->{-y} = 0;
    $self->{-width} = 5;
    $self->{-name} = '.';
    $self->{-dir} = 0;
    $self->{-sin} = 0;
    $self->{-cos} = 1;
    $self->{-color} = 'black';
    return $self->set_display();
}

sub move {
    my ($self,$dx,$dy) = @_;
    my ($ox,$oy) = ($self->{-x},$self->{-y});
    $self->{-x} += $dx;
    $self->{-y} += $dy;
    return $self if ($self->{-color} eq 'none');
    $self->{-canvas}->create('line',
	$ox,$oy,
	$self->{-x}, $self->{-y},
	-width=>$self->{-width},
	-tags=>$self->{-name},
	-fill=>$self->{-color});
    $self->{-main}->update;
    return $self;
}

sub color {
    my ($self,$color) = @_;
    $self->{-color} = $color;
    return $self;
}

sub name {
    my ($self,$name) = @_;
    $self->{-name} = $name;
    return $self;
}

sub width {
    my ($self,$width) = @_;
    $self->{-width} = $width;
    return $self;
}

sub erase {
    my ($self,$name) = @_;
    $self->{-canvas}->delete($name);
    return $self;
}

sub direction {
    my ($self,$dir) = @_;
    $self->{-dir} = $dir;
    $self->{-sin} = sin($dir*(2*3.14159626/360));
    $self->{-cos} = cos($dir*(2*3.14159626/360));
    return $self;
}

sub turn {
    my ($self,$turn) = @_;
    $self->direction($self->{-dir} + $turn);
    return $self;
}

sub left {
    my ($self) = @_;
    $self->turn(-90);
    return $self;
}

sub right {
    my ($self) = @_;
    $self->turn(90);
    return $self;
}

sub forward {
    my ($self,$length) = @_;
    $self->move(
	$self->{-cos}*$length,			
	$self->{-sin}*$length
    );
    return $self;
}

sub set_display {
    my ($self) = @_;
    my ($w,$c,$wsy,$wsx);

    if(!defined($self->{'-main'})) {
	if ($main) {
	    $self->{'-main'} = $main;
	} else {
	    $main = $self->{'-main'} = MainWindow->new();
	    $main->Button(-text => 'Ok', -width => 8, 
		-command => ['destroy', $main])->pack();
	}
    } 
    if (! $main) {
	$main = $self->{'-main'};
    }
    if(!defined($self->{'-canvas'})) {
	if ($canvas) {
	    $self->{'-canvas'} = $canvas;
	} else {
	    $w = $main->Frame;
	    $canvas = $self->{'-canvas'} = 
		$w->Canvas();
	    $c = $canvas;
$wsy = $w->Scrollbar( -relief=>"sunken", -command=>[$c,"yview"])->pack;
$wsx = $w->Scrollbar( -orient=>"horiz", -relief=>"sunken",-command=>[$c,"xview"])->pack;
$w->pack(-expand=>"yes",-fill => "both");
$wsy->pack(-side => 'right', -fill => 'y');
$wsx->pack(-side => 'bottom', -fill => 'x');
$c->pack(-expand => 'yes', -fill => 'both');
$c->configure(-xscrollcommand => ['set', $wsx], -yscrollcommand => ['set', $wsy]);
$main->Button(-text=>'Enlarge',-command=>sub{scale($c,1.6)})
      ->pack(-side=>'left',-expand=>1);
$main->Button(-text=>'Shrink',-command=>sub{scale($c,0.625)})
      ->pack(-side=>'left',-expand=>1);
	}
    } 
    if (! $canvas) {
	$canvas = $self->{'-canvas'};
    }
    $main->update();
    return $self;
}

sub scale {
    my ($c,$scale) = @_;
    my ($w,$h) = ($c->geometry =~ /\d+x\d+([+-]\d+)([+-]\d+)/);
    my ($s) = $c->cget(-scrollregion);
    my ($x,$y) = ($c->canvasx($w/2),$c->canvasy($h/2));
    $s->[0] = ($s->[0]-$x)*$scale+$x;
    $s->[1] = ($s->[1]-$y)*$scale+$y;
    $s->[2] = ($s->[2]-$x)*$scale+$x;
    $s->[3] = ($s->[3]-$y)*$scale+$y;
    $c->configure(-scrollregion=>$s);
    $c->scale('all', $x,$y,$scale,$scale);
}


sub MainLoop {
    my ($self) = @_;
    $self->{-main}->MainLoop();
}

1;


__END__

=head1 NAME

Turtle - Turtle Graphics Routine for Perl/Tk

=head1 SYNOPSIS

    use Turtle;

=head1 DESCRIPTION

Perl/Tkを使った Turtle Graphics ライブラリです。

sub create()
	Turtle を一つ作る。Window が開いてなければ新しく作ります。

sub move($x,$y)
	絶対座標への移動。移動の軌跡が線で描画されます。

sub color($color)
	色の指定。'none' を指定すると描画しません。

sub name($name))
	名前の指定。描画の時のPerl/TKのタグが指定されます。

sub width($width)
	線幅の指定

sub erase($name)
	指定された名前の亀が書いた絵を消します。

sub direction($dir) 
	forward の描画方向の絶対指定。360度で指定します。

sub turn($dir)
	forward の描画方向の相対指定。360度で指定します。

sub left()
	90度左に向きます。

sub right()
	90度右に向きます。

sub forward($length)
	前に進みます。方向は、direcitonなどで指定します。

sub set_display()
	内部で使用しているメソッド。

sub MainLoop 
	Perl/TK のMainLoopを呼び出します。


=head1 AUTHOR

Shinji Kono, kono@ie.u-ryukyu.ac.jp

=head1 SEE ALSO

Perl/TK document

=cut
