CAD::Drawing::IO::Tk - GUI I/O methods for CAD::Drawing

  (1) GNU General Public License
    (found at http://www.gnu.org/copyleft/gpl.html)
  (2) Artistic License
    (found at http://www.perl.com/pub/language/misc/Artistic.html)

  CAD::Drawing::IO
  Tk

  $drw->show(%options);

  $drw->Draw($cnv, %options);

  $drw->tkbindings($mw, $cnv);

  text_size_reset($cnv);

  free_dist();

  windowzoom($cnv);

  $drw->tksetview($cnv, %options);

  $scale = $drw->scalebox(\@size, \@ext);

  @xy_point = tkpoint(\@pt);

  my $tag = $drw->addr_to_tktag($addr);

  my $addr = $drw->tktag_to_addr($tag);

package CAD::Drawing::IO::Tk;
our $VERSION = '0.04';

use CAD::Drawing;
use CAD::Drawing::Defined;

use CAD::Calc qw(dist2d);

# with the new plug-in architecture, this seems odd to have a
# strictly-inherited module in the IO::* namespace (when this thing
# finally grows-up, maybe we use a GUI::* namespace?)

our $is_inherited = 1;


use vars qw(
	%dsp
	$textsize
	$text_base
	);

$text_base = 8;

use warnings;
use strict;
use Carp;

my %default = (
	width    => 800,
	height   => 600,
	zoom     => "fit",
	);

sub show {
	my $self = shift;
	my %options = @_;
	# XXX cannot do "use" or we get silly _TK_EXIT_(0) from everywhere!
	require Tk;
	require Tk::WorldCanvas;
	my $kidpid;
	if($options{forkokay}) {
		$SIG{CHILD} = 'IGNORE';
		if($kidpid = fork()) {
			return($kidpid);
		}
		defined($kidpid) or croak("cannot fork $!\n");
		$options{forkokay} = 0;
	}
	my $mw = $options{window};
	defined($mw) || ($mw = MainWindow->new());
	unless($options{size}) {
		foreach my $item ("width", "height") {
			my $val = $options{$item};
			$val || ($val = $default{$item});
			push(@{$options{size}}, $val);
		}
	}
	$options{bgcolor} || ($options{bgcolor} = "white");
	# FIXME: should have an indication of viewport number?
	$options{title} || ($options{title} = "Drawing");
	$mw->title($options{title});
	my ($w,$h) = @{$options{size}};
#    print "requesting $w x $h\n";
	my $cnv = $mw->WorldCanvas(
				'-bg' => $options{bgcolor},
				'-width' => $options{size}[0],
				'-height' => $options{size}[1],
				);
	# XXX scrolling when you want to wheelzoom is icky.  What's up with
	# that? (Tk::Canvas is a mess, that's what!)
	## print "bound to ", $cnv->bind('<4>'), "\n";
	$cnv->pack(-fill => 'both', -expand=>1);
	# XXX break this out into pieces
	my $stl;
	my %stl_conf = (
			-anchor => "sw",
			-width => $w,
			-justify=>"left",
			);
	my %stl_pack = (-fill => 'x', -expand=>0, -side => "bottom");
		
	unless($stl = $options{stl}) {
		$stl = $mw->Message(%stl_conf);
		$stl->pack(%stl_pack);
	}
	else {
		$stl->configure(%stl_conf);
		$stl->pack(%stl_pack);
	}
# FIXME: cannot just have a simplistic command line, it has to be powerful
#    my $cmd = $mw->Text(
#        -height=> 2,
#        -width => $w,
#        );
#    $cmd->pack(-fill => 'x', -expand=>0, -side => "bottom");
	# XXX $self here is a drawing, maybe that's not what we want...
	$self->tkbindings($mw, $cnv, $stl);
	$options{items} || ($options{items} = $self->select_addr({all=>1}));
	$self->Draw($cnv, %options);
	$cnv->viewAll();
	text_size_reset($cnv);
	if(defined($kidpid) or $options{hang}) {
	    $mw->MainLoop;
	}
	else {
		return($cnv);
	}
} # end subroutine show definition
########################################################################

sub Draw {
	my $self = shift;
	my $cnv = shift; 
	my %options = @_;
	my @list = @{$options{items}};
	foreach my $item (@list) {
		my $type = $item->{type};
#        print "item: $type\n";
		if($dsp{$type}) {
			my @tk_ids = $dsp{$type}->($self, $cnv, $item);
			if($options{tag}) {
				foreach my $tk_id (@tk_ids) {
					my $tagstring = $self->addr_to_tktag($item);
					$cnv->itemconfigure($tk_id, -tags => $tagstring);
				}
			}
		}
		else {
			carp "no function for $type\n";
		}
	}
	
} # end subroutine Draw definition
########################################################################

sub tkbindings {
	my $self = shift;
	my ($mw, $cnv, $stl) = @_;
	# FIXME: this should be much more robust

# maybe a vim-style modal binding? or possibly a command-line based
# system.
# just bind ":" to switch to the command bindings and <Esc> to go back
# to visual mode (and the end of every command must go to visual mode.)

	# this one basically means 'focusFollowsMouse', which is evil.
	# $mw->bind('<Any-Enter>' => sub{ $cnv->Tk::focus});

#    $mw->bind('<q>' => sub{$mw->destroy});
#    $cnv->CanvasBind('<q>' => sub{print "called\n";exit;});
	$mw->bind('<q>' => sub {$mw->destroy});

	# XXX move this...
	# middle-button pan:
	my @pan_start;
	my $drag_current;
	$cnv->CanvasBind(
		'<ButtonPress-2>' => sub {
			@pan_start = $cnv->eventLocation();
#            print "starting pan at @pan_start\n";
		});
	# have to have this here to prevent spurious panning with double-clicks
	$cnv->CanvasBind('<B2-Motion>' => sub {$drag_current = 1});
	$cnv->CanvasBind(
		'<ButtonRelease-2>' => sub {
			$drag_current || return();
			my @pan_stop = $cnv->eventLocation();
			my $scale = $cnv->pixelSize();
#            print "\tdouble: $isdouble\n";
#            print "\tdrag: $drag_current\n";
#            print "scale is $scale\n";
#            print "stopping pan at @pan_stop\n";
			my @diff = map({$pan_start[$_] - $pan_stop[$_]} 0,1);
#            my $panx = abs($diff[0])/$scale;
#            my $pany = abs($diff[1])/$scale;
#            print "pixels: ($panx,$pany)\n";
#            my $dopan = ( $panx > 10) | ( $pany > 10);
#            $dopan && print "panning by @diff\n";
#            $dopan && $cnv->panWorld(@diff);
			$cnv->panWorld(@diff);
			$drag_current = 0;
		});
	
	# OKAY, so we've got 4 zoom actions and we don't get text or images
	# for free.

	# this takes away all of our fun of having sizable texts (hmm. I
	# guess we could create this font from anywhere?)
	
	# XXX this is going to have some odd behaviour for now, but it isn't
	# worth trying to make a word-processor widget behave like scalable
	# text.
	$textsize = $text_base;
	$cnv->fontCreate(
			'cad-drawing-font',
			-family => 'lucidasans',
			-size   => $textsize,
			);
	text_size_reset($cnv);
#    print "view is @coords\n";
#    print "other configs:\n", 
#        join("\n", map({join(" ", @$_ )} $cnv->configure())), "\n";
#    print "width is: ", $cnv->cget(-width), "\n";
	
	# mouse-wheel zooming:
	$cnv->CanvasBind('<Button-4>' => sub{
				$cnv->zoom(1.125);
				text_size_reset($cnv);
				# print "$textsize\n";
				if(0) {
					package Tk::WorldCanvas;
					my $pdata = $cnv->privateData();
					print "pdata: $pdata\n";
					foreach my $key (keys(%$pdata)) {
						print "$key: $pdata->{$key}\n";
					}
					print "size is now $pdata->{width} x $pdata->{height}\n";
				}

			}
			);
	$cnv->CanvasBind('<Button-5>' => sub{
				$cnv->zoom(1/1.125);
				text_size_reset($cnv);
			}
			);
	# zoom extents:
	$cnv->CanvasBind('<Double-Button-2>' => sub{
				$cnv->viewAll();
				text_size_reset($cnv);
			}
			);
	# zoom window:
	$mw->bind(
		'<z>' => sub {
			$stl->configure(-text=>"Pick window corners");
			windowzoom($cnv, $stl);
			});
	# measure:
	$mw->bind(
		'<m>' => sub {
			$stl->configure(-text=>"Pick ends");
			free_dist($cnv, $stl);
			});


} # end subroutine tkbindings definition
########################################################################

sub text_size_reset {
	my $cnv = shift;
	my @c = $cnv->getView();
	my $width = $c[2] - $c[0];
	my $disp = $cnv->cget(-width);
	# print "showing $width in $disp\n";
	# print "scale is ", $disp / $width, "\n";
	$textsize = $text_base * $disp / $width;
	# print "textsize is $textsize\n";
	# XXX this is really getting to be a pain (too-large text causes slow-down)
	($textsize > 100) && ($textsize = 100);
	if($textsize >= 2) {
		## print "textsize: $textsize\n";
		$cnv->fontConfigure('cad-drawing-font', -size => $textsize);
	}
	else {
		$cnv->fontConfigure('cad-drawing-font', -size => 2);
	}


} # end subroutine text_size_reset definition
########################################################################

sub free_dist {
	my $cnv = shift;
	my $stl = shift;
	# this is crappy
	$cnv->CanvasBind(
		'<ButtonPress-1>' => sub {
			$cnv->rubberBand(0);
		});
	$cnv->CanvasBind(
		'<B1-Motion>' => sub {
			$cnv->rubberBand(1);
		});
	$cnv->CanvasBind(
		'<ButtonRelease-1>' => sub {
			my @box = $cnv->rubberBand(2);
			# print "box is @box\n";
			my $dist = dist2d([@box[0,1]],[@box[2,3]]);
			my $dx = $box[2] - $box[0];
			my $dy = $box[1] - $box[3];
			foreach my $item qw(
							<ButtonPress-1>
							<B1-Motion>
							<ButtonRelease-1>
							) {
				# print "item: $item\n";
				$cnv->CanvasBind($item => "");
			}
			$stl->configure(-text=>"$dist ($dx,$dy)");
			warn("measure: $dist ($dx,$dy)\n");
		});
} # end subroutine free_dist definition
########################################################################

sub windowzoom {
	my $cnv = shift;
	my $stl = shift;
	$cnv->CanvasBind(
		'<ButtonPress-1>' => sub {
			$cnv->rubberBand(0);
		});
	$cnv->CanvasBind(
		'<B1-Motion>' => sub {
			$cnv->rubberBand(1);
		});
	$cnv->CanvasBind(
		'<ButtonRelease-1>' => sub {
			my @box = $cnv->rubberBand(2);
			#print "box is @box\n";
			$cnv->viewArea(@box);
			text_size_reset($cnv);
			foreach my $item qw(
							<ButtonPress-1>
							<B1-Motion>
							<ButtonRelease-1>
							) {
				# print "item: $item\n";
				$cnv->CanvasBind($item => "");
			}
			$stl->configure(-text=>"");
		});
} # end subroutine windowzoom definition
########################################################################

sub tksetview {
	my $self = shift;
	my $cnv = shift;
	my %options = @_;
	my $width = $options{size}[0];
	my $height = $options{size}[1];
	my @ext = $self->OrthExtents($options{items});
	print "got extents: ", 
		join(" by ", map({join(" to ", @$_)} @ext)), "\n";
	my @cent = map({($_->[0] + $_->[1]) / 2} @ext);
	$options{center} && (@cent = @{$options{center}});
	print "center is @cent\n";
	my $scale = $options{scale};
	unless($scale) {
		$scale = $self->scalebox($options{size}, \@ext);
#        print "got scale: $scale\n";
	}
	$cnv->scale('all'=> 0,0 , $scale, $scale);
	my $bbox = $options{bbox};
	$_ *= $scale for @$bbox;
#    print "bbox now: @$bbox\n";
	$cnv->configure(-scrollregion=> $bbox);
#    my $xv = $ext[0][0] * $scale / $bbox->[2];
	my $xv = ($ext[0][0] * $scale - $bbox->[0]) / 
				($bbox->[2] - $bbox->[0]);
##    my $xv = ($width / 2 - $bbox->[0]) /
##                ($bbox->[2] - $bbox->[0]);

	print "xview: $xv\n";
	$cnv->xviewMoveto($xv);
	my (undef(), $yv) = tkpoint([0,$ext[1][0]]); 
	print "ypt: $yv\n";
	print "ext top: $ext[1][1] bottom: $ext[1][0]\n";
	print "bbox (t&b): $bbox->[1] $bbox->[3]\n";
	$yv = (-$ext[1][0] * $scale + $bbox->[3] - $height / 2) / 
				($bbox->[3] - $bbox->[1]);
	print "yview: $yv\n";
	$cnv->yviewMoveto($yv);
} # end subroutine tksetview definition
########################################################################

sub scalebox {
	my $self = shift;
	my ($size, $ext) = @_;
	my ($ew, $eh) = map({abs($_->[0] - $_->[1])} @$ext);
	my $dx = $size->[0] / $ew;
	my $dy = $size->[1] / $eh;
#    print "factors: $dx $dy\n";
	my $scale = [$dx => $dy] -> [$dy <= $dx];
	return($scale);
} # end subroutine scalebox definition
########################################################################

%dsp = (
	lines => sub {
		my ($self, $cnv, $addr) = @_;
		my $arrow = "none";
		$CAD::Drawing::IO::Tk::arrow && ($arrow = "last");
		my $obj = $self->getobj($addr);
		my $line = $cnv->createLine(
						map({tkpoint($_)} 
							@{$obj->{pts}},
							),
						# '-dash' => "",
						# '-activedash' => ",",
						# '-activefill' => "#ff0000",
						'-fill'=> $aci2hex[$obj->{color}],
						'-arrow' => $arrow,
						);
#        print "line item: $line (ref: ", ref($line), ")\n";
		# my @list = $cnv->itemconfigure($line);
		# foreach my $deal (@list) {
		#	print "got deal: @$deal\n";
		#}
		return($line);
	}, # end sub $dsp{lines}
	plines => sub {
		my ($self, $cnv, $addr) = @_;
		my $arrow = "none";
		$CAD::Drawing::IO::Tk::arrow && ($arrow = "last");
		my $obj = $self->getobj($addr);
		my $st = $obj->{closed} ? -1 : 0;
		my @ids;
		for(my $i = $st; $i < scalar(@{$obj->{pts}}) -1; $i++) {
			my @pts = map({tkpoint($_)}
						$obj->{pts}[$i], $obj->{pts}[$i+1],
						);
			# print "adding @pts ($i -> ", $i+1, ")\n";
			my $pline = $cnv->createLine(
						@pts,
						'-fill' => $aci2hex[$obj->{color}],
						'-arrow' => $arrow,
						);
#            print "pline item: $pline\n";
			push(@ids, $pline);
		}
		return(@ids);
	}, # end sub $dsp{plines}
	arcs => sub {
		my ($self, $cnv, $addr) = @_;
		my $obj = $self->getobj($addr);
#        print "keys: ", join(" ", keys(%$obj)), "\n";
		my $rad = $obj->{rad};
		my @pt = tkpoint($obj->{pt});
		# stupid graphics packages:
		my @rec = (
			map({$_ - $rad} @pt),
			map({$_ + $rad} @pt),
			);
		my @angs = @{$obj->{angs}};
		# stupid graphics packages:
		@angs = map({$_ * 180 / $pi} @angs);
		$angs[1] = $angs[1] - $angs[0];
		$angs[1] += 360;
		while($angs[1] > 360) {
			$angs[1] -= 360;
		}
		my $arc =  $cnv->createArc(
					@rec,
					'-start'  => $angs[0],
					'-extent' => $angs[1],
					'-outline' => $aci2hex[$obj->{color}],
					'-style' => "arc",
					);
		return($arc);
	}, # end sub $dsp{arcs}
	circles => sub {
		my ($self, $cnv, $addr) = @_;
		my $obj = $self->getobj($addr);
		my $rad = $obj->{rad};
		my @pt = tkpoint($obj->{pt});
		# stupid graphics packages:
		my @rec = (
			map({$_ - $rad} @pt),
			map({$_ + $rad} @pt),
			);
		my $circ = $cnv->createOval(
					@rec,
					'-outline' => $aci2hex[$obj->{color}],
					);
		return($circ);
	}, # end sub $dsp{circles}
	texts => sub {
		my ($self, $cnv, $addr) = @_;
		my $obj = $self->getobj($addr);
		my @pt = tkpoint($obj->{pt});
		my $height = $obj->{height};
		my $string = $obj->{string};
		my @text;
		# FIXME: if tk doesn't get its act together, this becomes kludge:
		if($obj->{render}) {
			die "this is broken";
		}
		else {
			@text = $cnv->createText(
						@pt,
						-font => "cad-drawing-font", #
						-anchor => "sw",
						-text => $string,
						-fill => $aci2hex[$obj->{color}],
						);
		}
		return(@text);
	}, # end sub $dsp{texts}
		
); # end %dsp coderef hash
########################################################################

sub tkpoint {
	return($_[0]->[0], $_[0]->[1]);
} # end subroutine tkpoint definition
########################################################################

sub addr_to_tktag {
	my $self = shift;
	my $addr = shift;
	return(join("###", $addr->{layer}, $addr->{type}, $addr->{id}));
} # end subroutine addr_to_tktag definition
########################################################################

sub tktag_to_addr {
	my $self = shift;
	my $tag = shift;
	my @these = split(/###/, $tag);
	(@these == 3) or croak("parsing tag failed! ($tag)\n");
	my @order = qw(layer type id);
	return({map({$order[$_] => $these[$_]} 0..2)});
} # end subroutine tktag_to_addr definition
########################################################################

1;