#!perl -w
#______________________________________________________________________
# Geometric operations
# [email protected], 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.
Control-Z to undo.
Control-R to redo.
Left Doubleclick 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>

=head1 COREQUISITES

=pod OSNAMES

any

=pod SCRIPT CATEGORIES

Educational

=cut
#______________________________________________________________________
# Packages
#______________________________________________________________________

use Tk;
use Tk::Balloon;

#______________________________________________________________________
# Line manipulation
# [email protected], 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
# [email protected], 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
# [email protected], 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: [email protected], 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.
Control-Z to undo.
Control-R to redo.
Left Doubleclick 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();
}

#______________________________________________________________________
# 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("<Control-z>",            \&undo);
$m->bind("<Control-r>",            \&redo);
$m->bind("<Double-ButtonPress-1>", \&doubleButtonPress1Point);

#______________________________________________________________________
# Display
#______________________________________________________________________

MainLoop;

You are viewing proxied material from ftp.icm.edu.pl. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.