#!/usr/bin/perl -w

use strict;
use warnings;

use Tk;
use Tk::Canvas;
use Data::Dumper;
use Storable qw(dclone);

my $mw = MainWindow->new();
$mw->state('zoomed');

my $canvas =
        $mw->Canvas()->pack(-expand => 1, -fill => 'both');
        
my %coord_1 = (
        'a' => [100,100,'b'],
        'b' => [200,100,'c'],
        'c' => [200,200,'d'],
        'd' => [150,250,'e'],
        'e' => [100,200,'a'],
);

my %coord_2 = (
        'f' => [250,250,'g'],
        'g' => [300,200,'h'],
        'h' => [300,300,'i'],
        'i' => [250,350,'j'],
        'j' => [200,300,'f'],
);

drawPolygon($canvas, \%coord_1, 'yellow', 'poly1'); #modified
my $moving_pol =  drawPolygon($canvas, \%coord_2, 'lightblue', 'poly2'); #modified
my $moving_pol_tag='poly2';

$mw->bind('<Up>', sub{movePolygon($canvas,$moving_pol,0,-5,$moving_pol_tag);}); #modified
$mw->bind('<Down>', sub{movePolygon($canvas,$moving_pol,0,5,$moving_pol_tag);}); #modified
$mw->bind('<Left>', sub{movePolygon($canvas,$moving_pol,-5,0,$moving_pol_tag);}); #modified
$mw->bind('<Right>', sub{movePolygon($canvas,$moving_pol,5,0,$moving_pol_tag);}); #modified

Tk::MainLoop;

sub drawPolygon{
        my $widget      = shift;
        my $coord       = shift;
        my $color       = shift;
        my $tag         = shift;     #added
        
        my @coords;
        foreach my $point (sort keys %{$coord}){
                push(@coords, $coord->{$point}->[0], $coord->{$point}->[1]);
        }

        return  $widget->createPolygon(
                @coords,
                -fill => $color,
                -outline => 'black',
                -tag => $tag        #added
        );
}

sub movePolygon{
        my $widget  = shift;
        my $polygon = shift;
        my $x_move  = shift;
        my $y_move  = shift;
        my $tag     = shift;        #added

        foreach my $point (sort keys %coord_2){
                $coord_2{$point}->[0] += $x_move;
                $coord_2{$point}->[1] += $y_move;
        }

        $widget->move($polygon, $x_move, $y_move);
        
        if (PolygonsOverlap(\%coord_2,$tag)){                  #modified
                $widget->itemconfigure(
                        $polygon, 
                        -outline        => 'red',
                        -fill => 'lightgreen'
                );
        }else{
                $widget->itemconfigure(
                        $polygon, 
                        -outline        => 'black',
                        -fill => 'lightblue'
                );
        }
}

###################################
# algorithmus zum testen, ob sich #
# die polygone überschneiden.     #
###################################
sub PolygonsOverlap{
        #my %coord_1 = %{shift()}; 
        my %coord_2 = %{shift()};
        my $moving_pol_tag = shift;         # name of the polygon that we are moving around

        my $bboxes;        # hash of all bounding boxes to check   
        my $clonedbboxes;  # clone of bboxes. Used only for loop iteration to avoid side effects when manipulating $bboxes inside the loop
        #my $tbboxes;
        my $objectshit;    # names of the objects you have hit
        my $xm=1;          # 1 needed for first run
        my $ym=1;
        my $DEBUG=0;

        print "--- entering colissioncheck ---\n" if ($DEBUG);

        my $bboxname='1';   # The first bounding box is a large rectangle that encloses the polygon completly. Lets call it '1'
        $bboxes->{$bboxname}->{bbxmin}=999999; 
        $bboxes->{$bboxname}->{bbxmax}=0;
        $bboxes->{$bboxname}->{bbymin}=999999;
        $bboxes->{$bboxname}->{bbymax}=0;

        #reduce the size of the same rectangle to exactly enclose our moving polygon
        foreach my $point (keys %coord_2){
         $bboxes->{$bboxname}->{bbxmin}=$coord_2{$point}->[0] if ($coord_2{$point}->[0] < $bboxes->{$bboxname}->{bbxmin});
         $bboxes->{$bboxname}->{bbxmax}=$coord_2{$point}->[0] if ($coord_2{$point}->[0] > $bboxes->{$bboxname}->{bbxmax});
         $bboxes->{$bboxname}->{bbymin}=$coord_2{$point}->[1] if ($coord_2{$point}->[1] < $bboxes->{$bboxname}->{bbymin});
         $bboxes->{$bboxname}->{bbymax}=$coord_2{$point}->[1] if ($coord_2{$point}->[1] > $bboxes->{$bboxname}->{bbymax});
        }
        
        while (scalar keys %{$bboxes} > 0) {    # keep checking as long as we have bboxes
          #my @deleteme;   # remove comment if you dont want to use dclone
          #my $tbboxes;    # remove comment if you dont want to use dclone
          my $numberofbboxes = scalar keys %{$bboxes};
          print "number of bboxes to check: $numberofbboxes\n" if ($DEBUG);

          %{$clonedbboxes} = %{ dclone \%{$bboxes} };          # clone the original bboxes hash and use it to control the loop, just to avoid side effects
          foreach my $thisbboxname (keys %{$clonedbboxes}) {   # process all bounding boxes
            my @objectsfound;
            print "next bbox to check: $thisbboxname (".$bboxes->{$thisbboxname}->{bbxmin}.",".$bboxes->{$thisbboxname}->{bbymin}."  ". $bboxes->{$thisbboxname}->{bbxmax}.",".$bboxes->{$thisbboxname}->{bbymax}.")\n" if ($DEBUG);

            #find canvas objects overlapping the current boundary box
            foreach my $thisobject ($canvas->find('overlapping', $bboxes->{$thisbboxname}->{bbxmin}, $bboxes->{$thisbboxname}->{bbymin},$bboxes->{$thisbboxname}->{bbxmax},$bboxes->{$thisbboxname}->{bbymax})) {
              my @tags = $canvas->gettags($thisobject);          # get the tags of the objects found
              #next if ($tags[0] eq $moving_pol_tag);            
              push (@objectsfound,$tags[0]);                     # save the name we have given to our objects. Be careful here when using more than one tag for your objects
            }
              my $objcount=scalar @objectsfound;
              print "$moving_pol_tag: $objcount overlapping objects inside bboxname: $thisbboxname (".$bboxes->{$thisbboxname}->{bbxmin}.",".$bboxes->{$thisbboxname}->{bbymin}."  ".$bboxes->{$thisbboxname}->{bbxmax}.",".$bboxes->{$thisbboxname}->{bbymax}."): ".join(',',@objectsfound)."\n" if ($DEBUG);
              
              if ($objcount > 1) {    # found another object in the near so start locating it
                # split this bounding box in the middle and create four smaller ones
                # AB
                # CD
                if (($xm>0) || ($ym>0)) {    # can the bbox be split any further ?
                  $xm=int(($bboxes->{$thisbboxname}->{bbxmax} - $bboxes->{$thisbboxname}->{bbxmin})/2);
                  $ym=int(($bboxes->{$thisbboxname}->{bbymax} - $bboxes->{$thisbboxname}->{bbymin})/2);
                  print "creating new bounding boxes:\n" if ($DEBUG);
                  # change the following 16 $bboxes on the left hand side to $tbboxes (and the print statements) to save new bboxes to a temp hash if you dont want to use dclone
                  #create rectangle A
                  $bboxname=$thisbboxname.'A';
                  $bboxes->{$bboxname}->{bbxmin}=$bboxes->{$thisbboxname}->{bbxmin};
                  $bboxes->{$bboxname}->{bbymin}=$bboxes->{$thisbboxname}->{bbymin};
                  $bboxes->{$bboxname}->{bbxmax}=$bboxes->{$thisbboxname}->{bbxmin} + $xm;
                  $bboxes->{$bboxname}->{bbymax}=$bboxes->{$thisbboxname}->{bbymin} + $ym;
                  print "$bboxname: ".$bboxes->{$bboxname}->{bbxmin}.",".$bboxes->{$bboxname}->{bbymin}."  ".$bboxes->{$bboxname}->{bbxmax}.",".$bboxes->{$bboxname}->{bbymax}."\n" if ($DEBUG);
                  #create rectangle B
                  $bboxname=$thisbboxname.'B';
                  $bboxes->{$bboxname}->{bbxmin}=$bboxes->{$thisbboxname}->{bbxmin} + $xm + 1;
                  $bboxes->{$bboxname}->{bbymin}=$bboxes->{$thisbboxname}->{bbymin};
                  $bboxes->{$bboxname}->{bbxmax}=$bboxes->{$thisbboxname}->{bbxmax};
                  $bboxes->{$bboxname}->{bbymax}=$bboxes->{$thisbboxname}->{bbymin} + $ym;
                  print "$bboxname: ".$bboxes->{$bboxname}->{bbxmin}.",".$bboxes->{$bboxname}->{bbymin}."  ".$bboxes->{$bboxname}->{bbxmax}.",".$bboxes->{$bboxname}->{bbymax}."\n" if ($DEBUG);
                  #create rectangle C
                  $bboxname=$thisbboxname.'C';
                  $bboxes->{$bboxname}->{bbxmin}=$bboxes->{$thisbboxname}->{bbxmin};
                  $bboxes->{$bboxname}->{bbymin}=$bboxes->{$thisbboxname}->{bbymin} + $ym + 1;
                  $bboxes->{$bboxname}->{bbxmax}=$bboxes->{$thisbboxname}->{bbxmin} + $xm;
                  $bboxes->{$bboxname}->{bbymax}=$bboxes->{$thisbboxname}->{bbymax};
                  print "$bboxname: ".$bboxes->{$bboxname}->{bbxmin}.",".$bboxes->{$bboxname}->{bbymin}."  ".$bboxes->{$bboxname}->{bbxmax}.",".$bboxes->{$bboxname}->{bbymax}."\n" if ($DEBUG);
                  #create rectangle D
                  $bboxname=$thisbboxname.'D';
                  $bboxes->{$bboxname}->{bbxmin}=$bboxes->{$thisbboxname}->{bbxmin} + $xm + 1;
                  $bboxes->{$bboxname}->{bbymin}=$bboxes->{$thisbboxname}->{bbymin} + $ym + 1;
                  $bboxes->{$bboxname}->{bbxmax}=$bboxes->{$thisbboxname}->{bbxmax};
                  $bboxes->{$bboxname}->{bbymax}=$bboxes->{$thisbboxname}->{bbymax};
                  print "$bboxname: ".$bboxes->{$bboxname}->{bbxmin}.",".$bboxes->{$bboxname}->{bbymin}."  ".$bboxes->{$bboxname}->{bbxmax}.",".$bboxes->{$bboxname}->{bbymax}."\n" if ($DEBUG);
                  print Dumper($bboxes) if ($DEBUG);
                } #end if $xm>0...
                else { #smallest bbox still has something overlapping...so its a collision
                  print "$moving_pol_tag: collision detected: ".join(',',@objectsfound)." in $thisbboxname (".$bboxes->{$thisbboxname}->{bbxmin}.",".$bboxes->{$thisbboxname}->{bbymin}."  ".$bboxes->{$thisbboxname}->{bbxmax}.",".$bboxes->{$thisbboxname}->{bbymax}.") !!!!!\n" if ($DEBUG);
                  foreach my $thishit (@objectsfound) {
                    next if ($thishit eq $moving_pol_tag);   # do not add the moving polygon
                    print "adding $thishit to objectshit hash\n" if ($DEBUG);
                    $objectshit->{$thishit}=1;               # use hash to get a unique list of objects hit. Save collision coords here if you need it
                  }
                }
              }

            delete $bboxes->{$thisbboxname};                           # comment this line out if you dont want to use dclone
            print "deleting bbox $thisbboxname\n" if ($DEBUG);         # comment this line out if you dont want to use dclone
            #print "marking $thisbboxname for deletion\n" if ($DEBUG); # uncomment this line if you dont want to use dclone
            #push (@deleteme,$thisbboxname);                           # uncomment this line if you dont want to use dclone

          } #end of the loop foreach my thisbboxname

          print "end of foreach thisbboxname\n" if ($DEBUG);

#          foreach (@deleteme) {                                       # uncomment this line if you dont want to use dclone
#            print "deleting bbox $_\n" if ($DEBUG);                   # uncomment this line if you dont want to use dclone
#            delete $bboxes->{$_} ;                                    # uncomment this line if you dont want to use dclone
#          }                                                           # uncomment this line if you dont want to use dclone
#          foreach my $thisbboxname (keys %{$tbboxes}) {                                # uncomment this line if you dont want to use dclone
#            print "adding bbox: $thisbboxname to original bboxhash\n" if ($DEBUG);     # uncomment this line if you dont want to use dclone
#            $bboxes->{$thisbboxname}->{bbxmin}=$tbboxes->{$thisbboxname}->{bbxmin};    # uncomment this line if you dont want to use dclone
#            $bboxes->{$thisbboxname}->{bbymin}=$tbboxes->{$thisbboxname}->{bbymin};    # uncomment this line if you dont want to use dclone
#            $bboxes->{$thisbboxname}->{bbxmax}=$tbboxes->{$thisbboxname}->{bbxmax};    # uncomment this line if you dont want to use dclone
#            $bboxes->{$thisbboxname}->{bbymax}=$tbboxes->{$thisbboxname}->{bbymax};    # uncomment this line if you dont want to use dclone
#          }                                                                            # uncomment this line if you dont want to use dclone

        } #end while

        my $numberofobjectshit= scalar keys %{$objectshit};
        print "Number of objects hit: $numberofobjectshit\n" if ($DEBUG);
        if ($numberofobjectshit > 0) {
          print "The following objects have been hit by $moving_pol_tag: ",join (",",keys %{$objectshit})."\n";
        }
        print "--- end of collisioncheck---\n" if ($DEBUG);

  return $numberofobjectshit;
}