#!/usr/local/bin/perl -w
#
#    generate_test_patterns --- Generate geometric test patterns
#    Copyright (2003) by Tom Fawcett
#    Created Sat Mar 29 2003 by Tom Fawcett (<tfawcett@acm.org>)
#
#    $Id: generate_test_patterns.pl 103 2008-06-21 03:36:24Z fawcett $
#    $URL: svn+ssh://dw/home/repo/CA/test_patterns/generate_test_patterns.pl $
#
##### REQUIREMENTS  ##########################################################
use English;
use strict;
use Math::Random qw(random_uniform);
use Math::Geometry::Planar;
use Getopt::Long;

#  These are constants
my $EMPTY  = 0;
my $CLASS1 = 1;
my $CLASS2 = 2;

#  If on, empty and remove all subdirectories.  Turned off because removing
#  directories under version control makes svn go nuts.
use constant RMDIR => 0;

srand;

my @domains = qw( linearaxp linear parabolic closedconvex closedconcave
    disjunctive parity );

##### PROCESS ARGUMENTS  #####################################################
#  Declare option values, set defaults
my $xrange     = "0:4";
my $yrange     = "0:4";
my $resolution = 0.05;

GetOptions(
    "xrange=s"     => \$xrange,
    "yrange=s"     => \$yrange,
    "resolution=f" => \$resolution
) or die;

##### INITIALIZATION  ########################################################
my ( $xlow, $xhigh ) = split( ':', $xrange );
my ( $ylow, $yhigh ) = split( ':', $yrange );

open( my $PARMS, ">PARAMETERS" ) or die ">PARAMETERS: $OS_ERROR";
print $PARMS join( ",", $xlow, $xhigh, $ylow, $yhigh, $resolution ), "\n";
close($PARMS);

##############################################################################
#  Global variable of points indexed by class.  The subs below push their
#  values onto this.
my (%points);

for my $subdir ( @ARGV == 0 ? @domains : @ARGV ) {
    print "\nProcessing $subdir\n";
    if (RMDIR) {
        system("rm -rf $subdir"); # Ignore errors here
    }
    unless ( -d $subdir ) {
        mkdir($subdir) or die "mkdir($subdir): $OS_ERROR";
    }

    open( my $POINTS, ">$subdir/patterns.exhaustive" )
        or die("open(>$subdir/patterns.exhaustive: $OS_ERROR");
    print $POINTS "# Created by: $PROGRAM_NAME @ARGV\n";

    #  Generate points from the sub call
    %points = ();
    my $call = "&make_${subdir}('$subdir');";
    eval($call);

    #  Print points to file
    my $n_class1 = @{ $points{$CLASS1} };
    my $n_class2 = @{ $points{$CLASS2} };
    printf $POINTS "# Total of %d points (%d class 1, %d class 2)\n",
        $n_class1 + $n_class2, $n_class1, $n_class2;

    for my $class ( $CLASS1, $CLASS2 ) {
        for my $point ( @{ $points{$class} } ) {
            my ( $x, $y ) = @$point;
            print $POINTS "$x $y $class\n";
        }
        print $POINTS "\n\n";
    }

    close($POINTS);
}

exit(0);

#=============================================================================

sub make_linearaxp {
    my ($dir) = @_;

    #  Randomly choose boundary axis and line
    my ( $axis, $thresh );

    #  Note that we can't use references here because we'd have to
    #  reference variables inside the subroutine below.
    if ( rand > 0.5 ) {
        $axis   = "x";
        $thresh = ( $xhigh - $xlow ) / 2;
    }
    else {
        $axis   = "y";
        $thresh = ( $yhigh - $ylow ) / 2;
    }

    generate_and_classify_points(
        sub {
            my ( $x, $y ) = @_;
            if ( $axis eq "x" ) {
                $x > $thresh ? $CLASS1 : $CLASS2;
            }
            else {
                $y > $thresh ? $CLASS1 : $CLASS2;
            }
        }
    );
}

sub make_linear {
    my ($dir) = @_;

    my $slope = random_uniform( 1, 0.5, 2 );

    #  Set up intercept b so that the rectangle is bisected
    my $y_mid = ( $yhigh - $ylow ) / 2;
    my $x_mid = ( $xhigh - $xlow ) / 2;
    my $b     = $y_mid - $slope * $x_mid;

    print "Generating for y > $slope * x + $b\n";

    generate_and_classify_points(
        sub {
            my ( $x, $y ) = @_;
            my $class = ( $x * $slope + $b > $y ) ? $CLASS1 : $CLASS2;
            $class;
        }
    );
}

sub make_parabolic {
    my ($dir) = @_;

    my ( $x, $y );

    my $y_mid = ( $yhigh - $ylow ) / 2;
    my $x_mid = ( $xhigh - $xlow ) / 2;

    #  Upward concave parabola at (h,k)
    #  Use derivation y = (x-h)^2 / 4p + k
    #  where the bottom point of the parabola is at (h,k) and the spread is
    #  determined by p

    #  Choose h = x_mid, k = y_mid / 2
    my $h = $x_mid;
    my $k = $y_mid / 2;

    #    my $p = random_uniform( 1, 0, 1 );
    #  At p=0.25, we get a decent spread
    my $p = 0.25;

    print "Generating for parabola y = (x - $h)^2 / (4* $p) + $k\n";

    generate_and_classify_points(
        sub {
            my ( $x, $y ) = @_;
            my $y_thresh = ( $x - $h )**2 / ( 4 * $p ) + $k;
            my $class = ( $y_thresh > $y ) ? $CLASS1 : $CLASS2;
            $class;
        }
    );
}

sub make_closedconvex {
    my ($dir) = @_;

    my $y_mid     = ( $yhigh - $ylow ) / 2;
    my $x_mid     = ( $xhigh - $xlow ) / 2;
    my $x_quarter = $x_mid / 2;
    my $y_quarter = $y_mid / 2;

    #  Generate scattershot points withing a quarter rectangle
    my ( $polygon, @polypts );
    for ( 1 .. 20 ) {
        push(
            @polypts,
            [   random_uniform( 1, $x_quarter, $x_quarter + $x_mid ),
                random_uniform( 1, $y_quarter, $y_quarter + $y_mid )
            ]
        );
    }
    $polygon = Math::Geometry::Planar->new;
    $polygon->points( \@polypts );
    my $chull = $polygon->convexhull2;

    generate_and_classify_points(
        sub {
            my ( $x, $y ) = @_;
            my $class
                = ( $chull->isinside( [ $x, $y ] ) ? $CLASS1 : $CLASS2 );
            $class;
        }
    );
}

sub make_closedconcave {
    my ($dir) = @_;

    my $y_mid     = ( $yhigh - $ylow ) / 2;
    my $x_mid     = ( $xhigh - $xlow ) / 2;
    my $x_quarter = $x_mid / 2;
    my $y_quarter = $y_mid / 2;

    #  Generate scattershot points withing a quarter rectangle
    my ( $polygon, @polypts );
    for ( 1 .. 20 ) {
        push(
            @polypts,
            [   random_uniform( 1, $x_quarter, $x_quarter + $x_mid ),
                random_uniform( 1, $y_quarter, $y_quarter + $y_mid )
            ]
        );
    }
    $polygon = Math::Geometry::Planar->new;
    $polygon->points( \@polypts );
    my $chull = $polygon->convexhull2;

    #  Now we have a convex polygon.  Make it concave by calculating its
    #  center, removing one hull point, and connecting the hull point's two
    #  neighbors to the center.
    my $centroid = $chull->centroid;
    my (@cpoints) = @{ $chull->points };
    splice( @cpoints, int( rand @cpoints ), 1, $centroid );
    my $concave_poly = Math::Geometry::Planar->new;
    $concave_poly->points( \@cpoints );

    generate_and_classify_points(
        sub {
            my ( $x, $y ) = @_;
            my $class = (
                $concave_poly->isinside( [ $x, $y ] ) ? $CLASS1 : $CLASS2 );
            $class;
        }
    );
}

#  Disjunctive is essentially multiple concave polygons
sub make_disjunctive {
    my ($dir) = @_;

    my ( $x, $y );

    my $y_mid     = ( $yhigh - $ylow ) / 2;
    my $x_mid     = ( $xhigh - $xlow ) / 2;
    my $x_quarter = $x_mid / 2;
    my $y_quarter = $y_mid / 2;

    my (%points);
    my (@polys);

    for my $x_center ( 1, 3 ) {
        for my $y_center ( 1, 3 ) {

            #  Generate scattershot points within a quarter rectangle
            my ( $polygon, @polypts );
            for ( 1 .. 20 ) {
                push(
                    @polypts,
                    [   random_uniform( 1, $x_center - 1, $x_center + 1 ),
                        random_uniform( 1, $y_center - 1, $y_center + 1 )
                    ]
                );
            }
            $polygon = Math::Geometry::Planar->new;
            $polygon->points( \@polypts );
            my $chull = $polygon->convexhull2;

            #  Now we have a convex polygon.  Make it concave by calculating
            #  its center, removing one hull point, and connecting the hull
            #  point's two neighbors to the center.
            my $centroid = $chull->centroid;
            my (@cpoints) = @{ $chull->points };
            splice( @cpoints, 1, 1, $centroid );
            my $concave_poly = Math::Geometry::Planar->new;
            $concave_poly->points( \@cpoints );
            push( @polys, $concave_poly );
        }
    }

    generate_and_classify_points(
        sub {
            my ( $x, $y ) = @_;
            my $class = $CLASS2;    # default = not inside any poly
            for my $poly (@polys) {
                if ( $poly->isinside( [ $x, $y ] ) ) {
                    $class = $CLASS1;
                    last;
                }
            }
            $class;
        }
    );

}

sub make_parity {
    my ($dir) = @_;

    use constant RADIUS   => 0.5;
    use constant RSQUARED => RADIUS**2;

    my (@circles);

    for my $x_center ( 1, 2, 3 ) {
        for my $y_center ( 1, 2, 3 ) {

            #  This is rancid:
            my $class = ( $x_center + $y_center ) % 2 + 1;
            push( @circles, [ $x_center, $y_center, $class ] );
        }
    }

    generate_and_classify_points(
        sub {
            my ( $x, $y ) = @_;
            for my $circle (@circles) {
                my ( $xc, $yc, $class ) = @$circle;
                if ( ( $x - $xc )**2 + ( $y - $yc )**2 < RSQUARED ) {
                    return $class;
                }
            }

            return $CLASS1;    # We need a default -- use $CLASS1
        }
    );
}

sub generate_and_classify_points {
    my ($classifier) = @_;

    for ( my $x = $xlow; $x <= $xhigh; $x += $resolution ) {
        for ( my $y = $ylow; $y <= $yhigh; $y += $resolution ) {
            my $class = $classifier->( $x, $y );
            next if $class == $EMPTY;    # ***** DISCARD POINT
            push( @{ $points{$class} }, [ $x, $y ] );
        }
    }
}

##### End of generate_test_patterns.pl