#!perl -w
#______________________________________________________________________
# Geometric operations
# PhilipRBrenan@yahooo.com, 2003.
#______________________________________________________________________

my $VERSION = 1.2;

=head1 NAME

Geops - draw geometric figures using compass and straight edge only.

=head1 DESCRIPTION

Geometric constructions using compass and straight-edge only.
The right mouse button draws circles.
The left mouse button draws straight lines.
The center mousewheel zooms in and out.

Press z to undo.
Press r to redo.
Press x to expand
Press c to contract

Double click left for more options

Try drawing:

One line parallel to another
Lines at 30, 60, 90 degrees to another
An Isoscelese triangle
An equilateral triangle
A square
A hexagon
A pentagon
A circle through three non colinear points

Try drawing diagrams that demonstrate:

The theorem of pythagoras
cos(a+b)
sin(a+b)
Shearing a triangle does not change its area
the diagonals of a rhombus meet at 90.
Angle doubling in a circle
Right triangle in semi-circle
Bisection of a circle

Given a triangle, draw a circle:
 - through the triangle's vertices
 - tangentially touching the sides of the triangle,
   with the center inside the triangle
 - tangentially touching the sides of the triangle with
   the center of the circle outside the triangle, and
   two sides of the triangle extended into lines.

=head1 README

Draw geometric figures using compass and straight edge only.

=head1 PREREQUISITES

C<Tk>

  sudo apt install libx11-dev

=head1 COREQUISITES

=pod OSNAMES

any

=pod SCRIPT CATEGORIES

Educational

=cut
#______________________________________________________________________
# Packages
#______________________________________________________________________

use Tk;
use Tk::Balloon;

#______________________________________________________________________
# Line manipulation
# PhilipRBrenan@yahoo.com, Novosoft Inc., 2003
#______________________________________________________________________

package line;
use Carp;

#______________________________________________________________________
# Create a line
# A line is characterized by the two points through which it passes
#______________________________________________________________________

sub new($$$$)
 {my $l = bless {};   # line

  my $sx = shift;     # X point 1
  my $sy = shift;     # Y point 1
  my $fx = shift;     # X point 2
  my $fy = shift;     # Y point 2

  my $dx = ($fx-$sx); # Delta X
  my $dy = ($fy-$sy); # Delta Y

  $l->{sx} = $sx;
  $l->{sy} = $sy;
  $l->{fx} = $fx;
  $l->{fy} = $fy;
  $l->{dx} = $dx;
  $l->{dy} = $dy;

  croak "Bad line defined" if $dx == 0  and $dy == 0;
  return $l;
 }

#______________________________________________________________________
# Intersect with box - find the points where a line crosses a box
#______________________________________________________________________

sub intersectWithBox($$$$$)
 {my $l   = shift; # line
  my $bx1 = shift; # Lower left  X of box
  my $by1 = shift; # Lower right Y of box
  my $bx2 = shift; # Lower left  X of box
  my $by2 = shift; # Lower right Y of box

  my ($sx, $sy, $fx, $fy, $dx, $dy) = @$l{qw(sx sy fx fy dx dy)};

  my ($i, @i);

#______________________________________________________________________
# Special cases
#______________________________________________________________________

# Points too close

  return undef if abs($dx) <= 1 and abs($dy) <= 1;

# Vertical line

  return ($sx, $by1, $sx, $by2) if abs($dx) <= 1;

# Horizontal line

  return ($bx1, $sy, $bx2, $sy) if abs($dy) <= 1;

#______________________________________________________________________
# Intersection with each line bounding the box
#______________________________________________________________________

# Lower

  $i = $sx-$dx*($sy-$by1)/$dy;
  push @i, ($i, $by1) if $i >= $bx1 and $i <= $bx2;

# Upper

  $i = $sx-$dx*($sy-$by2)/$dy;
  push @i, ($i, $by2) if $i >= $bx1 and $i <= $bx2;
  return @i if scalar(@i) == 4;

# Right

  $i = $sy-$dy*($sx-$bx2)/$dx;
  push @i, ($bx2, $i) if $i >= $by1 and $i <= $by2;
  return @i if scalar(@i) == 4;

# Left

  $i = $sy-$dy*($sx-$bx1)/$dx;
  push @i, ($bx1, $i) if $i >= $by1 and $i <= $by2;

  return @i;
 }

#______________________________________________________________________
# Determinant
#______________________________________________________________________

sub determinant($$$$)
 {my ($x1, $y1, $x2, $y2) = @_;
  return ($x1*$y2 - $x2*$y1);
 }

#______________________________________________________________________
# Intersection of two lines
#______________________________________________________________________

sub intersection(@)
 {my ($p10, $p11, $p20, $p21, $p30, $p31, $p40, $p41) = @_;
  my $n = determinant($p30-$p10, $p30-$p40, $p31-$p11, $p31-$p41);
  my $d = determinant($p20-$p10, $p30-$p40, $p21-$p11, $p31-$p41);

  return undef if abs($d) < 1;

  return ($p10 + $n/$d * ($p20 - $p10),
          $p11 + $n/$d * ($p21 - $p11));
 }

#______________________________________________________________________
# Point on a line closest to a point
# P1, P2 line, P3 point
#______________________________________________________________________

sub pointOnLineClosestToPoint(@)
 {my ($p10, $p11, $p20, $p21, $p30, $p31) = @_;

  my $p40 = $p30 + $p21 - $p11; # Second point of line through P3
  my $p41 = $p31 - $p20 + $p10; # at right angles to line through P1, P2

  return intersection($p10, $p11, $p20, $p21, $p30, $p31, $p40, $p41);
}

#______________________________________________________________________
# Unit vector along a line
#______________________________________________________________________

sub unitVectorAlongLine(@)
 {my ($p10, $p11, $p20, $p21) = @_;

  my ($x, $y) = (($p10-$p20), ($p11-$p21));
  return undef if $x == 0 and $y == 0;

  my $d = sqrt($x*$x+$y*$y);
  return ($x/$d, $y/$d);
 }

#______________________________________________________________________
# Package loaded successfully
#______________________________________________________________________

1;

#______________________________________________________________________
# Display a dialog for selection of line thickness and dash pattern
# PhilipRBrenan@yahooo.com, 2003.
#______________________________________________________________________

package lineStyle;

sub new($@)
 {my $m = shift;  # Main Window
  my %p = (-selected=>'green', -unselected=>'white', -flash=>'red', -entered=>'pink', -background=>'white',
           -line=>'blue', -widths=>[1..5], -dash=>['', qw(. - -. -..)], -height=>20, -width=>40, @_);
  my @w = (@{$p{'-widths'}});
  my @lineDraw = (5, $p{'-height'}/2+2, $p{'-width'}-2, $p{'-height'}/2+2);
  my @dash  = @{$p{'-dash'}};
  my $dash  = 1;
  my $width = 1;
  my @cdash = ();
  my @cline = ();
  my $row   = 1;
  my $n = scalar(@w); $n = scalar(@dash) if scalar(@dash) > $n;

  my $dw = $m->LabFrame(-label=>'Line types', -labelside=>'acrosstop')->pack();
  my $l1 = $dw->Label(-text=>'Width')->grid(-column=>1, -row=>$row);
  my $l2 = $dw->Label(-text=>'Style')->grid(-column=>2, -row=>$row);
  ++$row;

# Line width

  for(my $i = 0; $i < $n; ++$i)
   {if (defined($w[$i]))
     {my $c;
      my $enter = sub($$)
       {my $c = shift;
        my $i = shift;
        $c->configure(-background=>$p{'-entered'}) unless $i == $width;
       };

      my $leave = sub($$)
       {my $c = shift;
        my $i = shift;
        $c->configure(-background=>$p{'-unselected'}) unless $i == $width;
       };

      my $press = sub($$)
       {my $c = shift;
        my $i = shift;
        $c->configure(-background=>$p{'-flash'});
       };

      my $release = sub($$)
       {my $c = shift;
        my $i = shift;
        $width = $i;
        for(my $j = 0; $j < $n; ++$j)
         {$cline[$j]->configure(-background=>$p{'-unselected'});
         }
        $c->configure(-background=>$p{'-selected'});
        ${$p{'-widthVar'}} = $w[$width] if defined $p{'-widthVar'};
       };

      $cline[$i] = $c = $dw->Canvas(-height=>$p{'-height'}, -width=>$p{'-width'},
        -background=>$p{'-background'})->grid(-column=>1, -row=>$row);
      $c->configure(-background=>$p{'-selected'}) if defined($p{'-widthVar'}) and $w[$i] == ${$p{'-widthVar'}};
      $c->createLine(@lineDraw, -fill=>$p{'-line'}, -width=>$w[$i]);
      $c->CanvasBind("<ButtonRelease-1>", [$release, $i]);
      $c->CanvasBind("<ButtonPress-1>",   [$press,   $i]);
      $c->CanvasBind("<Enter>",           [$enter,   $i]);
      $c->CanvasBind("<Leave>",           [$leave,   $i]);
     }

# Line dash style

    my $d = $dash[$i];
    if (defined($d))
     {my $c;
      my $enter = sub($$)
       {my $c = shift;
        my $i = shift;
        $c->configure(-background=>$p{'-entered'}) unless $i == $dash;
       };

      my $leave = sub($$)
       {my $c = shift;
        my $i = shift;
        unless($i == $dash)
         {$c->configure(-background=>$p{'-unselected'});
         }
       };

      my $press = sub($$)
       {my $c = shift;
        my $i = shift;
        $c->configure(-background=>$p{'-flash'});
       };

      my $release = sub($$)
       {my $c = shift;
        my $i = shift;
        $dash = $i;
        for(my $j = 0; $j < $n; ++$j)
         {$cdash[$j]->configure(-background=>$p{'-unselected'});
         }
        $c->configure(-background=>$p{'-selected'});
        ${$p{'-dashVar'}} = $dash[$dash] if defined $p{'-dashVar'};
       };

      $cdash[$i] = $c = $dw->Canvas(-height=>$p{'-height'}, -width=>$p{'-width'},
        -background=>$p{'-background'})->grid(-column=>2, -row=>$row);
      $c->configure(-background=>$p{'-selected'}) if defined($p{'-dashVar'}) and $dash[$i] eq ${$p{'-dashVar'}};
      $c->createLine(@lineDraw, -fill=>$p{'-line'}, -dash=>$dash[$i], -width=>$i);
      $c->CanvasBind("<ButtonRelease-1>", [$release, $i]);
      $c->CanvasBind("<ButtonPress-1>",   [$press,   $i]);
      $c->CanvasBind("<Enter>",           [$enter,   $i]);
      $c->CanvasBind("<Leave>",           [$leave,   $i]);
     }
    ++$row;
   }
  return $dw;
 }

#______________________________________________________________________
# Package loaded successfully
#______________________________________________________________________

1;

#______________________________________________________________________
# Get/Set
# PhilipRBrenan@yahooo.com, 2003.
#______________________________________________________________________

package gs;
use Carp;
#use Strict;

sub new()
 {return bless {};
 }

#______________________________________________________________________
# Get - retrieve values of global importance
#______________________________________________________________________

sub get($@)
 {my $g = shift;
  my @p = @_;
  return $g->{$p[0]}                     if scalar(@p) == 1;
  return $g->{$p[0]}->{$p[1]}            if scalar(@p) == 2;
  return $g->{$p[0]}->{$p[1]}->{$p[2]}   if scalar(@p) == 3;
  die "geo::get: Wrong number of parameters";
 }

#______________________________________________________________________
# Set - record values of global importance
#______________________________________________________________________

sub set($@)
 {my $g = shift;
  my @p = @_;
  return $g->{$p[0]} = $p[1]                    if scalar(@p) == 2;
  return $g->{$p[0]}->{$p[1]} = $p[2]           if scalar(@p) == 3;
  return $g->{$p[0]}->{$p[1]}->{$p[2]} = $p[3]  if scalar(@p) == 4;
  die "geo::set: Wrong number of parameters";
 }

#______________________________________________________________________
# Main
#______________________________________________________________________

package main;

print << 'END';

GEOPS: PhilipRBrenan@yahoo.com, 2003-2004

Geometric constructions using compass and straight-edge only.
The right mouse button draws circles.
The left mouse button draws straight lines.
The center mousewheel zooms in and out.

Press z to undo.
Press r to redo.
Press x to expand
Press c to contract

Double click left for more options

Try drawing:

One line parallel to another
Lines at 30, 60, 90 degrees to another
An Isoscelese triangle
An equilateral triangle
A square
A hexagon
A pentagon
A circle through three non colinear points

Try drawing diagrams that demonstrate:

The theorem of pythagoras
cos(a+b)
sin(a+b)
Shearing a triangle does not change its area
the diagonals of a rhombus meet at 90.
Angle doubling in a circle
Right triangle in semi-circle
Bisection of a circle
Given a triangle, draw a circle:
 - through the triangle's vertices
 - tangentially touching the sides of the triangle,
   with the center inside the triangle
 - tangentially touching the sides of the triangle with
   the center of the circle outside the triangle, and
   two sides of the triangle extended into lines.
END


#______________________________________________________________________
# Get X, Y coords of mouse.  Round to nearest object if we are close
#______________________________________________________________________

sub getXYFromEvent($)
 {my $w = shift;
  my $e = $w->XEvent;
  my ($x, $y) = areWeNearAnything(($c->canvasx($e->x), $c->canvasy($e->y)));
  return ($x, $y, $e->b);
 }

#______________________________________________________________________
# Button press - record mouse position and start new object
#______________________________________________________________________

sub buttonPress($)
 {($bx, $by) = getXYFromEvent(shift());

  $c->createOval($bx-$ps, $by-$ps, $bx+$ps, $by+$ps, -tags=>'startPoint', -fill=>'red');

# Undo / redo capability

  if (defined($objoff) and $objoff < scalar(@obj))
   {my @d = splice @obj, $objoff;
    for my $o(@d)
     {$c->delete($o->{tag}) if defined $o->{tag};
     }
    $objoff = undef;
   }
 }

#______________________________________________________________________
# Button release - finish new object unless back where we started
#______________________________________________________________________

sub buttonRelease($)
 {my ($x, $y, $b) = getXYFromEvent(shift());

  $c->delete('startPoint');

# Finish drawing line

  if ($b == 1)
   {$c->delete('currentLine');
    my $h = abs($y-$by) < $pc; $y = $by if $h;
    my $v = abs($x-$bx) < $pc; $x = $bx if $v;

   unless (($x-$bx)**2+($y-$by)**2 < $ps*$ps)
     {my $t = $c->createLine($bx, $by, $x, $y, -tags=>[$drawColor, 'line'],
      -fill =>$drawColor, -activefill =>'blue',        -disabledfill =>'yellow',
      -width=>$drawWidth, -activewidth=>$drawWidth+1,  -disabledwidth=>$drawWidth,
      -dash =>$drawDash);

      my $o = {type=>'line', vertical=>$v, horizontal=>$h, tag=>$t};
      push @obj, ({type=>'commit'}, $o);
      findIntersections($o);
     }
   }

# Finish drawing circle

  elsif ($b == 3)
   {$c->delete('currentCircle');

    my $r = sqrt(($x-$bx)**2+($y-$by)**2);
    unless ($r < $ps)
     {my $t1 = $c->createOval($bx-$r, $by-$r, $bx+$r, $by+$r, -tags=>[$drawColor, 'circle'],
      -outline=>$drawColor, -activeoutline=>'blue',     -disabledoutline=>'yellow',
      -width  =>$drawWidth, -activewidth=>$drawWidth+1, -disabledwidth=>$drawWidth,
      -dash   =>$drawDash);

      my $t2 = drawPoint($bx, $by, ["circleCenter$t1"]);

      my $o1 = {type=>'circle', tag=>$t1};
      my $o2 = {%$t2, centerOfCircle=>$t1};
      push @obj, ({type=>'commit'}, $o1, $o2);
      findIntersections($o1);
     }
   }
  $c->raise('point');
 }

#______________________________________________________________________
# Button 1 motion - draw line
#______________________________________________________________________

sub button1Motion($)
 {my ($x, $y) = getXYFromEvent(shift());

  return if configureStartPoint($x, $y);

  my $h = abs($y-$by) < $pc; $y = $by if $h;
  my $v = abs($x-$bx) < $pc; $x = $bx if $v;

  $c->delete('currentLine');

  my @i   = ($bx, $by, $x, $y);
  $c->createLine(@i, -width=>$drawWidth, -tags=>'currentLine', -fill =>'blue', -width=>$drawWidth+1);
 }

#______________________________________________________________________
# Button 2 motion - pan
#______________________________________________________________________

sub button2Motion($)
 {my ($x, $y) = getXYFromEvent(shift());
  $c->move('all', $x-$bx, $y-$by);
  $c->move('startPoint', $bx-$x, $by-$y);
  ($bx, $by) = ($x, $y);
 }

#______________________________________________________________________
# Button 3 motion - draw circle
#______________________________________________________________________

sub button3Motion($)
 {my ($x, $y) = getXYFromEvent(shift());

  return if configureStartPoint($x, $y);

  my $r = sqrt(($x-$bx)**2+($y-$by)**2);

  $c->delete('currentCircle');

  $c->createOval($bx-$r, $by-$r, $bx+$r, $by+$r, -tags=>'currentCircle',
    -outline=>'blue', -width  =>$drawWidth+1);
 }

#______________________________________________________________________
# Zoom in or out on mouse wheel
#______________________________________________________________________

sub mouseWheel($)
 {my $e = shift;
  my $w = $e->XEvent;
  my ($x, $y, $d) = ($w->x, $w->y, $w->D);
  my ($cx, $cy)   = ($c->canvasx($x), $c->canvasy($y));

  my ($xv1, $xv2) = $c->xview;
  my ($yv1, $yv2) = $c->yview;

  if ($d > 0)   # Zoom out
   {$c->scale('all', $x, $y, 4/5, 4/5);
    my $fx = $xv1 - $cx/5/4/$g->get(qw(display x)); $fx = 0 if $fx < 0;
    my $fy = $yv1 - $cy/5/4/$g->get(qw(display y)); $fy = 0 if $fy < 0;
    $c->xviewMoveto($fx);
    $c->yviewMoveto($fy);
   }
  else          # Zoom in
   {$c->scale('all', $x, $y, 5/4, 5/4);
    my $fx = $xv1 + $cx/$g->get(qw(display x)); $fx = 1 if $fx > 1;
    my $fy = $yv1 + $cy/$g->get(qw(display y)); $fy = 1 if $fy > 1;
    $c->xviewMoveto($fx);
    $c->yviewMoveto($fy);
   }

  redrawAllPoints();
 }

sub contract($)
 {my $e = shift;
  my $w = $e->XEvent;
  my ($x, $y, $d) = ($w->x, $w->y, $w->D);
  my ($cx, $cy)   = ($c->canvasx($x), $c->canvasy($y));

  my ($xv1, $xv2) = $c->xview;
  my ($yv1, $yv2) = $c->yview;
  $c->scale('all', $x, $y, 4/5, 4/5);
  my $fx = $xv1 - $cx/5/4/$g->get(qw(display x)); $fx = 0 if $fx < 0;
  my $fy = $yv1 - $cy/5/4/$g->get(qw(display y)); $fy = 0 if $fy < 0;
  $c->xviewMoveto($fx);
  $c->yviewMoveto($fy);

  redrawAllPoints();
 }

sub expand($)
 {my $e = shift;

  my $w = $e->XEvent;
  my ($x, $y, $d) = ($w->x, $w->y, $w->D);
  my ($cx, $cy)   = ($c->canvasx($x), $c->canvasy($y));

  my ($xv1, $xv2) = $c->xview;
  my ($yv1, $yv2) = $c->yview;

  $c->scale('all', $x, $y, 5/4, 5/4);
  my $fx = $xv1 + $cx/$g->get(qw(display x)); $fx = 1 if $fx > 1;
  my $fy = $yv1 + $cy/$g->get(qw(display y)); $fy = 1 if $fy > 1;
  $c->xviewMoveto($fx);
  $c->yviewMoveto($fy);

  redrawAllPoints();
 }

#______________________________________________________________________
# Double Click - show actions dialog
#______________________________________________________________________

sub doubleButtonPress1Point($$)
 {my $c   = shift();                 # Canvas press took place on
  my $t   = shift();                 # Tag of point selected
  my $lastTag  = $t;                 # Last tag selected
  my $startTag = $t;                 # Starting tag
  my $cl  = $c->itemcget($t, -fill=>);
  my $row = 0;                       # Grid row for next button
  my %ba  = qw(-anchor w -width 8);  # Default button attributes
  my %ga  = qw(-sticky w);           # Default button attributes
  my %cb  = ();                      # Hash of check buttons

# Dialog main window

  if (defined($mm))
   {$mm->raise();
    return;
   }

  $mm = MainWindow->new();
  $mm->title($g->get(qw(display title)));
  $mm->OnDestroy(sub {$mm = undef});

#______________________________________________________________________
# Color select
#______________________________________________________________________

  my $pm = $mm->LabFrame(-label=>'Color', -labelside=>'acrosstop')
   ->grid(-column=>1, -row=>1);
  $balloon->attach($pm, -msg=>"Choose the color you wish to draw in.\nYou can show or hide selected colors.");

  my $showInColor = sub ($)
   {my $r = shift; # Color that changed state

    my @t = $c->find(withtag=>'all');
    for my $t(@t)
     {my $l = colorFromTag($t);
      my $s = 'hidden';
         $s = 'normal' if $showColor->{$r} == 1;
      $c->itemconfigure($t, -state=>$s) if $l eq $r;
     }
   };

  my $changeColors = sub ()
   {my @t = $c->find(withtag=>'QED');
    for my $t(@t)
     {my $type = $c->type($t);
      $c->itemconfigure($t, -fill   =>$drawColor) if $type eq 'line';
      $c->itemconfigure($t, -outline=>$drawColor) if $type eq 'oval';
      $showColor->{$drawColor} = 1;
      &$showInColor($drawColor);
     }
    $cb{$drawColor}->select();
   };

  my $showColors = sub($)
   {my $l = shift; # Color that changed state
    &$showInColor($l);
   };

  my $t1 = $pm->Label(-text=>'Draw', -anchor=>'w')->grid(-column=>1, -row=>++$row, -sticky=>'w');
  my $t2 = $pm->Label(-text=>'Show', -anchor=>'e')->grid(-column=>2, -row=>  $row);

  for my $color(@drawColor)
   {my $bcolor = $color; $bcolor = 'white' if $color eq 'black';
    my $rb = $pm->Radiobutton(
       -text       => $color,
       -background => $bcolor,
       -selectcolor=> $bcolor,
       -variable   => \$drawColor,
       -value      => $color,
       -anchor     => 'w',
       -command    => $changeColors,
       )->grid(-column=>1, -row=>++$row, -sticky=>'we');

    my $cb = $pm->Checkbutton(
 #     -text       => $color,
       -background => $bcolor,
       -selectcolor=> $bcolor,
       -variable   => \$showColor->{$color},
       -anchor     => 'center',
       -command    => [$showColors, $color],
       )->grid(-column=>2, -row=>$row, -sticky=>'we');

    $cb{$color} = $cb;
    $balloon->attach($rb, -msg=>"Draw in $color.");
    $balloon->attach($cb, -msg=>"Show or hide $color.");
   }

#______________________________________________________________________
# Line style select
#______________________________________________________________________

  my $lm = $mm->lineStyle::new(-selected=>'green', -flash=>'red', -entered=>'pink', -unselected=>'white',
      -background=>'white', -line=>'blue', -widthVar=>\$drawWidth, -dashVar=>\$drawDash,
      -widths=>[1..5], -dash=>['', qw(. - -. -..)], -height=>20, -width=>50)
    ->grid(-column=>1, -row=>2);

#______________________________________________________________________
# Files
#______________________________________________________________________

  my $print = sub
   {my $f = $m->getSaveFile(-defaultextension=>'.jpg', #-filetypes=>['JPG files', ['.jpg']],
                             -title=>'Choose a file to write the image to');

    $c->itemconfigure('point', -state=>'hidden');
    $c->postscript(-file=>"zzz.ps");
    $c->itemconfigure('point', -state=>'normal');
    my $cmd = $gs;
    $cmd =~ s/XXX/$f/;
    `$cmd`;
    $m->messageBox(-message=>"Image written to $f", -title=>'Success!', -type=>'OK');
   };

  my $new  = sub {print "New not implemented yet\n"};
  my $save = sub {print "Save not implemented yet\n"};


  my $fm = $mm->LabFrame(-label=>'Files', -labelside=>'acrosstop')->grid(-column=>1, -row=>3);
  my $pb = $fm->Button(-text=>'Print', -command=>$print)->grid(-column=>1, -row=>1);
  my $nb = $fm->Button(-text=>'New',   -command=>$new)  ->grid(-column=>2, -row=>1);
  my $sb = $fm->Button(-text=>'Save',  -command=>$save) ->grid(-column=>3, -row=>1);

  $balloon->attach($pb, -msg=>"Create JPEG");
  $balloon->attach($nb, -msg=>"New file to contain data");
  $balloon->attach($sb, -msg=>"Save data to file");
 }

#______________________________________________________________________
# Are we near anything - check how close a point is to known objects
# This could be improved by using $c->bbox
#______________________________________________________________________

sub areWeNearAnything($$)
 {my $x = shift; # X position
  my $y = shift; # Y position
  my $n = $pc;

  for my $o(@obj)
   {if ($o->{type} eq 'point' and !defined($o->{reuse}))
     {my ($cx, $cy) = coordsOfPoint($o->{tag});
      my $d = ($x-$cx)**2+($y-$cy)**2; # Squared distance to center
      return ($cx, $cy) if $d < $n*$n; # Substitute center of circle
     }
   }
  return ($x, $y);
 }

#______________________________________________________________________
# findIntersections - last object added with existing objects
#______________________________________________________________________

sub findIntersections($)
 {return unless scalar(@obj) > 0;   # No intersections yet

  my $a = shift;
   {my %a = %$a;
    next unless $a{type} eq 'line' or $a{type} eq 'circle';

    for my $o(@obj)
     {my %o = %$o;
      next unless $o{type} eq 'line' or $o{type} eq 'circle';
      next unless colorFromTag($o{tag}) eq colorFromTag($a{tag});

#______________________________________________________________________
# Intersect circle and circle
# r,R: Radii of circles.
# D:   Distance between centers.
# d:   Half of major axis of chord of intersection
# e:   Distance to chord from one center
# T:   Angle of line drawn through centers to horizontal.
# t:   Half angle subtended by 'd' from center of one circle
# sin(a+b) = sin(a)cos(b)+cos(a)sin(b)
# sin(a-b) = sin(a)cos(b)-cos(a)sin(b)
# cos(a+b) = cos(a)cos(b)-sin(a)sin(b)
# cos(a-b) = cos(a)cos(b)+sin(a)sin(b)
#______________________________________________________________________

      if ($a{type} eq 'circle' and $o{type} eq 'circle')
       {my $r         = radiusOfCircle($a);
        my $R         = radiusOfCircle($o);
        my ($cx, $cy) = centerOfCircle($a);
        my ($Cx, $Cy) = centerOfCircle($o);
        my $D = sqrt(($cx-$Cx)**2+($cy-$Cy)**2); # Distance between two centers
        next if $D > $R+$r;                      # Too far apart to intersect
        next if $D < $ps;                        # Too close to intersect

        my $dd = $R*$R - ($R*$R-$r*$r+$D*$D)**2/(4*$D*$D); # Half chord width squared
        my $d = sqrt(abs($dd));                  # Half chord width
        my $e = sqrt($r*$r - $dd);               # Distance to half chord from center of circle
        my $cosT = ($Cx-$cx) / $D;               # cos(T)
        my $sinT = ($Cy-$cy) / $D;               # sin(T)
        my $sint = $d/$r;
        my $cost = $e/$r;

        my $sinTpt = $sinT*$cost+$cosT*$sint;
        my $cosTpt = $cosT*$cost-$sinT*$sint;
        my $sinTmt = $sinT*$cost-$cosT*$sint;
        my $cosTmt = $cosT*$cost+$sinT*$sint;

        my @i = ([$cx+$cosTpt*$r, $cy+$sinTpt*$r],
                 [$cx+$cosTmt*$r, $cy+$sinTmt*$r]);

        for my $i(@i)
         {my ($x, $y) = @$i;
          my $t = drawPoint($x, $y, ["intersectCircle$a{tag}Circle$o{tag}"]);
          push @obj, {%$t, intersectCircles=>[$a, $o]};
         }
       }

#______________________________________________________________________
# Intersect line and line
#______________________________________________________________________

      if ($a{type} eq 'line' and $o{type} eq 'line')
       {my @a = coordsOfLine($a);
        my @o = coordsOfLine($o);
        my ($x, $y) = line::intersection(@a, @o);
        next unless defined $x;

        my $t = drawPoint($x, $y, ["intersectLine$a{tag}Line$o{tag}"]);
        push @obj, {%$t, intersectLines=>[$a, $o]};
       }

#______________________________________________________________________
# Intersect line and circle
# Find the point on the line closest to the center of the circle.
# This point is midway between the two intersection points.
#______________________________________________________________________

      if (($a{type} eq 'line' and $o{type} eq 'circle') or
          ($o{type} eq 'line' and $a{type} eq 'circle'))
       {my %l = %a; %l = %o if $o{type} eq 'line';
        my %c = %o; %c = %a if $a{type} eq 'circle';

        my @l = coordsOfLine(\%l);
        my @c = centerOfCircle(\%c);
        my $r = radiusOfCircle(\%c);
        my ($X, $Y) = line::pointOnLineClosestToPoint(@l, @c);
        next unless defined $X;

        my $dd = ($c[0]-$X)**2+($c[1]-$Y)**2;  # Distance squared from midway to center
        next if sqrt($dd) > $r;                # Check actually intersects circle
        my $d  = sqrt($r**2-$dd);              # Distance from midway to circumference

        my ($ux, $uy) = line::unitVectorAlongLine(@l);

        my $t1 = drawPoint($X + $d * $ux, $Y + $d * $uy, ["intersectLine$l{tag}Circle$c{tag}"]);
        push @obj, {%$t1, intersectLineCircle=>[\%l, \%c]};

        my $t2 = drawPoint($X - $d * $ux, $Y - $d * $uy, ["intersectLine$l{tag}Circle$c{tag}"]);
        push @obj, {%$t2, intersectLineCircle=>[\%l, \%c]};
       }
     }
   }
 }

#______________________________________________________________________
# Redraw all points to correct size
#______________________________________________________________________

sub redrawAllPoints()
 {for my $p(@obj)
   {my %p = %$p;
    next unless $p{type} eq 'point' and !defined $p{reuse};
    my @i       = $c->coords($p{tag});
    my ($x, $y) = coordsOfPoint($p{tag});
    $c->coords($p{tag}, $x-$ps, $y-$ps, $x+$ps, $y+$ps);
   }
 }

#______________________________________________________________________
# Draw point unless very close to an existing point
#______________________________________________________________________

sub drawPoint($$)
 {my $x  = shift; # X coord
  my $y  = shift; # Y coord
  my $t  = shift; # Array of tags

  my @n = $c->find(overlapping=>$x-$ps, $y-$ps, $x+$ps, $y+$ps);

  for my $n(@n)
   {my @t = $c->gettags($n);
    my %t;
    for my $t(@t) {$t{$t} = 1};
    if ($t{point} and $t{$drawColor})
     {my ($cx, $cy) = coordsOfPoint($n);
      my $d = ($cx-$x)**2+($cy-$y)**2;
      return {type=>'point', reuse=>$n} if $d < $near;
     }
   }

  my $p = $c->createOval($x-$ps, $y-$ps, $x+$ps, $y+$ps, -tags=>['point', $drawColor, @$t],
    -outline=>$drawColor, -fill=>'white', -activefill=>'green', -disabledfill=>'yellow');
  $c->bind($p, "<Double-ButtonPress-1>", [\&doubleButtonPress1Point, $p]);
  return {type=>'point', tag=>$p};
 }

#______________________________________________________________________
# Configure start point
#______________________________________________________________________

sub configureStartPoint($$)
 {my ($x, $y) = @_;

  if (($x-$bx)**2+($y-$by)**2 < $ps*$ps)
   {$c->itemconfigure('startPoint', -fill=>'red');
    return 1;
   }
  else
   {$c  ->itemconfigure('startPoint', -fill=>'green');
    return 0;
   }
 }

#______________________________________________________________________
# Coords of line from tag
#______________________________________________________________________

sub coordsOfLine($)
 {my $l = shift; # Line
  return $c->coords($l->{tag});
 }

#______________________________________________________________________
# Radius of circle from tag
#______________________________________________________________________

sub radiusOfCircle($)
 {my $C = shift; # Circle
  my ($x1, $y1, $x2, $y2) = $c->coords($C->{tag});
  return abs($x2 - $x1) / 2;
 }

#______________________________________________________________________
# Center of circle from tag
#______________________________________________________________________

sub centerOfCircle($)
 {my $C = shift; # Circle
  my ($x1, $y1, $x2, $y2) = $c->coords($C->{tag});
  return (($x1+$x2)/2, ($y1+$y2)/2);
 }

#______________________________________________________________________
# Coord of point from tag
#______________________________________________________________________

sub coordsOfPoint($)
 {my $p = shift; # Tag of point
  my ($x1, $y1, $x2, $y2) = $c->coords($p);
unless ($x1)
 {print "p=$p\n";
  dd();
 }
  return (($x1+$x2)/2, ($y1+$y2)/2);
 }

#______________________________________________________________________
# Color of object from tag
#______________________________________________________________________

sub colorFromTag($)
 {my $t    = shift; # Tag
  my $type = $c->type($t);
  my $cl;
     $cl = $c->itemcget($t, -fill=>)    if $type eq 'line';
     $cl = $c->itemcget($t, -outline=>) if $type eq 'oval';
  return $cl;
 }

#______________________________________________________________________
# Dump all objects
#______________________________________________________________________

sub dd($)
 {my $l = shift; # Title
  print "\n";
  print "$l\n" if $l;
  my @t = $c->find(withtag=>'all');
  for my $t(@t)
   {my @v = $c->gettags($t);
    if (@v)
     {my @co = $c->coords($t);
       print "$t:", join(' ', @v), "\n  coords:", join(' ', @co), "\n";
     }
   }
 }

#______________________________________________________________________
# Undo
#______________________________________________________________________

sub undo()
 {$objoff = scalar(@obj) unless defined($objoff);
  $objoff-- if $objoff > 0;

  for(;$objoff >= 0; --$objoff)
   {return if $objoff < 0;
    my %o = %{$obj[$objoff]};
    my $t = ''; $t = $o{tag} if defined($o{tag});
    if ($o{type} eq 'commit')
     {return;
     }
    $c->itemconfigure($o{tag}, -state=>'disabled');
   }
 }

#______________________________________________________________________
# Redo
#______________________________________________________________________

sub redo()
 {return unless defined($objoff);
  $objoff++ if $objoff < scalar(@obj);

  for(;$objoff < scalar(@obj);++$objoff)
   {my %o = %{$obj[$objoff]};
    my $t = ''; $t = $o{tag} if defined($o{tag});
    if ($o{type} eq 'commit')
     {return;
     }
    $c->itemconfigure($o{tag}, -state=>'normal');
   }
 }

#______________________________________________________________________
# Main
#______________________________________________________________________

$g = gs::new();
$g->set( qw(display title Geops));    # X size of display
$g->set( qw(display x 1000));         # X size of display
$g->set( qw(display y 1000));         # Y size of display
$g->set( qw(display near    0.001));  # Near enough to be considered the same
$g->set( qw(user point size 5));      # Point representation size
$g->set( qw(user point capture 10));  # Point representation size

#______________________________________________________________________
# Create display
#______________________________________________________________________

$m = MainWindow->new();
$m->title($g->get(qw(display title)));
$g->set(qw(display main), $m);

$m->OnDestroy(sub {$mm->destroy() if defined($mm)});

$c = $m->Canvas(
    -background => 'white',
    -width      => $g->get(qw(display x)),
    -height     => $g->get(qw(display y)),
    -cursor=>'crosshair');

$g->set(qw(display canvas),      $c);

$c->pack(-expand=>1, -fill=>'both');

$balloon = $m->Balloon(); # Help balloon

#______________________________________________________________________
# Data
#______________________________________________________________________

$ps   = $g->get( qw(user point size));        # Point size
$pc   = $g->get( qw(user point capture));     # Point capture size
$near = $g->get( qw(display near));           # Near enough to be the same
$bx   = undef;                              # Button down X
$by   = undef;                              # Button down Y
@obj  = ();                                 # List of objects
@drawColor = qw/DarkRed Red DeepPink Magenta OrangeRed Orange Gold Yellow Cyan Green DarkGreen Purple Blue DarkBlue Black/;
$drawColor = 'Black';                       # Current color
$drawWidth = 3;                             # Current drawing width
$drawDash  = '';                            # Dash scheme
$showColor->{$drawColor} = 1;               # Activate current color

$gs = '/gs/"gs8.11"/bin/gswin32c.exe -sDEVICE=jpeg -SOutputFile=XXX -dBATCH -dNOPAUSE zzz.ps';

#______________________________________________________________________
# Bindings
#______________________________________________________________________

$c->CanvasBind("<ButtonPress>",                \&buttonPress);
$c->CanvasBind("<ButtonRelease>",              \&buttonRelease);
$c->CanvasBind("<Button1-Motion>",             \&button1Motion);
$c->CanvasBind("<Button2-Motion>",             \&button2Motion);
$c->CanvasBind("<Button3-Motion>",             \&button3Motion);
$c->CanvasBind('all', "<MouseWheel>",          \&mouseWheel);
$m->bind("<x>",                                \&expand);
$m->bind("<c>",                                \&contract);
$m->bind("<z>",                                \&undo);
$m->bind("<r>",                                \&redo);
$m->bind("<Double-ButtonPress-1>",             \&doubleButtonPress1Point);

#______________________________________________________________________
# Display
#______________________________________________________________________

MainLoop;