#! /usr/bin/perl5.8.5

#! /usr/bin/perl
=head1  gdraw.pl Simple TK graphics for Perl.  v.2.2.1-perl-beta 01/07/08.  (c) Boley.

 gdraw.pl Simple TK graphics for Perl.   version 2.2.1-perl-beta 01/07/08.  Copyright 2008 boley.     #####

 perl interface to Tk graphics toolkit, translated from the original scheme
 see original scheme STk or python versions for details & examples  ###
 To use this in the simplest way, put the following at the top of your file:
     require 'gdraw.pl';
 then all your program to build up a Tk tableau,
 then the following at the end [this starts the Tk activity]
       MainLoop();
 Each of the fcns that create an object return the object's handle.

 See the companion sample test driver for a simple example: testgdraw.pl

 2008-01-07 fixed drag bug w/ negative indices (tomerl)
 2005-11-23 fixed get_color/set_color, get_text, etc.

=head1 List of functions provided:
  $gdraw_canvasroot			# Tk root window object 
  $gdraw_canvas				# Tk canvas object
  stall()				# update display and continue.
  stall(@msgs)				# update display. If @msgs given, then
					# print it and wait for user commands 
  draw_line($x1,$y1,$x2,$y2)		# draws a line from (x1,y1) to (x2,y2) 
  draw_text($string,$x,$y,@options)	# draws text at (x,y) 
  draw_oval($x1,$y1,$x2,$y2)		# draws an oval from (x1,y1) to (x2,y2) 
  fill_oval($x1,$y1,$x2,$y2,$color)	# fills an oval from (x1,y1)
					# to (x2,y2) 
  draw_rectangle($x1,$y1,$x2,$y2)	# draws an rectangle from (x1,y1)
					# to (x2,y2) 
  fill_rectangle($x1,$y1,$x2,$y2,$color)# fills an rectangle from (x1,y1)
				        # to (x2,y2) 
  clear_canvas()			# Clears the canvas 
  clear_graphics			# { clear_canvas; }
  print_canvas($filename,%options)	# save a postscript image of canvas
  get_color($ID)			# get color for item. 
  set_color($ID,$color) 		# set color for item. 
  get_text($ID) 			# get text for item. 
  set_text($ID,$new_text)		# set text for item. 
  get_width($ID)			# get width for item. $ID=0 => canvas. 
  set_width($ID,$new_hgt,$new_width)	# set width for item.
  get_font_info($ID)		# get font info for a text object. 
  get_font_size($ID)		# get font size (a number) . 
  set_font_size($ID,$fontsize)	# set font size (a number) for $ID,
				# which should be a text object. 
  get_coords($ID)		# get X-Y coordinates: [left,top,right,bottom]
  set_coords($ID,@coords)	# set X-Y coordinates of item,
				# [left,top,right,bottom].
  raise($ID)			# raise object on top of all other objects. 
  lower($ID)			# lower object, hiding behind other objects. 
  get_binding($ID,$button)	# get binding associated with object (from
				# in a home-grown array) 
  set_binding($ID,$thunk,$button)	# set procedure binding for item. 
  get_motion_binding($ID)		# get motion binding for object $ID. 
  set_motion_binding($ID,$thunk)	# set procedure motion binding for item 
  get_release_binding($ID)		# get procedure binding for releasing a
		     			# a button
  set_release_binding($ID,$thunk)	# set procedure binding for releasing
					# a button (not in orig gdraw) 
  get_mouse_coords()	# get mouse coordinates 
  get_type($ID) 	# get type of object (e.g. oval, rectangle, text,...) 
  get_IDs($arg) 	# get all $IDs: a list of all objects on canvas. 
  tkdelete($ID) 	# delete is a reserved word # delete an item on
			# the canvas. $ID can be 'all' or 0.	 
  endow_with_drag($ID,$drag,$clear,$button)	# endow $ID with the ability
			# to be dragged (uses drag_obj & clear_drag_obj)
  drag_obj($ID,$m0x,$m0y,@c0_flags)	# default dragging fcn
			# init coords are in m0 (mouse) and c0 (figure).
			# flags can be ('corner')
  clear_drag_obj($ID)	# fcn called when mouse released. This clears
			# the motion binding (dragging). 
  after($n,$p)		# after delay of n msec, do thunk p. 
  gdraw_errmsg(@msgs)	# generate an error message
  gdraw_init_canvas()	#  initialize canvas
  gdraw_init_graphics() { gdraw_init_canvas() }
  MainLoop()		# Tk::MainLoop : start Tk's main loop.

=cut

use Tk;
use strict;
use warnings;

print "=== gdraw.pl version 2.2.1-perl-beta 01/07/08. Copyright 2008 boley ===\n";
print "===         Simple Perl interface to Tk graphics toolkit.         ===\n";

our $gdraw_canvasroot ;
our $gdraw_canvas ;

sub stall { my @msgs = @_;
   #"update display. If msgs given, then print it, and wait for user commands"
   if ($#_ < 0 ) {
      $gdraw_canvasroot->update;
      }
   else {
      print join("\n",@msgs),"\n";
      print "=== enter Perl commands.  finish with 'last'\n";
      while (1) {
	  no strict;
          $gdraw_canvasroot->update;
	  print "P> ";
	  print eval(<>);
	  print "$@\n";
	  }
      $gdraw_canvasroot->update;
      }
   }

sub draw_line { my ($x1,$y1,$x2,$y2) = @_;
   #"draws a line from (x1,y1) to (x2,y2)";
   $gdraw_canvas->create('line',$x1,$y1,$x2,$y2);
   }

sub draw_text { my ($string,$x,$y,@options)=@_;
   #"draws text at (x,y)";
   my $c = grep( /\Acorner\z/i, @options);
   if ($c) {
      $gdraw_canvas->create('text',$x,$y,'-text',$string,'-anchor','sw');
      }
   else {
      $gdraw_canvas->create('text',$x,$y,'-text',$string);
      }
   }

sub draw_oval { my ($x1,$y1,$x2,$y2) = @_;
   #"draws an oval from (x1,y1) to (x2,y2)";
   $gdraw_canvas->create('oval',$x1,$y1,$x2,$y2);
   }

sub fill_oval { my ($x1,$y1,$x2,$y2,$color) = @_;
   #"fills an oval from (x1,y1) to (x2,y2)";
   if (not $color) { $color='black'; }
   my $ID=$gdraw_canvas->create('oval',$x1,$y1,$x2,$y2);
   set_color($ID,$color);
   $ID;
   }

sub draw_rectangle { my ($x1,$y1,$x2,$y2) = @_;
   #"draws an rectangle from (x1,y1) to (x2,y2)";
   $gdraw_canvas->create('rectangle',$x1,$y1,$x2,$y2);
   }

sub fill_rectangle { my ($x1,$y1,$x2,$y2,$color) = @_;
   #"fills an rectangle from (x1,y1) to (x2,y2)";
   if (not $color) { $color='black'; }
   my $ID=$gdraw_canvas->create('rectangle',$x1,$y1,$x2,$y2);
   set_color($ID,$color);
   $ID;
   }

sub clear_canvas {
   #"Clears the canvas (synonym: clear_graphics).";
   my @all = $gdraw_canvas->find('all');
   foreach my $i (@all) {
       $gdraw_canvas->delete($i);
       }
   }
sub clear_graphics { clear_canvas; }


sub print_canvas { my ($filename,%options) = @_;
   #"  ; save a postscript image of the canvas;\
   #; options:;\
   #;     colormap       varName;\
   #;     colormode      "color" | "grey" | "mono";\
   #;     file           fileName        e.g. "all.ps";\
   #;     fontmap        varName;\
   #;     height         size            e.g. "8i";\
   #;     pageanchor     anchor;\
   #;     pageheight     size            e.g. "8i";\
   #;     pagewidth      size            e.g. "8i";\
   #;     pagex          position;\
   #;     pagey          position;\
   #;     rotate         boolean;\
   #;     width          size            e.g. "8i";\
   #;     x              position;\
   #;     y              position ;\
   #";
   $options{'file'}=$filename;
   if (not exists $options{'colormode'}) { $options{'colormode'}='color'; };
   my @opts = (%options);
   $gdraw_canvas->postscript(@opts);
   }

sub get_color { my ($ID) = @_;
   #"get color for item.";
   my $temp;
   if ( $ID > 0 ) { $temp=$gdraw_canvas->itemconfigure($ID,'-fill'); }
   else           { $temp=$gdraw_canvas->configure('-background'); } ;
   ${$temp}[-1]
   }

sub set_color { my ($ID,$color) = @_;
   #"set color for item.";
   my $temp;
   if ($ID > 0 ) { $temp=$gdraw_canvas->itemconfigure($ID,'-fill',$color); }
   else          { $temp=$gdraw_canvas->configure('-background',$color); } ;
   }


sub get_text { my ($ID) = @_; 
   #"get text for item.";
   my $ans;
   if ( $ID > 0 ) { $ans = $gdraw_canvas->itemconfigure($ID,'-text') }
   else           { $ans = '' };
   ${$ans}[-1]
   }

sub set_text { my ($ID,$new_text)= @_; 
   #"set text for item.";
   if ( $ID > 0 ) { $gdraw_canvas->itemconfigure($ID,'-text',$new_text); }
   }

sub get_width { my ($ID) = @_; 
   #"get width for item. For $ID=0, retrieves window size.";
   if ( $ID > 0 ) { my @temp = ($gdraw_canvas->itemconfigure($ID,'width'));
                    return $temp[-1] 
		  }
   else           { my $temp1=$gdraw_canvas->height();
                    my $temp2=$gdraw_canvas->width();
                    return ($temp1,$temp2)
                  }
   }

sub set_width { my ($ID,$new_hgt,$new_width) = @_; 
   #"set width for item.;\
   #for $ID=0, sets window size. accepts either 2 numbers or a tuple of 2 numbers";
   if ( $ID > 0 ) 
      { $gdraw_canvas->itemconfigure($ID,'-width',$new_hgt); }
   else
      { $gdraw_canvas->configure('-height',$new_hgt,'-width',$new_width) }
   }

sub get_font_info { my ($ID) = @_; 
    #"retrieve font info for a text object.";
    my @f = ($gdraw_canvas->itemconfigure($ID,'-font'));
    my @font = ( $f[-2] =~ /\A\S*/ );
    (@f)
   }

sub get_font_size { my ($ID) = @_; 
    #"retrieve font size (a number) for a text object.";
    my @f = ($gdraw_canvas->itemconfigure($ID,'-font'));
    my $fontinfo = ${$f[-1]};
    my @fs = ( $fontinfo =~ /\b\d+\z/g ) ;
    $fs[0]
   }

sub set_font_size { my ($ID,$fontsize) = @_; 
    #"set font size (a number) for $ID, which should be a text object.";
    my @f = ($gdraw_canvas->itemconfigure($ID,'-font'));
    my $fontinfo = ${$f[-1]};
    my @font = ( $fontinfo =~ /\A\S*\s/g );
    my @fs = ( $fontinfo =~ /\b-\d+\z/g ) ;
    #print "set_font_size: ","@f","\n";
    #print "set_font_size: $fontinfo  \n";
    my $new_font =  $font[0] .  $fontsize ;
    $gdraw_canvas->itemconfigure($ID,'-font',$new_font);
   }


sub get_coords { my ($ID) = @_; 
   #"get X-Y coordinates of item, [left,top,right,bottom]";
   if ( $ID > 0 ) { ($gdraw_canvas->coords($ID)); }
   else { ($gdraw_canvas->height(),$gdraw_canvas->width()); }
   }

sub set_coords { my ($ID,@coords) = @_; 
   #"set X-Y coordinates of item, [left,top,right,bottom].;"
   if ( $ID > 0 ) { $gdraw_canvas->coords($ID,@coords) }
   else { gdraw_errmsg("Use set_width to change the shape of the canvas") }
   }

sub raise { my ($ID) = @_ ;
   #"raise object, making it visible over all other objects.";
   if ( $ID > 0 ) { $gdraw_canvas->raise($ID); }
   }

sub lower { my ($ID) = @_; 
   #"lower object, hiding behind other objects.";
   if ( $ID > 0 ) {  $gdraw_canvas->lower($ID); }
   }


sub get_binding { my ($ID,$button) = @_; 
   #"get binding associated with object (from in a home-grown array)";
   if ( $#_ < 1 ) { $button = '<Button>'; }
   if ( $button =~ /\A\d+\z/ ) {  $button='<Button-' . $button . '>' } ;
   my @ans;
   my $ans;
   if (not $button) {
      if   ( $ID > 0 ) { @ans = ($gdraw_canvas->bind($ID)); }
      else             { @ans = ($gdraw_canvasroot->bind($gdraw_canvas));}
      (@ans)
      }
   else  {
      if   ( $ID > 0 ) { $ans = $gdraw_canvas->bind($ID,$button); }
      else             { $ans = $gdraw_canvasroot->bind($gdraw_canvas,$button);}
      ${$ans}[0]      # synomym for  @{$ans}->[0] 
      } ;
   }

sub set_binding { my ($ID,$thunk,$button) = @_; 
   #"set procedure binding for item.";
   if ( $#_ < 2 ) { $button = '<Button>'; }
   if ( $button =~ /\A\d+\z/ ) {  $button='<Button-' . $button . '>' } ;
   if ( not $thunk ) { $thunk = '' } ;
   if ( $ID > 0 ) { $gdraw_canvas->bind($ID,$button,$thunk); }
   else           { $gdraw_canvasroot->bind($gdraw_canvas,$button,$thunk); }
   }


sub get_motion_binding { my ($ID) = @_;
   #"get motion binding for object $ID.";
   get_binding($ID,'<Motion>');
   }

sub set_motion_binding { my ($ID,$thunk) = @_; 
   #"set procedure motion binding for item.";
   set_binding($ID,$thunk,'<Motion>');
   }

sub get_mouse_coords { # no arguments 
   #"get mouse coordinates";
   my $x=$gdraw_canvasroot->rootx();
   my $y=$gdraw_canvasroot->rooty();
   my @p=($gdraw_canvasroot->pointerxy());
   ($p[0]-$x,$p[1]-$y);
   }

sub get_type { my ($ID) = @_; 
   #"get type of object (e.g. oval, rectangle, text, etc.).";
   if ( $ID > 0 ) {  $gdraw_canvas->type($ID); }
   else           {  'canvas'; }
   }

sub get_IDs { my ($arg) = @_; 
   #"get all $IDs: a list of all objects on canvas.";
   if ( $#_ < 0 ) { $arg = 'all' } ;
   $gdraw_canvas->find($arg);
   }

sub tkdelete { my ($ID) = @_;  # delete is a reserved word
   #"delete an item on the canvas.  $ID can be 'all' or 0. ";
   if    ( $ID eq  'all' ) { clear_canvas(); }
   elsif ( $ID==0 )        { clear_canvas(); }
   else {
      my @all = get_IDs();
      foreach my $i (@all) { if ($i == $ID ) { $gdraw_canvas->delete($i); } }
      }
   }

#### Functions not in the older gdraw.scm file.;

sub get_release_binding { my ($ID) = @_; 
   #"get procedure binding for releasing a button for item. (not in orig gdraw)";
   get_binding($ID,'<ButtonRelease>');
   }

sub set_release_binding { my ($ID,$thunk) = @_; 
   #"set procedure binding for releasing a button for item. (not in orig gdraw)";
   set_binding($ID,$thunk,'<ButtonRelease>');
   }


sub drag_obj { my ($ID,$m0x,$m0y,@c0_flags) = @_;
    # init coords are in m0 (mouse) and c0 (figure).;
    #"fcn called during dragging when mouse moves. This fcn drags the figure.;\
    #if flags includes 'corner', then only move the upper left corner.";
    my @m = get_mouse_coords();
    my @diff = ($m[0]-$m0x,$m[1]-$m0y);
#   my @c0 = grep( /\A\d+\z/, @c0_flags);  -- bug drag object partialy to out of the window
    my @c0 = grep( /\b\-?\d+\b/, @c0_flags); ## slight mod to tomerl's fix 2008-01-07
    my $corner = grep( /\Acorner\z/i, @c0_flags);
    $c0[0] = $c0[0] + $diff[0];
    $c0[1] = $c0[1] + $diff[1];
    if ( ( $#c0 > 1 ) and ( not $corner )) {
        $c0[2] = $c0[2] + $diff[0];
        $c0[3] = $c0[3] + $diff[1];
	}
    set_coords($ID,@c0);
   }

sub clear_drag_obj { my ($ID) = @_; 
    #"fcn called when mouse released. This clears the motion binding (dragging).";
    set_motion_binding(0,"");
   }

sub endow_with_drag { my ($ID,$drag,$clear,$button) = @_; 
    #"endow $ID with the ability to be dragged (uses drag_obj & clear_drag_obj;\
    #as default dragging functions." ;
    if ( not $drag ) { $drag = \&drag_obj }
    if ( not $clear ) { $clear = \&clear_drag_obj } 
    if ( not $button ) { $button = '<Button>' } 
    my $drag_item = sub { 
        my @m0 = get_mouse_coords();
        my @c0 = get_coords($ID);
	my $clrdrag = sub { &$clear($ID) };      # clears the motion binding.;
        my $move = sub { &$drag($ID,@m0,@c0) };  # actually moves the object.;
        set_release_binding(0,$clrdrag);# end the drag when button released;
        set_motion_binding(0,$move);    # move the object when the mouse moves.;
	&$move();
	};
    set_binding($ID,$drag_item,$button);# endow $ID with dragging capability.;
   }

sub after { my ($n,$p) = @_; 
    #"after delay of n msec, do thunk p.";
    $gdraw_canvas->after($n,$p);
   }

##### utilities;

sub gdraw_errmsg { my (@msgs) = @_; 
   print STDERR "====== gdraw error: ";
   print STDERR "@msgs";
   print STDERR "\n";
   }

sub gdraw_init_canvas { # no arguments
   if (not Exists ($gdraw_canvasroot ) ) {
       $gdraw_canvasroot = MainWindow->new;
       $gdraw_canvas = $gdraw_canvasroot->Canvas;
       $gdraw_canvas->pack();
       $gdraw_canvasroot->update;
       $gdraw_canvas->configure('-height','6i','-width','6i');
       }
   } ;

sub  gdraw_init_graphics { gdraw_init_canvas() };

gdraw_init_canvas();

1
__END__

=head1 Example

 # This example draws a green circle.  You must click on the canvas to
 # start it moving. click again to stop it.

 use strict; use warnings;

 do 'gdraw.pl';

 ## build all the basic objects.
 my $circle=fill_oval(20,40,60,80,'green');  ## the ball
 stall();                                    ## draw it now.
 my @CanvasDim=get_width(0);                 ## where's the right wall?
 my $counter = 0;                            ## count the iterations
 my $paused = 1;                             ## global 'paused' state.

 sub f { my @position = get_coords($circle); ## move the circle.
         $position[0] += 2;
         $position[2] += 2;
         if ($position[2] >= $CanvasDim[0])
            { $position[0]=20;   $position[2]=60   };
         set_coords($circle,@position);
         print "\r$counter    ";
         $counter++;
         stall();
         return @position}
 
 sub g { if ($paused) {print "pause\n";return}; f() ; after(50,\&g) };
        ## The 'g' procedure checks the paused state, moves the ball, 
        ## and finally repeats itself after 50 msec.

 sub toggle { $paused = not $paused ; g() } ## toggle state, then try main task
 
 set_binding(0,\&toggle);                   ## what to do upon mouse click.
 
 my $textbox = draw_text('Click here to start and stop',200,300);

 MainLoop();                                ## Tell Tk to start processing.