#!/usr/bin/perl

# $Header: /home/abhaile/swmcd/.CVS/Perl/ColorWork,v 1.6 2008/11/24 00:29:45 swmcd Exp $

use 5;
use strict;
use English;
use Tk;
use Tk::DialogBox;

use constant MAGIC     => 'CKnt';

use constant NShades   =>  4;
use constant ColorSize => 50;
use constant GridSize  => 10;

use constant X1        =>  0;
use constant Y1        =>  1;
use constant X2        =>  2;
use constant Y2        =>  3;

use constant LEFT      =>  0;
use constant TOP       =>  1;
use constant RIGHT     =>  2;
use constant BOTTOM    =>  3;

my($Revision) = '$Revision: 1.6 $';
$Revision =~ s/\$Revision: //;
$Revision =~ s/\$$//;

my $CurrentFill    = 'black';

my @Square  = (0  , 0,
	       1  , 0,
	       1  , 1,
	       0  , 1);

my @Chevron = (0  , 0,
	       0.5, 0.5,
	       1  , 0,
	       1  , 1,
	       0.5, 1.5,
	       0  , 1);

my @Color =
(
 [ 'grey0'   , 'grey33'	 , 'grey67'  , 'grey100'  ],

 map { my $base = $_;
       [ map { $base . $_ } (4, 3, 2, 1) ] } qw(red green blue cyan magenta yellow brown)
);


my $MW = new MainWindow;
my $KP = new KnitPattern $MW, 24, 32, 8, 8;
MainLoop;


sub KnitPattern::new
{
    my($package, $MW, $rows, $cols, $rowGuides, $colGuides) = @_;

    my $colorHeight = (@Color+2) * ColorSize;
    my $gridHeight  = ($rows+3) * GridSize;
    my $height      = max($colorHeight, $gridHeight) + 50;
    my $width       = (NShades+1) * ColorSize + ($cols+1) * GridSize;
    $MW->geometry("${width}x$height+50+50");

    my $frame  = $MW->Frame;
    my $canvas = $frame->Canvas;
    $frame ->pack(-expand => 1, -fill => 'both');
    $canvas->pack(-expand => 1, -fill => 'both');
    $canvas->repeat(50, [ \&markee_crawl, $canvas ]);

    my $gridTop     = GridSize;
    my $gridBottom  = $gridTop + $rows * GridSize;
    my $gridLeft    = ColorSize * (NShades + 1);
    my $gridRight   = $gridLeft + $cols * GridSize;
    my @grid        = ($gridLeft, $gridTop, $gridRight, $gridBottom);

    my $KP = { frame     => $frame,
	       canvas    => $canvas,
	       rows 	 => $rows,
	       cols 	 => $cols,
	       rowGuides => $rowGuides,
	       colGuides => $colGuides,
	       grid      => \@grid,
	       pair      => [],  # row, col => [ square, chevron ]
	       dual      => [],  # square <=> chevron
	       RC        => [],  # square, chevron => [ row, col ]
	       stash     => {},
	     };

    bless $KP, $package;

    $KP->make_palette;
    $KP->make_grid;
    $KP->make_guides;
    $KP->make_buttons;

    $KP
}

sub KnitPattern::make_palette
{
    my $KP     = shift;
    my $canvas = $KP->{canvas};

    for my $r (0..$#Color)
    {
	for my $c (0..NShades-1)
	{
	    my @corners = map { $_ * ColorSize } ($c, $r, $c+1, $r+1);
	    my $color   = $Color[$r][$c];
	    my $id = $canvas->createRectangle(@corners, -fill => $color, -tags => [ $color ]);
	    $canvas->bind($id, '<1>' => sub { handle_color($canvas) } );
	}
    }

    my $v = ColorSize * (@Color + 0.5);

    my $h = ColorSize *  0.75;
    my @square = Polygon(\@Square, ColorSize, $h, $v);
    my $squareID = $canvas->createPolygon(@square, -fill => 'black', -tags => ['current-fill']);
    $canvas->bind($squareID, '<1>' => sub { handle_square($canvas) } );

    $h = ColorSize *  2.25;
    my @chevron = Polygon(\@Chevron, ColorSize, $h, $v);
    my $chevronID = $canvas->createPolygon(@chevron, -fill => 'black', -tags => ['current-fill']);
    $canvas->bind($chevronID, '<1>' => sub { handle_chevron($canvas) } );
}

sub KnitPattern::make_grid
{
    my $KP     = shift;
    my $canvas = $KP->{canvas};
    my $rows   = $KP->{rows};
    my $cols   = $KP->{cols};

    my $v = $KP->{grid}[TOP];
    for my $r (0..$rows-1)
    {
	my $h = $KP->{grid}[LEFT];
	for my $c (0..$cols-1)
	{
	    my @square = Polygon(\@Square, GridSize, $h, $v);
	    my $squareID = $canvas->createPolygon(@square,
						  -outline => 'grey',
						  -fill    => undef,
						  -tags    => [ qw(grid square) ]);

	    my @chevron = Polygon(\@Chevron, GridSize, $h, $v);
	    my $chevronID = $canvas->createPolygon(@chevron,
						   -fill   => undef,
						   -state  => 'hidden',
						   -tags   => [ qw(grid chevron) ]);

	    $KP->{dual}[$squareID ] =   $chevronID;
	    $KP->{dual}[$chevronID] =   $squareID;
	    $KP->{pair}[$r][$c]     = [ $squareID, $chevronID ];

	    my @rc = ($r, $c);
	    $KP->{RC}[$squareID ] = \@rc;
	    $KP->{RC}[$chevronID] = \@rc;

	    $h += GridSize;
	}
	$v += GridSize;
    }

    $canvas->CanvasBind('<ButtonPress-1>'   => sub { grid_mark	      ($KP) } );
    $canvas->CanvasBind('<B1-Motion>' 	    => sub { grid_drag	      ($KP) } );
    $canvas->CanvasBind('<ButtonRelease-1>' => sub { grid_release     ($KP) } );

    $canvas->CanvasBind('<ButtonPress-3>'   => sub { selection_mark   ($KP) } );
    $canvas->CanvasBind('<B3-Motion>' 	    => sub { selection_drag   ($KP) } );
    $canvas->CanvasBind('<ButtonRelease-3>' => sub { selection_release($KP) } );
}

sub KnitPattern::make_guides
{
    my $KP     	  = shift;
    my $canvas 	  = $KP->{canvas};
    my $rows   	  = $KP->{rows};
    my $cols   	  = $KP->{cols};
    my $rowGuides = $KP->{rowGuides};
    my $colGuides = $KP->{colGuides};
    my $left      = $KP->{grid}[LEFT];
    my $top       = $KP->{grid}[TOP];
    my $right     = $KP->{grid}[RIGHT];
    my $bottom    = $KP->{grid}[BOTTOM];

    my $v = $top;
    for (my $r=0; $r<=$rows; $r+=$rowGuides)
    {
	$canvas->createLine($left, $v, $right, $v, -tags => [ qw(guide) ]);
	$v += $rowGuides * GridSize;
    }

    my $h = $left;
    for (my $c=0; $c<=$cols; $c+=$colGuides)
    {
	$canvas->createLine($h, $top, $h, $bottom, -tags => [ qw(guide) ]);
	$h += $colGuides * GridSize;
    }
}

sub KnitPattern::make_buttons
{
    my $KP    = shift;
    my $frame = $KP->{frame};

    $frame->Button(-text    => 'Quit',
		   -command => \&Quit  )->pack(-side => 'left' , -padx => 20);

    $frame->Button(-text    => 'Load',
		   -command => \&Load  )->pack(-side => 'left' , -padx => 5);

    $frame->Button(-text    => 'Save',
		   -command => \&Save  )->pack(-side => 'left');

    $frame->Button(-text    => 'Print',
		   -command => \&Print )->pack(-side => 'left' , -padx => 5);

    $frame->Button(-text    => 'Resize',
		   -command => \&Resize)->pack(-side => 'left' , -padx => 20);

    $frame->Button(-text    => 'Help',
		   -command => \&Help  )->pack(-side => 'right', -padx => 20);
}


################################################################################
# Left Button - paint
#
sub grid_mark
{
    my $KP     = shift;
    my $canvas = $KP->{canvas};
    my $stash  = $KP->{stash };

    my($id)    = $canvas->find(withtag => 'source');
    my($x, $y) = $canvas->XY;

    if ($id)
    {
	if ($canvas->Inside($id, $x, $y))
	{
	    $stash->{active} = 'copy';
	    copy_mark($KP)
	}
	else
	{
	    $stash->{active} = undef;
	    $canvas->delete('source');
	}
    }
    else
    {
	$stash->{active} = 'square';
	square_mark($KP);
    }
}

sub grid_drag
{
    my $KP     = shift;
    my $canvas = $KP->{canvas};
    my $stash  = $KP->{stash };

    for ($stash->{active})
    {
	/square/ and square_drag($KP);
	/copy/   and copy_drag  ($KP);
    }
}

sub grid_release
{
    my $KP     = shift;
    my $canvas = $KP->{canvas};
    my $stash  = $KP->{stash };

    for ($stash->{active})
    {
	/copy/ and copy_release($KP);
    }

    $stash->{active} = undef;
}


sub square_mark
{
    my $KP     	= shift;
    my $canvas 	= $KP->{canvas};
    my $stash  	= $KP->{stash };

    my($x, $y)  = $canvas->XY;
    my($id)     = $canvas->find(overlapping => $x, $y, $x, $y);
    my @tags    = $canvas->gettags($id);
    grep { /grid/ } @tags or
	return;

    my $oldFill = $canvas->itemcget($id, -fill);
    my $fill    = $oldFill eq $CurrentFill ? undef : $CurrentFill;

    for my $id ($id, $KP->{dual}[$id])
    {
	$canvas->itemconfigure($id, -fill => $fill);
    }

    $stash->{square}{id  } = $id;
    $stash->{square}{fill} = $fill;
    $KP->{dirty} = 1;
}

sub square_drag
{
    my $KP     	= shift;
    my $canvas 	= $KP->{canvas};
    my $stash  	= $KP->{stash };

    my($x, $y)  = $canvas->XY;
    my($id)     = $canvas->find(overlapping => $x, $y, $x, $y);
    my @tags    = $canvas->gettags($id);
    grep { /grid/ } @tags or
	return;

    $id == $stash->{square}{id} and
	return;

    for my $id ($id, $KP->{dual}[$id])
    {
	$canvas->itemconfigure($id, -fill => $stash->{square}{fill});
    }

    $stash->{square}{id} = $id;
}

sub copy_mark
{
    my $KP     	= shift;
    my $canvas 	= $KP->{canvas};
    my $stash  	= $KP->{stash };

    $canvas->delete('dest');

    my($source) = $canvas->find(withtag => 'source');
    $source or return;

    my $xy = $canvas->XY;
    $stash->{dest  } = $xy;
    $stash->{margin} = Margin($canvas, $source, $xy);

    MakeMarkee($canvas, 'dest', $canvas->coords($source));
}

sub copy_drag
{
    my $KP     	 = shift;
    my $canvas 	 = $KP->{canvas};
    my $stash  	 = $KP->{stash };

    my $coords   = $stash->{dest};
    my($x1, $y1) = @$coords;
    my($x2, $y2) = $canvas->XY;
    ClipMargin($KP, $x2, $y2);

    my $dx = $x2 - $x1;
    my $dy = $y2 - $y1;

    $dx = int($dx / GridSize) * GridSize;
    $dy = int($dy / GridSize) * GridSize;

    if ($dx or $dy)
    {
	my $ids = $canvas->find(withtag => 'dest');
	for my $id (@$ids)
	{
	    $canvas->move($id, $dx, $dy);
	    $stash->{dest} = [ $x1+$dx, $y1+$dy ];
	}
    }
}

sub copy_release
{
    my $KP       = shift;
    my $canvas 	 = $KP->{canvas};

    my $idSource = $canvas->find(withtag => 'source');
    my $idDest   = $canvas->find(withtag => 'dest'  );
    @$idSource and @$idDest or return;

    copy_grid($KP, $idSource, $idDest);

    my @coords = $canvas->coords($idDest->[0]);
    for my $id (@$idSource)
    {
	$canvas->coords($id, @coords);
    }

    $canvas->delete('dest');
    $KP->{dirty} = 1;
}

sub copy_grid
{
    my($KP, $idSource, $idDest) = @_;
    my $canvas = $KP->{canvas};

    my @sourceCoords = $canvas->coords($idSource->[0]);
    my @destCoords   = $canvas->coords($idDest  ->[0]);

    my($sx1, $sy1, $sx2, $sy2) = @sourceCoords;
    my($dx1, $dy1, $dx2, $dy2) = @destCoords;

    my $h = GridSize / 2;

    my @sIDs = $canvas->find(overlapping => $sx1+$h, $sy1+$h, $sx1+$h, $sy1+$h);
    my($sID) = grep { $canvas->find(withtag => 'grid' ) } @sIDs;
    my $rc = $KP->{RC}[$sID];
    $rc or return;
    my($sr0, $sc0) = @$rc;

    my @dIDs = $canvas->find(overlapping => $dx1+$h, $dy1+$h, $dx1+$h, $dy1+$h);
    my($dID) = grep { $canvas->find(withtag => 'grid' ) } @dIDs;
    $rc = $KP->{RC}[$dID];
    $rc or return;
    my($dr0, $dc0) = @$rc;

    my $nRows = ($sy2 - $sy1) / GridSize;
    my $nCols = ($sx2 - $sx1) / GridSize;

    my @fill;

    for (my $r=0; $r<$nRows; $r++)
    {
	my $sr = $sr0 + $r;

	for (my $c=0; $c<$nCols; $c++)
	{
	    my $sc   = $sc0 + $c;
	    my $sgID = $KP->{pair}[$sr][$sc][0];
	    $fill[$sr][$sc] = $canvas->itemcget($sgID, -fill);
	}
    }

    for (my $r=0; $r<$nRows; $r++)
    {
	my $sr = $sr0 + $r;
	my $dr = $dr0 + $r;

	for (my $c=0; $c<$nCols; $c++)
	{
	    my $sc = $sc0 + $c;
	    my $dc = $dc0 + $c;

	    my $dgIDs = $KP->{pair}[$dr][$dc];
	    for my $dgID (@$dgIDs)
	    {
		$canvas->itemconfigure($dgID, -fill => $fill[$sr][$sc]);
	    }
	}
    }
}


################################################################################
# Right Button - selection
#
sub selection_mark
{
    my $KP = shift;
    my $canvas = $KP->{canvas};
    my $stash  = $KP->{stash };

    $canvas->delete('source');
    $stash->{source} = $canvas->XY;
}

sub selection_drag
{
    my $KP = shift;
    my $canvas = $KP->{canvas};
    my $stash  = $KP->{stash };

    my $coords = $stash->{source};
    $coords or
	return;

    my($x1, $y1) = @$coords;
    my($x2, $y2) = $canvas->XY;

    if ($x1 != $x2 and $y1 != $y2)
    {
	MakeMarkee($canvas, 'source', $x1, $y1, $x2, $y2);
    }
}

sub selection_release
{
    my $KP = shift;
    my $canvas = $KP->{canvas};
    my $stash  = $KP->{stash };

    my($id) = $canvas->find(withtag => 'source');
    $id or return;

    my($x1, $y1, $x2, $y2) = $canvas->coords($id);
    RoundIn($KP, $x1, $y1, $x2, $y2);

    if ($x1 < $x2 and $y1 < $y2)
    {
	MakeMarkee($canvas, 'source', $x1, $y1, $x2, $y2);
    }
    else
    {
	$canvas->delete('source');
    }
}

sub MakeMarkee
{
    my($canvas, $name, @xyxy) = @_;

    $canvas->delete($name);

    my $rb = $canvas->createRectangle(@xyxy, -outline    => 'black',
				      	     -dash       => ",",
				      	     -dashoffset => 0,
				      	     -tags       => ['markee', $name]);

    my $rw = $canvas->createRectangle(@xyxy, -outline    => 'white',
				      	     -dash       => ",",
				      	     -dashoffset => 4,
				      	     -tags       => ['markee', $name]);
}

sub markee_crawl
{
    my $canvas = shift;
    my @ids    = $canvas->find(withtag => 'markee');
    for my $id (@ids)
    {
	my $offset = $canvas->itemcget($id, '-dashoffset');
	$offset--;
	$offset &= 7;
	$canvas->itemconfigure($id, -dashoffset => $offset);
    }
}


################################################################################
# Pallet & View
#
sub handle_color
{
    my $canvas = shift;
    my $ids    = $canvas->find(withtag => 'current');
    my $id     = shift @$ids;
    $id or return;
    my @tags   = $canvas->gettags($id);
    ($CurrentFill) = grep { not /current/ } @tags;
    $canvas->itemconfigure('current-fill', -fill => $CurrentFill);
}

sub handle_square
{
    my $canvas = shift;
    $canvas->itemconfigure('square' , -state => 'normal');
    $canvas->itemconfigure('chevron', -state => 'hidden');
    $canvas->itemconfigure('guide'  , -state => 'normal');
}

sub handle_chevron
{
    my $canvas = shift;
    $canvas->itemconfigure('square' , -state => 'hidden');
    $canvas->itemconfigure('chevron', -state => 'normal');
    $canvas->itemconfigure('guide'  , -state => 'hidden');
}


################################################################################
# Buttons
#
sub Quit
{
    if ($KP->{dirty})
    {
	my $answer = $MW->messageBox(-icon => 'warning', -type => 'YesNo',
				     -title => '',
				     -message => "You have unsaved changes. Exit anyway?");

	$answer eq 'Yes'
	    or return;
    }

    exit;
}

sub Load
{
    if ($KP->{dirty})
    {
	my $answer = $MW->messageBox(-icon    => 'warning', -type => 'YesNo',
				     -title   => '',
				     -message => "You have unsaved changes. Discard them?");
	return unless
	    $answer eq 'Yes';
    }

    my @types  = (['ColorWork files', '.ckn']);
    my @filter = $OSNAME eq 'MSWin32' ? () : (-filetypes => \@types);
    my $file = $MW->getOpenFile(@filter);
    $file or return;

    open FILE, $file or do
    {
	$MW->messageBox(-title   => 'Error',
			-type    => 'OK',
			-icon    => 'error',
			-message => "Can't open $file: $!");
	return;
    };

    my $line = <FILE>;
    my($magic,  @size) = split ' ', $line;
    if ($magic ne MAGIC or not CheckRange(1,1000, @size))
    {
	$MW->messageBox(-title   => 'Error',
			-type    => 'OK',
			-icon    => 'error',
			-message => "$file is not a valid ColorWork file");
	return;
    }

    if (not SameSize($KP, @size))
    {
	$KP->{frame}->destroy;
	$KP = new KnitPattern $MW, @size;
    }

    my $canvas = $KP->{canvas};
    my $cols   = $KP->{cols};
    my $r      = 0;
    while (<FILE>)
    {
	my @colors = split;
	for my $c (0..$cols-1)
	{
	    my $ids   = $KP->{pair}[$r][$c];
	    my $color = $colors[$c];
	    my $fill  = $color eq '.' ? undef : $color;
	    for my $id (@$ids)
	    {
		$canvas->itemconfigure($id, -fill => $fill);
	    }
	}
	$r++;
    }

    $KP->{dirty} = 0;
}

sub SameSize
{
    my($KP, $rows, $cols, $rowGuides, $colGuides) = @_;

    $rows      == $KP->{rows}      and
    $cols      == $KP->{cols}      and
    $rowGuides == $KP->{rowGuides} and
    $colGuides == $KP->{colGuides}
}

sub Save
{
    my $canvas 	  = $KP->{canvas};
    my $rows   	  = $KP->{rows};
    my $cols   	  = $KP->{cols};
    my $rowGuides = $KP->{rowGuides};
    my $colGuides = $KP->{colGuides};

    my @types = (['ColorWork files', '.ckn']);
    my @filter = $OSNAME eq 'MSWin32' ? () : (-filetypes => \@types);
    my $file = $MW->getSaveFile(-defaultextension => '.ckn', @filter);
    $file or return;

    open FILE, "> $file" or do
    {
	$MW->messageBox(-title   => 'Error',
			-type    => 'OK',
			-icon    => 'error',
			-message => "Can't open $file: $!");
	return;
    };

    print FILE MAGIC, " $rows $cols $rowGuides $colGuides\n";

    for my $r (0..$rows-1)
    {
	for my $c (0..$cols-1)
	{
	    my $id = $KP->{pair}[$r][$c][0];
	    my $fill    = $canvas->itemcget($id, -fill);
	    my $color   = $fill ? $fill : '.';
	    print FILE "$color ";
	}
	print FILE "\n";
    }

    $KP->{dirty} = 0;
}

sub Print
{
    my $canvas = $KP->{canvas};

    my @types = (['Postscript files', '.ps']);
    my $file = $MW->getSaveFile( # -filetypes     => \@types,
				-defaultextension => '.ps');
    $file or return;

    my $left = $KP->{grid}[LEFT];
    my $top  = $KP->{grid}[TOP ];
    $canvas->postscript(-file => $file, -rotate => 1, -x => $left, -y => $top);
}

sub Resize
{
    my $rows   	  = $KP->{rows};
    my $cols   	  = $KP->{cols};
    my $rowGuides = $KP->{rowGuides};
    my $colGuides = $KP->{colGuides};

    my $dialog = $MW->DialogBox(-title 	        => 'Resize',
				-default_button => 'OK',
				-buttons        => [qw(OK Cancel)]);

    my $rh = $dialog->add('Label', -text  => 'Grid size');
    my $gh = $dialog->add('Label', -text  => 'Guideline interval');

    my $rl = $dialog->add('Label', -text  => 'Rows');
    my $rs = $dialog->add('Entry', -text  => $rows     , -width => 4);
    my $rg = $dialog->add('Entry', -text  => $rowGuides, -width => 4);

    my $cl = $dialog->add('Label', -text  => 'Cols');
    my $cs = $dialog->add('Entry', -text  => $cols     , -width => 4);
    my $cg = $dialog->add('Entry', -text  => $colGuides, -width => 4);

    Tk::grid('x', $rh, $gh, -padx => 10, -sticky => 'w');
    Tk::grid($rl, $rs, $rg, -padx => 10, -sticky => 'w');
    Tk::grid($cl, $cs, $cg, -padx => 10, -sticky => 'w');

    my $answer = $dialog->Show;

    ($rows, $cols, $rowGuides, $colGuides) = map { $_->get } ($rs, $cs, $rg, $cg);

    if ($answer eq 'OK' and not SameSize($KP, $rows, $cols, $rowGuides, $colGuides))
    {
	if ($KP->{dirty})
	{
	    my $answer = $MW->messageBox(-icon    => 'warning', -type => 'YesNo',
					 -title   => '',
					 -message => "You have unsaved changes. Discard them?");

	    $answer eq 'Yes'
		or return;
	}

	ClipRange(1, 1000, $rows, $cols, $rowGuides, $colGuides);

	$KP->{frame}->destroy;
	$KP = new KnitPattern $MW, $rows, $cols, $rowGuides, $colGuides;
    }
}

sub Help
{
    my $dialog = $MW->DialogBox(-title => 'Help',
				-default_button => 'OK',
				-buttons        => [qw(OK)]);

    my $message = $dialog->add('Message', -width => 500, -text => <<EOT);
ColorWork $Revision

In the palette: Left click to set the current color.
The square and chevron below the palette show the current color.
Click the square or chevron to toggle the grid view.

In the grid:
Left click to set a square to the current color.
Left click again to clear the square.
Left click and drag to set lots of squares.

Right click and drag to create a selection.
Then left click drag'n'drop to make copies of the selection.
EOT

    $message->pack;
    $dialog->Show;
}


################################################################################
# Utility
#
sub RoundIn
{
    my $KP   = shift;
    my $grid = $KP->{grid};
    my($left, $top, $right, $bottom) = @$grid;

    ClipRange($left, $right , $_[X1], $_[X2]);
    ClipRange($top , $bottom, $_[Y1], $_[Y2]);

    RoundRight($KP, $_[X1]);
    RoundDown ($KP, $_[Y1]);
    RoundLeft ($KP, $_[X2]);
    RoundUp   ($KP, $_[Y2]);
}

sub RoundUp
{
    my $KP  = shift;
    my $top = $KP->{grid}[TOP];
    Round($top, 0, @_)
}

sub RoundDown
{
    my $KP  = shift;
    my $top = $KP->{grid}[TOP];
    Round($top, 1, @_)
}

sub RoundLeft
{
    my $KP   = shift;
    my $left = $KP->{grid}[LEFT];
    Round($left, 0, @_)
}

sub RoundRight
{
    my $KP   = shift;
    my $left = $KP->{grid}[LEFT];
    Round($left, 1, @_)
}

sub Round
{
    my $origin = shift;
    my $up     = shift;

    for (@_)
    {
	my $dx = $_ - $origin;
	$dx += GridSize-1 if $up;
	$dx = int($dx / GridSize) * GridSize;
	$_ = $origin + $dx
    }
}

sub Polygon
{
    my($corners, $size, $h, $v) = @_;
    my @corners;

    for (my $i=0; $i<@$corners; $i+=2)
    {
	push @corners, $h + $size * $corners->[$i  ];
	push @corners, $v + $size * $corners->[$i+1];
    }

    @corners
}

sub Offset
{
    my($corners, $h, $v) = @_;

    $corners->[0] += $h;
    $corners->[1] += $v;
    $corners->[2] += $h;
    $corners->[3] += $v;
}

sub max
{
    my $max = shift;
    for (@_) { $max < $_ and $max = $_ }
    $max
}

sub Margin
{
    my($canvas, $rect, $xy) = @_;

    my($x, $y) = @$xy;
    my($left, $top, $right, $bottom) = $canvas->coords($rect);
    [ $x-$left, $y-$top, $right-$x, $bottom-$y ]
}

sub ClipMargin
{
    my $KP     = shift;
    my $grid   = $KP->{grid};
    my $margin = $KP->{stash}{margin};

    my($gl, $gt, $gr, $gb) = @$grid;
    my($ml, $mt, $mr, $mb) = @$margin;

    ClipRange($gl+$ml, $gr-$mr, $_[0]);
    ClipRange($gt+$mt, $gb-$mb, $_[1]);
}

sub ClipRange
{
    my $min = shift;
    my $max = shift;

    for (@_)
    {
	$_ < $min and $_ = $min;
	$_ > $max and $_ = $max;
    }
}

sub CheckRange
{
    my $min = shift;
    my $max = shift;

    for (@_)
    {
	$_ < $min and return 0;
	$_ > $max and return 0;
    }

    1
}

################################################################################
# Methods
#
sub Tk::Canvas::XY
{
    my $canvas = shift;

    my $x = $canvas->canvasx($Tk::event->x);
    my $y = $canvas->canvasy($Tk::event->y);

    my @xy = ($x, $y);
    wantarray ? @xy : \@xy
}

sub Tk::Canvas::Inside
{
    my($canvas, $id, $x, $y) = @_;

    my($x1, $y1, $x2, $y2) = $canvas->coords($id);

    $x1 <= $x and $x <= $x2 and $y1 <= $y and $y <= $y2
}

sub Tk::Canvas::Intersect
{
    my($canvas, $idA, $idB) = @_;

    my($ax1, $ay1, $ax2, $ay2) = $canvas->coords($idA);
    my($bx1, $by1, $bx2, $by2) = $canvas->coords($idB);

    Intersect($ax1, $ax2, $bx1, $bx2) and Intersect($ay1, $ay2, $by1, $by2)
}

sub Intersect
{
    my($a, $b, $x, $y) = @_;

    $x < $b and $a < $y
}

__END__

=head1 NAME

ColorWork - colorwork knitting pattern editor

=head1 SYNOPSIS

B<ColorWork>

=head1 DESCRIPTION

B<ColorWork> is an editor for creating colorwork knitting patterns.
The stitches can be viewed either as squares (easier to edit),
or chevrons (closer to the finished appearance).

=head2 Creating patterns

Click on the pallet to set the current color.
The big square and chevron show the currently selected color.

Left-click on the big square for the grid view.
Left-click on the big chevron for the chevron view.

Left-click on the grid to set a square to the current color.
Left-click again to clear it.
Left-click and drag to set/clear many squares.

Right-click and drag on the grid to select a rectangular region.
The selection is shown by a markee (crawling) outline.
When you Right-click-up, the markee snaps to the grid lines.

Left-click and drag inside the selection picks up the selection and drops a copy of it elsewhere.
The markee goes with the copy.
After you drop it, you can click and drag to drop another copy.

To clear the selection

=over 4

=item *

left-click outside the selection

=item *

right-click anywhere

=back


=head2 Load and Save

The B<Save> button saves the current pattern to a file,
with a C<.ckn> extension

The B<Load> button loads a saved pattern from a C<.ckn> file.

=head2 Resize

The B<Resize> button brings up a dialog box that allows you
to change the size of the pattern, and the guideline interval.

=head2 Printing

The B<Print> button writes the current pattern to a PostScript (C<.ps>) file.
You have to print the PostScript file yourself.

=head1 REQUIRES

B<ColorWork> is written Perl/Tk.
To run it, you need

=over 4

=item *

Perl

=item *

C<Tk>

=back

If you want to print the patterns,
you need some way to print PostScript file.

=head1 BUGS

=over 4

=item *

File extension filtering is broken on Win32.

=item *

The Resize dialog should do proper validation on the Entry widgets.

=back


=head1 TODO

Nothing planned.
Send suggestions, bugs, etc. to <swmcd@world.std.com>


=head1 AUTHOR

Steven McDougall <swmcd@world.std.com>


=head1 COPYRIGHT

Copyright (c) 2007-2008 by Steven McDougall. This program is free
software; you can redistribute it and/or modify it under the same
terms as Perl itself.