package ATR::Tk::SexSymbol;

use strict;
use warnings;

use base 'Exporter';
our @EXPORT = qw(makeSex);

use Tk::Canvas;

# $Id: SexSymbol.pm,v 1.3 2005/01/13 16:44:36 mca Exp $

#----------------------------------------------------------------------------

=head1 UNICODE SEX SYMBOL

According to
http://aspn.activestate.com/ASPN/Mail/Message/perl-win32-users/2286304
we need to C<use Tk 804.027> in order to make Unicode text work in
labels etc..

I dont have that, but here's how to use it:

 use charnames ':full';
 $foo_frame->Label
    (-text => "male = \N{MALE SIGN} female = \N{FEMALE SIGN}",
     -font => "-Misc-Fixed-Medium-R-Normal--20-200-75-75-C-100-ISO10646-1)",
    )->pack;

or equivalently use \x{2642} and \x{2640} without the 'charnames'
module.

=head2 Make canvas containing require symbol

 use ATR::Tk::SexSymbol;
 my $widget = makeSex($frame, 'male', $pixelHeight);

=cut

sub makeSex {
    my ($parentWidget, $sex, $sizePxHeight, $showText) = @_;
    $sizePxHeight ||= 24;
    $showText ||= 0;

    my $size = $sizePxHeight / 7.6;
    my ($x, $y, $w, $h);
    my $colour;
    if ($sex eq 'female') {
	($x, $y) = ($size * 2.3, $size * 2.4);
	($w, $h) = ($size * 4.6, $size * 7.6);
	$colour = '#d1385f';
    } else {
	($x, $y) = ($size * 2.3, $size * 4.0);
	($w, $h) = ($size * 6.1, $size * 6.6);
	$colour = '#373bd0';
    }
    # Positions aren't exactly right
    # but you can't tell unless you zoom to size = 50

    my $canvas = $parentWidget->Canvas
      (
       -class => 'SexSymbol',
       -width => $w,
       -height => $h,
      );

    createSymbol($canvas, $sex,
		 $x, $y,
		 -scale => $size,
		 -dlabel => $showText,
		 -fg => $colour);
    return $canvas;
}

# These symbols are inconvenient 'cos they don't move with the widget location managers...
sub createSymbol {
    my ($canv, $type, $x, $y, %args) = @_;

    $args{-scale} ||= 5;
    $args{-dlabel} = 1 unless defined $args{-dlabel};
    my ($u, $txt) = delete @args{qw(-scale -dlabel)};
    my $fg = delete $args{-fg} || 'black';

    if ($type eq 'female') {
	$canv->createOval( $x - 2*$u, $y - 2*$u,
			   $x + 2*$u, $y + 2*$u,
			   -width => $u * 0.6,
			   -outline => $fg,
			   %args);
	$canv->createLine( $x, $y + 2*$u,
			   $x, $y + 5*$u,
			   -width => $u * 0.6,
			   -capstyle => 'round',
			   -fill => $fg,
			   %args);
	$canv->createLine( $x - $u, $y + 4*$u,
			   $x + $u, $y + 4*$u,
			   -width => $u * 0.6,
			   -capstyle => 'round',
			   -fill => $fg,
			   %args);
	$canv->createText($x, $y,
			  -justify => "center",
			  -text => "F",
			  -fg => $fg,
			  %args)
	  if $txt;
    } elsif ($type eq 'male') {
	my $rt2 = sqrt(2);

	$canv->createOval( $x - 2*$u, $y - 2*$u,
			   $x + 2*$u, $y + 2*$u,
			   -width => $u * 0.6,
			   -outline => $fg,
			   %args);
	my ($px, $py) = ($x + 5*$u/$rt2, $y - 5*$u/$rt2);
	$canv->createLine( $x + 2*$u/$rt2, $y - 2*$u/$rt2,
			   $px, $py,
			   -width => $u * 0.6,
			   -capstyle => 'round',
			   -fill => $fg,
			   %args);
	my $deg = 15;
	my $deg2rad = 2 * 3.1415926 / 360;
	$canv->createLine( $px - 2*$u*cos(15 * $deg2rad), $py + 2*$u*sin(15 * $deg2rad),
			   $px, $py,
			   $px - 2*$u*sin(15 * $deg2rad), $py + 2*$u*cos(15 * $deg2rad),
			   -width => $u * 0.6,
			   -capstyle => 'round',
			   -fill => $fg,
			   %args);
	$canv->createText($x, $y,
			  -justify => "center",
			  -text => "M",
			  -fg => $fg,
			  %args)
	  if $txt;
    } else {
	die "Unknown symbol type '$type'";
    }
}
