<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">#!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&lt;Tk&gt;

  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-&gt;{sx} = $sx;
  $l-&gt;{sy} = $sy;
  $l-&gt;{fx} = $fx;
  $l-&gt;{fy} = $fy;
  $l-&gt;{dx} = $dx;
  $l-&gt;{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) &lt;= 1 and abs($dy) &lt;= 1;

# Vertical line

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

# Horizontal line

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

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

# Lower

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

# Upper

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

# Right

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

# Left

  $i = $sy-$dy*($sx-$bx1)/$dx;
  push @i, ($bx1, $i) if $i &gt;= $by1 and $i &lt;= $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) &lt; 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=&gt;'green', -unselected=&gt;'white', -flash=&gt;'red', -entered=&gt;'pink', -background=&gt;'white',
           -line=&gt;'blue', -widths=&gt;[1..5], -dash=&gt;['', qw(. - -. -..)], -height=&gt;20, -width=&gt;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) &gt; $n;

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

# Line width

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

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

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

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

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

# Line dash style

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

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

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

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

      $cdash[$i] = $c = $dw-&gt;Canvas(-height=&gt;$p{'-height'}, -width=&gt;$p{'-width'},
        -background=&gt;$p{'-background'})-&gt;grid(-column=&gt;2, -row=&gt;$row);
      $c-&gt;configure(-background=&gt;$p{'-selected'}) if defined($p{'-dashVar'}) and $dash[$i] eq ${$p{'-dashVar'}};
      $c-&gt;createLine(@lineDraw, -fill=&gt;$p{'-line'}, -dash=&gt;$dash[$i], -width=&gt;$i);
      $c-&gt;CanvasBind("&lt;ButtonRelease-1&gt;", [$release, $i]);
      $c-&gt;CanvasBind("&lt;ButtonPress-1&gt;",   [$press,   $i]);
      $c-&gt;CanvasBind("&lt;Enter&gt;",           [$enter,   $i]);
      $c-&gt;CanvasBind("&lt;Leave&gt;",           [$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-&gt;{$p[0]}                     if scalar(@p) == 1;
  return $g-&gt;{$p[0]}-&gt;{$p[1]}            if scalar(@p) == 2;
  return $g-&gt;{$p[0]}-&gt;{$p[1]}-&gt;{$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-&gt;{$p[0]} = $p[1]                    if scalar(@p) == 2;
  return $g-&gt;{$p[0]}-&gt;{$p[1]} = $p[2]           if scalar(@p) == 3;
  return $g-&gt;{$p[0]}-&gt;{$p[1]}-&gt;{$p[2]} = $p[3]  if scalar(@p) == 4;
  die "geo::set: Wrong number of parameters";
 }

#______________________________________________________________________
# Main
#______________________________________________________________________

package main;

print &lt;&lt; '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-&gt;XEvent;
  my ($x, $y) = areWeNearAnything(($c-&gt;canvasx($e-&gt;x), $c-&gt;canvasy($e-&gt;y)));
  return ($x, $y, $e-&gt;b);
 }

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

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

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

# Undo / redo capability

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

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

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

  $c-&gt;delete('startPoint');

# Finish drawing line

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

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

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

# Finish drawing circle

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

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

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

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

#______________________________________________________________________
# Button 1 motion - draw line
#______________________________________________________________________

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

  return if configureStartPoint($x, $y);

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

  $c-&gt;delete('currentLine');

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

#______________________________________________________________________
# Button 2 motion - pan
#______________________________________________________________________

sub button2Motion($)
 {my ($x, $y) = getXYFromEvent(shift());
  $c-&gt;move('all', $x-$bx, $y-$by);
  $c-&gt;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-&gt;delete('currentCircle');

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

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

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

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

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

  redrawAllPoints();
 }

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

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

  redrawAllPoints();
 }

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

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

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

  $c-&gt;scale('all', $x, $y, 5/4, 5/4);
  my $fx = $xv1 + $cx/$g-&gt;get(qw(display x)); $fx = 1 if $fx &gt; 1;
  my $fy = $yv1 + $cy/$g-&gt;get(qw(display y)); $fy = 1 if $fy &gt; 1;
  $c-&gt;xviewMoveto($fx);
  $c-&gt;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-&gt;itemcget($t, -fill=&gt;);
  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-&gt;raise();
    return;
   }

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

#______________________________________________________________________
# Color select
#______________________________________________________________________

  my $pm = $mm-&gt;LabFrame(-label=&gt;'Color', -labelside=&gt;'acrosstop')
   -&gt;grid(-column=&gt;1, -row=&gt;1);
  $balloon-&gt;attach($pm, -msg=&gt;"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-&gt;find(withtag=&gt;'all');
    for my $t(@t)
     {my $l = colorFromTag($t);
      my $s = 'hidden';
         $s = 'normal' if $showColor-&gt;{$r} == 1;
      $c-&gt;itemconfigure($t, -state=&gt;$s) if $l eq $r;
     }
   };

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

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

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

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

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

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

#______________________________________________________________________
# Line style select
#______________________________________________________________________

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

#______________________________________________________________________
# Files
#______________________________________________________________________

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

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

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


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

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

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

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

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

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

sub findIntersections($)
 {return unless scalar(@obj) &gt; 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 &gt; $R+$r;                      # Too far apart to intersect
        next if $D &lt; $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=&gt;[$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=&gt;[$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) &gt; $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=&gt;[\%l, \%c]};

        my $t2 = drawPoint($X - $d * $ux, $Y - $d * $uy, ["intersectLine$l{tag}Circle$c{tag}"]);
        push @obj, {%$t2, intersectLineCircle=&gt;[\%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-&gt;coords($p{tag});
    my ($x, $y) = coordsOfPoint($p{tag});
    $c-&gt;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-&gt;find(overlapping=&gt;$x-$ps, $y-$ps, $x+$ps, $y+$ps);

  for my $n(@n)
   {my @t = $c-&gt;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=&gt;'point', reuse=&gt;$n} if $d &lt; $near;
     }
   }

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

#______________________________________________________________________
# Configure start point
#______________________________________________________________________

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

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

#______________________________________________________________________
# Coords of line from tag
#______________________________________________________________________

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

#______________________________________________________________________
# Radius of circle from tag
#______________________________________________________________________

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

#______________________________________________________________________
# Center of circle from tag
#______________________________________________________________________

sub centerOfCircle($)
 {my $C = shift; # Circle
  my ($x1, $y1, $x2, $y2) = $c-&gt;coords($C-&gt;{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-&gt;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-&gt;type($t);
  my $cl;
     $cl = $c-&gt;itemcget($t, -fill=&gt;)    if $type eq 'line';
     $cl = $c-&gt;itemcget($t, -outline=&gt;) 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-&gt;find(withtag=&gt;'all');
  for my $t(@t)
   {my @v = $c-&gt;gettags($t);
    if (@v)
     {my @co = $c-&gt;coords($t);
       print "$t:", join(' ', @v), "\n  coords:", join(' ', @co), "\n";
     }
   }
 }

#______________________________________________________________________
# Undo
#______________________________________________________________________

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

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

#______________________________________________________________________
# Redo
#______________________________________________________________________

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

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

#______________________________________________________________________
# Main
#______________________________________________________________________

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

#______________________________________________________________________
# Create display
#______________________________________________________________________

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

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

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

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

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

$balloon = $m-&gt;Balloon(); # Help balloon

#______________________________________________________________________
# Data
#______________________________________________________________________

$ps   = $g-&gt;get( qw(user point size));        # Point size
$pc   = $g-&gt;get( qw(user point capture));     # Point capture size
$near = $g-&gt;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-&gt;{$drawColor} = 1;               # Activate current color

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

#______________________________________________________________________
# Bindings
#______________________________________________________________________

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

#______________________________________________________________________
# Display
#______________________________________________________________________

MainLoop;
</pre></body></html>