#!/usr/bin/perl

my $path;
my $perl;

=head1 NAME

 vptk - Perl/Tk Visual resource editor (canvas edition)

=head1 SYNOPSIS

 vptk [-help]

   -h[elp]  - show this help

=head1 DESCRIPTION

  1. General considerations
  =========================

  * The project supply toolkit for Perl/Tk canvas design
  * End-user may be not familiar with Perl/Tk

  2. User interface
  =================

  * All data stored in Perl/Tk include-file form
  * Most functions accessible both from pull-down menu,
    toolbar panel and by keyboard shortcuts

  3. Restrictions
  ===============

  * No infinite scaling for graphic objects
  * One-level undo only (maybe increased?)

  4. Main features
  ================

  * Widgets stored in Perl/Tk include-file format
  * All basic canvas objects supported: 
    line, poly, curves, oval, arc, chord, rectangle
  * Object editing by using selection bars
  * Objects order supported
  * Toolbar ballons and status string
  * File setup: description, background color, output precision
  * Constraint support for uniform figures
  * Arc/Pie support
  * Cursor changes on selection/object
  * Undo for all artwork modifications (incl. drag/resize)
  * Group select (for move/duplicate/erase only) - with massive undo
  * Help & HTML documentation
  * Unlimited undo/redo
  * Post-script print
 
  5. To be implemented
  ====================

  * Point remove (in polygons)
  * Figures type conversion (oval-circle,square-rect,line-polyline,
  line-curve,polyline-polygon,polygon-splash)
  * Cursor position display (on/off)
  * Strict checks of 'points' list (pairs, minimal number, constraints)
  * Add/remove objects to/from group selection with shift+click
  * NumEntry for numeric values

  6. Known bugs
  =============

  * transformations produce wrong results when scale is not 1:1 - blocked
  * dragging uniform figures sometime produce 'non-uniform' results

=cut

BEGIN
{
  $path=$0;
  $path=~s#[^/\\]+$##;
  $path='.' unless $path;
  unshift @INC,$path;
  foreach($^X, '/usr/local/bin/perl', '/usr/bin/perl')
  {
    if(-f $_)
    {
      $perl = $_;
      last;
    }
  }
  die "$0 installation error: directory ${path}/toolbar not found!\n"
    unless -d "${path}/toolbar";
}

use strict;
use Tk 800;

use Tk::DialogBox;
use Tk::Dialog;
use Tk::TList;
use Tk::Photo;
use Tk::Checkbutton;
use Tk::Canvas;
use Tk::Balloon;
use Tk::ROText;

if (grep /^--?h/,@ARGV)
{
  # for real perl script only!
  # does not work on M$ Win EXE-file
  system "perldoc $0";
  exit 1;
}

my $ver=q$Revision: 1.2 $;

my $bg_color='gray';
my $changes;          # Modifications flag
my $precision=2;      # Output file floating point precision
my %canv_obj=();      # internal structure for objects storing
my @canv_obj=();      # objects order array
my $cnv_bg=$bg_color; # canvas background
my $cnv_t='';         # canvas title (descriptions)
my $cnv_fullcode=0;   # generate full executable code
my $lastfile='';      # last file used in Open/Save
my $selected_id='';   # ID for selected object
my @undo=();          # Undo buffer
my @redo=();          # Redo buffer
my $obj_count=0;      # Uniq object ID counter
my $scale=1;          # Visualisation scale
my $scale_h='1:1';    # Visualisation scale (human-friendly form)
my ($sx,$sy);         # saved initial mouse x,y for dragging procedure
my $mouse_drag='';    # mouse gragging function
my $selection_type=1; # 1 - regular; 2 - fine edit
my $selection=0;      # 'selection painted' flag
# The following table describes geometric objects translation to Tk canvas:
my (%obj2canvas)=(
  Oval=>'oval',Circle=>'oval',Line=>'line',PolyLine=>'line',Splash=>'polygon',
  Polygon=>'polygon',Curve=>'line',Rectangle=>'rectangle',Square=>'rectangle',
  Pie=>'arc',Chord=>'arc');
# and here is the table of all objects' properties
my (%attr) = (
'Line'=>[-arrow=>'arrowside',-width=>'linewidth',-fill=>'color','points'=>2,
  -capstyle=>'menu(butt|projecting|round)'],
'PolyLine'=>[-arrow=>'arrowside',-width=>'linewidth',-fill=>'color','points'=>3,
  -capstyle=>'menu(butt|projecting|round)',-joinstyle=>'menu(bevel|miter|round)'],
'Curve'=>[-arrow=>'arrowside',-width=>'linewidth',-fill=>'color',-splinesteps=>'linewidth',
  'points'=>3,-capstyle=>'menu(butt|projecting|round)',-joinstyle=>'menu(bevel|miter|round)'],
'Polygon'=>[-width=>'linewidth',-fill=>'color',-outline=>'color','points'=>3],
'Splash'=>[-width=>'linewidth',-fill=>'color',-outline=>'color',-splinesteps=>'linewidth',
  'points'=>3],
'Oval'=>[-width=>'linewidth',-fill=>'color',-outline=>'color','points'=>2],
'Circle'=>[-width=>'linewidth',-fill=>'color',-outline=>'color','points'=>2],
'Rectangle'=>[-width=>'linewidth',-fill=>'color',-outline=>'color','points'=>2],
'Square'=>[-width=>'linewidth',-fill=>'color',-outline=>'color','points'=>2],
'Pie'=>[-extent=>'linewidth',-fill=>'color',-outline=>'color',-start=>'linewidth',-width=>'linewidth','points'=>2],
'Chord'=>[-extent=>'linewidth',-fill=>'color',-outline=>'color',-start=>'linewidth',-width=>'linewidth','points'=>2]
);

#
# ======================== Geometry management for Main window ================
# 
my $mw = MainWindow->new(-title=>"Visual Perl Tk $ver (canvas edition)",
  -background=>$bg_color);
$mw->bind("<Escape>", \&abandon);
$mw->geometry('+120+1'); # initial window position

# create bold font:
$mw->fontCreate('C_bold',-family => 'courier', -weight => 'bold');
# Prepare help from HTML file:
# 1. read HTML file
my (@html_help)=(&read_html("$path/toolbar/canvas_help.html"));
@html_help = 'text Sorry, help file not available!' unless $html_help[0];
# 2. get gif-files list
my @html_gifs=grep(/^gif/,@html_help);
map s/^\S+\s+//,@html_gifs;
# 3. get array of text descriptors in following format:
# {gif/text/bold} <text>
# read all pictures:
my %pic;
foreach (qw/open save new undo redo repaint properties delete exit duplicate/,
qw/canv_chord canv_line canv_polygon canv_splash canv_circle canv_oval canv_polyline canv_square canv_curve canv_pie canv_rectangle/,
  @html_gifs)
{
  my $pic_file="$path/toolbar/$_.gif";
  $pic_file = "$path/toolbar/$_.xpm" unless -e $pic_file;
  $pic{$_} = $mw->Photo(-file=>$pic_file)
    unless defined $pic{$_};
}

# +-------------------------------+
# | menu ...                      |
# +-------------------------------+
# | tool bar                      |
# +-------------------------------+
# |                               |  
# |                               |  
# |             canvas            |
# |             area              |
# |                               |  
# |                               |  
# |_______________________________|
# | status bar                    |
# +-------------------------------+
#

my $menubar = $mw->Frame(-relief => 'raised', -borderwidth => 2)
->form(-top=>'%0',-left=>'%0',-right=>'%100');

$menubar->Menubutton(qw/-text File -underline 0 -tearoff 0 -menuitems/ =>
  [
    [Button => 'Open ...',    -command => \&file_open, -underline => 0 , -accelerator => 'Control+o'],
    [Button => 'New',         -command => \&file_new, -underline => 0 ,  -accelerator => 'Control+n'],
    [Button => 'Save',        -command => \&file_save, -underline => 0 , -accelerator => 'Control+s'],
    [Button => 'Save As ...', -command => [\&file_save, 'Save As'], -underline => 5 ],
    [Separator => ''],
    [Button => 'Setup ...',   -command => \&file_setup, -underline => 1 ],
    [Separator => ''],
    [Button => 'Print ...',   -command => \&file_print, -underline => 0 ],
    [Separator => ''],
    [Button => 'Quit',        -command => \&abandon, -underline => 0 ,   -accelerator => 'ESC'],
  ])->pack(-side=>'left');

$menubar->Menubutton(qw/-text Edit -underline 0 -tearoff 0 -menuitems/ =>
  [
    [Button => 'Undo',         -command => \&undo, -underline => 0 , -accelerator => 'Control+z'],
    [Button => 'Redo',         -command => \&redo, -underline => 0 , -accelerator => 'Control+r'],
    [Button => 'Properties',   -command => \&edit_properties, -underline => 0 ],
    [Button => 'Delete',       -command => \&edit_delete, -underline => 1 ],
    [Button => 'Duplicate',    -command => \&edit_duplicate, -underline => 0 ],
  ])->pack(-side=>'left');

$menubar->Menubutton(qw/-text Transform -underline 0 -tearoff 0 -menuitems/ =>
  [
    [Button => 'Re-size',      -command => \&menus_resize, -underline => 3 ],
    [Button => 'X-mirror',     -command => \&menus_x_mirror, -underline => 0 ],
    [Button => 'Y-mirror',     -command => \&menus_y_mirror, -underline => 0 ],
    [Button => 'Free rotate',  -command => \&free_rotate, -underline => 0 ],
    [Button => 'Point edit',   -command => \&menus_point_edit, -underline => 0 ],
  ])->pack(-side=>'left');

$menubar->Menubutton(qw/-text Order -underline 0 -tearoff 0 -menuitems/ =>
  [
    [Button => 'Move up',        -command => [\&menus_order,'1+'], -underline => 5 ],
    [Button => 'Move down',      -command => [\&menus_order,'1-'], -underline => 5 ],
    [Button => 'Bring to front', -command => [\&menus_order,'+'], -underline => 0 ],
    [Button => 'Send to back',   -command => [\&menus_order,'-'], -underline => 0 ],
  ])->pack(-side=>'left');

$menubar->Menubutton(qw/-text View -underline 0 -tearoff 0 -menuitems/ =>
  [
     [Button => 'Repaint',        -command => \&menus_repaint, -underline => 0 ],
     [Separator => ''],
     [Button => 'Code',           -command => \&menus_codeview, -underline => 0 ],
     [Separator => ''],
     [Button => 'Scale 1:1',      -command => [\&menus_scale, '1:1'], -underline => 8 ],
     [Button => 'Scale 1:2',      -command => [\&menus_scale, '1:2'], -underline => 8 ],
     [Button => 'Scale 1:3',      -command => [\&menus_scale, '1:3'], -underline => 8 ],
     [Button => 'Scale 1:4',      -command => [\&menus_scale, '1:4'], -underline => 8 ],
     [Button => 'Scale 2:1',      -command => [\&menus_scale, '2:1']],
     [Button => 'Scale 3:1',      -command => [\&menus_scale, '3:1']],
     [Button => 'Scale 4:1',      -command => [\&menus_scale, '4:1']],
  ])->pack(-side=>'left');

my $createmenub=$menubar->Menubutton(qw/-text Create -underline 0/)
  ->pack(-side=>'left');
my $createmenu = $createmenub->Menu(-tearoff => 0);
foreach (qw/Line PolyLine Curve Polygon Splash Circle Oval Pie Chord Square Rectangle/)
{
  $createmenu->command(-label => $_, 
    -image=>$pic{lc("canv_$_")},-command => [\&menus_create, $_]);
}
$createmenub->configure(-menu =>$createmenu);

$menubar->Menubutton(qw/-text Help -underline 0 -tearoff 0 -menuitems/ =>
  [
     [Button => 'Help',      -command => \&help, -underline => 0 ],
     [Button => 'About',     -command => \&menu_about, -underline => 0 ],
  ])->pack(-side=>'right');

my $bf=$mw->Frame()->
form(-top=>$menubar,-left=>'%0',-right=>'%100',-bottom=>'%100');
my $ctrl_frame=$bf->Frame()->pack(-side=>'top',-anchor=>'nw');
my $main_frame=$bf->Frame()->
  pack(-side=>'top',-anchor=>'ne',-fill=>'both',-expand=>1);
my $status_frame=$bf->Frame(-relief=>'groove')->
  pack(-side=>'top',-anchor=>'nw',-fill=>'x');
my $sel_status_f=$status_frame->Frame(-relief=>'sunken',-borderwidth=>2)->
  pack(-side=>'left');
my $status=$sel_status_f->Label(-text=>'No selection')->pack(-side=>'left');
my $changes_f=$status_frame->Frame(-relief=>'sunken',-borderwidth=>2)->
  pack(-side=>'right');
my $changes_l=$changes_f->Label(-text=>' ')->pack(-side=>'right');
&changes(0);

my $tf=$main_frame->Scrolled('TList',-browsecmd=>\&tlist_select,
  -selectmode=>'extended',-orient => 'horizontal',-itemtype =>'imagetext')->
  pack(-side=>'left',-fill=>'y');
$tf->bind('<Control-Button-1>',\&tlist_select);
$tf->packAdjust(-side=>'left');
my $c=$main_frame->Scrolled('Canvas',-background=>$bg_color,-cursor=>'crosshair',
  -relief=>'sunken',-borderwidth=>2,
  -scrollbars=>'se',-scrollregion=>['-10c','-10c','50c','20c'])
   ->pack(-fill=>'both',-expand=>1);
# ==========
# ctrl_frame
# ==========
  $b=$mw->Balloon(-background=>'lightyellow',-initwait=>550);
  $b->attach($ctrl_frame->Button(-image=>$pic{'new'},-command=>\&file_new)->pack(-side=>'left',-expand=>1),-balloonmsg=>'New picture');
  $b->attach($ctrl_frame->Button(-image=>$pic{'open'},-command=>\&file_open) ->pack(-side=>'left',-expand=>1),-balloonmsg=>'Open file');
  $b->attach($ctrl_frame->Button(-image=>$pic{'save'},-command=>\&file_save) ->pack(-side=>'left',-expand=>1),-balloonmsg=>'Save current file');
  $ctrl_frame->Label(-text=>' ')->pack(-side=>'left',-expand=>1);
  $b->attach($ctrl_frame->Button(-image=>$pic{'undo'},-command=>\&undo) ->pack(-side=>'left',-expand=>1),-balloonmsg=>'Undo last change (limited)');
  $b->attach($ctrl_frame->Button(-image=>$pic{'redo'},-command=>\&redo) ->pack(-side=>'left',-expand=>1),-balloonmsg=>'Redo last change (limited)');
  $b->attach($ctrl_frame->Button(-image=>$pic{'delete'},-command=>\&edit_delete) ->pack(-side=>'left',-expand=>1),-balloonmsg=>'Erase selected');
  $b->attach($ctrl_frame->Button(-image=>$pic{'duplicate'},-command=>\&edit_duplicate) ->pack(-side=>'left',-expand=>1),-balloonmsg=>'Duplicate selected');
  $b->attach($ctrl_frame->Button(-image=>$pic{'properties'},-command=>\&edit_properties) ->pack(-side=>'left',-expand=>1),-balloonmsg=>'View/modify properties');
  $ctrl_frame->Label(-text=>' ')->pack(-side=>'left',-expand=>1);
  $b->attach($ctrl_frame->Button(-image=>$pic{'repaint'},-command=>\&menus_repaint) ->pack(-side=>'left',-expand=>1),-balloonmsg=>'Repaint all picture');
  my $sc_b=$ctrl_frame->Menubutton(qw/-text Scale -relief raised/)->pack(-side=>'left');
  $b->attach($sc_b,-balloonmsg=>'Zoom/unzoom picture view');
  {
    my $m = $sc_b->Menu(-tearoff => 0);
    foreach (qw/1:1 1:2 1:3 1:4 2:1 3:1 4:1/)
    {
      $m->command(-label => $_, -command=>[\&menus_scale, $_]);
    }
    $sc_b->configure(-menu => $m);
  }
  $ctrl_frame->Label(-text=>' ')->pack(-side=>'left',-expand=>1);
  $b->attach($ctrl_frame->Button(-image=>$pic{'exit'},-command=>\&abandon) ->pack(-side=>'left',-expand=>1),-balloonmsg=>'Exit program');

#
# =============================== Events/Keys binding ===============================
#
$c->bind('move','<Enter>' => sub{ $c->configure(-cursor=>'fleur') });
$c->bind('erase','<Enter>' => sub{ $c->configure(-cursor=>'pirate') });
$c->bind('resize','<Enter>' => sub{ $c->configure(-cursor=>'dotbox') });
$c->bind('configure','<Enter>' => sub{ $c->configure(-cursor=>'hand2') });
$c->bind('sel_type_resize','<Enter>' => sub{ $c->configure(-cursor=>'sizing') });
$c->bind('sel_type_cut','<Enter>' => sub{ $c->configure(-cursor=>'cross_reverse') });
$c->bind('selection','<Leave>' => sub{ $c->configure(-cursor=>'crosshair')});
$c->bind('cnv_obj','<Enter>' => sub{ $c->configure(-cursor=>'top_left_arrow')});
$c->bind('cnv_obj','<Leave>' => sub{ $c->configure(-cursor=>'crosshair')});

# massive selection area information
my %iinfo = (qw/areaX1 0 areaY1 0 areaX2 0 areaY2 0/);

$c->CanvasBind('<Button-3>',sub{&mark_start($Tk::event->x,$Tk::event->y)});
$c->CanvasBind('<B3-Motion>',sub{&mark_stroke($Tk::event->x,$Tk::event->y)});
$c->CanvasBind('<B3-ButtonRelease>',sub{&mark_end});
$c->CanvasBind('<Button-1>',\&mouse_click);
$c->CanvasBind('<B1-Motion>',sub{&mouse_drag($Tk::event->x,$Tk::event->y)});
$mw->bind('<Delete>',\&edit_delete);
$mw->bind('<Control-o>',\&file_open);
$mw->bind('<Control-s>',\&file_save);
$mw->bind('<Control-z>',\&undo);
$mw->bind('<Control-r>',\&redo);
$mw->bind('<F1>',\&help);
$mw->bind('<d>',\&edit_duplicate);

$mw->protocol('WM_DELETE_WINDOW',\&wm_abandon);

&file_read(@ARGV) if scalar(@ARGV);

MainLoop;

######################################################
#     SUBROUTINES section
######################################################

sub menu_about
{
  my $d = $mw->DialogBox(-title=>'About',-buttons=>['Ok']);
  $d->Label(-text=>"Visual Perl Tk (canvas edition)\n$ver")->pack();
  $d->Label(-text=>"Copyright (c) 2002 Felix Liberman\n\n".
    "e-mail: FelixL\@Rambler.RU\n\n".
    "IDE: GVIM 6.0")->pack();
  $d->resizable(0,0);
  $d->Show();
}

sub changes
{
  $changes=shift;
  $changes_l->configure(-text=> ($changes)?'*':' ');
}

sub redraw_preview
{
  my ($canv,$opt)=(@_);
  $canv->delete('preview');
  my @coords=(10,10,50,65);
  @coords=(10,10,65,50)
    if ($opt->{'rotate'});
  my @colors=('red','green','blue');
  @colors=('black','lightgray','darkgray')
    if ($opt->{'colormode'} eq 'gray');
  @colors=('black','white','black')
    if ($opt->{'colormode'} eq 'mono');

  $canv->create('rectangle',@coords,-fill=>'white',-outline=>'black',-tags=>['preview']);
  foreach my $color(@colors)
  {
    foreach my $i(0..3){$coords[$i]+=($i<2)?4:-4}
    my @fc=(@coords)[0,1,0,3,2,3,2,1];
    $canv->create('polygon',@fc,-fill=>$color,-smooth=>1,-tags=>['preview']);
  }

  @coords=(10,70,45,100);
  $canv->create('rectangle',@coords,-fill=>'white',-outline=>'black',-tags=>['preview']);
  $canv->create('line',25,86,53,82,11,99,30,65,25,89,-smooth=>1,-tags=>['preview']);
  $canv->create('rectangle',15,79,32,96,-tags=>['preview'])
   if $opt->{'capture'};
}

sub file_print
{
  my %opt=(
    'rotate'=>0,
    'colormode'=>'color',
    'name'=>'picture.ps',
    'capture'=>0);
  my $db=$mw->DialogBox(-title=>'Print PostScript',-buttons=>['Start','Dismiss']);
  my $Preview = $db -> Canvas(-borderwidth=>2,-relief=>'sunken',
    -width=>100,-height=>100)-> pack(-anchor=>'nw',-side=>'left',-fill=>'y');
  my $Options = $db -> Frame ( -relief=>'raised' ) -> 
    pack(-anchor=>'nw',-padx=>10,-side=>'left',-pady=>10,-fill=>'y');

  &redraw_preview($Preview,\%opt);
  my $or_fr = $Options -> LabFrame ( -labelside=>'acrosstop',-relief=>'ridge',
    -label=>'Orientation:') -> pack(-anchor=>'nw',-padx=>10);
  $or_fr -> Radiobutton ( -text=>'Portrait', -variable=>\$opt{'rotate'}, 
    -value=>0, -command=> [\&redraw_preview,$Preview,\%opt] ) ->  pack(-anchor=>'nw',-side=>'left');
  $or_fr -> Radiobutton ( -text=>'Landscape', -variable=>\$opt{'rotate'}, 
    -value=>1, -command=> [\&redraw_preview,$Preview,\%opt] ) ->  pack(-anchor=>'nw',-side=>'left');

  my $mode_fr = $Options -> LabFrame ( -labelside=>'acrosstop',-relief=>'ridge',
    -label=>'Print mode:' ) -> pack(-anchor=>'nw',-padx=>10);
  $mode_fr -> Radiobutton ( -text=>'Color', -value=>'color',
    -variable=>\$opt{'colormode'}, -command=> [\&redraw_preview,$Preview,\%opt]) -> pack(-side=>'left');
  $mode_fr -> Radiobutton ( -text=>'Greyscale', -value=>'gray',
    -variable=>\$opt{'colormode'}, -command=> [\&redraw_preview,$Preview,\%opt]) -> pack(-side=>'left');
  $mode_fr -> Radiobutton ( -text=>'Mono', -value=>'mono',
    -variable=>\$opt{'colormode'}, -command=> [\&redraw_preview,$Preview,\%opt]) -> pack(-side=>'left');

  my $cap_fr = $Options -> LabFrame ( -labelside=>'acrosstop',-relief=>'ridge',
    -label=>'Capture:') -> pack(-anchor=>'nw',-padx=>10);
  $cap_fr -> Radiobutton ( -text=>'All', -variable=>\$opt{'capture'}, 
    -value=>0, -command=> [\&redraw_preview,$Preview,\%opt] ) ->  pack(-anchor=>'nw',-side=>'left');
  $cap_fr -> Radiobutton ( -text=>'Window', -variable=>\$opt{'capture'}, 
    -value=>1, -command=> [\&redraw_preview,$Preview,\%opt] ) ->  pack(-anchor=>'nw',-side=>'left');

  my $File_fr = $Options -> Frame ( -relief=>'raised' ) -> pack(-anchor=>'nw',-pady=>10);
  my $File = $File_fr -> LabEntry ( -justify=>'left',-relief=>'sunken',-label=>'File',
    -labelPack=>[-anchor=>'n',-side=>'left'],-textvariable=>\$opt{'name'}
     ) -> pack(-side,'left');
  my $Open = $File_fr -> Button ( -text=>'Open...',
    -command=>sub{
      $mw->Busy;
      # open file save dialog box
      my @types = ( ["PostScript files",'.pl'], ["All files", '*'] );
      my $file = $opt{'name'};
      $file=~s#.*[/\\]([^/\\]+)$#$1#;
      if($^O=~/(^win)|(^$)/i)
      {
        $file = $mw->getSaveFile(-filetypes => \@types,
                          -initialfile => $file,
                          -defaultextension => '.ps',
                          -title=>'print to file');
      }
      else
      {
        $file = $mw->FileSelect(-directory => '.',
                          -initialfile => $file,
                          -title=>'print to file')->Show;
      }
      $mw->Unbusy;
      # if file selected
      $opt{'name'}=$file if($file);
    
    } ) -> pack(-side=>'left',-padx=>5);
  $db->resizable(0,0);
  return if($db->Show() eq 'Dismiss');
  my @capture=();
  my ($x0,$y0,$x1,$y1)=$c->bbox('all');
  @capture=('-x'=>$x0,'-y'=>$y0,-height=>$y1-$y0,-width=>$x1-$x0)
    unless $opt{'capture'};
  $c -> postscript(-colormode=>$opt{'colormode'},
    -file=>$opt{'name'},-rotate=>$opt{'rotate'},@capture);
}

sub file_setup
{
  my $new_bg=$cnv_bg;
  my $new_t=$cnv_t;
  my $new_p=$precision;
  my $new_fullcode = $cnv_fullcode;
  my $db=$mw->DialogBox(-title=>'Setup',-buttons=>['Accept','Cancel']);
  my $f1=$db->Frame()->pack(-side=>'top',-fill=>'x',-padx=>15,-pady=>15);
  $f1->Label(-text=>'Background ')->pack(-side=>'left',-padx=>5);
  my $menubutton = $f1->Menubutton(-relief=>'raised',-text=>'color',-background=>$new_bg)
    ->pack(-side=>'left');
  my $menu = $menubutton->menu(-tearoff=>0);
  $menubutton->configure(-menu => $menu);
  foreach (qw/white gray black red orange yellow green lightblue blue violet/)
  {
    $menubutton->command(-label => $_,-background=>$_,-foreground=>'cyan',
      -command=>[sub{$new_bg=shift;$menubutton->configure(-background=>$new_bg)},$_]);
  }
  my $f2=$db->Frame()->pack(-side=>'top',-fill=>'x',-padx=>15,-pady=>15);
  $f2->Label(-text=>'Title')->pack(-side=>'left',-padx=>5);
  $f2->Entry(-textvariable=>\$new_t)->pack(-side=>'left');
  my $f3=$db->Frame()->pack(-side=>'top',-fill=>'x',-padx=>15,-pady=>15);
  $f3->Label(-text=>'Output precision')->pack(-side=>'left',-padx=>5);
  &NumEntry($f3,-textvariable=>\$new_p,
          -width=>2,-minvalue=>0)->pack(-side=>'left');
  my $f4=$db->Frame()->pack(-side=>'top',-fill=>'x',-padx=>15,-pady=>15);
  $f4->Checkbutton(-text=>'Generate full executable program',
    -variable=>\$new_fullcode)->pack(-side=>'left',-padx=>5);


  $db->resizable(1,0);
  return if($db->Show() eq 'Cancel');
  # save current state for undo
  &undo_save();
  $c->configure(-background=>$new_bg);
  $precision=$new_p;
  $cnv_bg=$new_bg;
  $cnv_t=$new_t;
  $cnv_fullcode=$new_fullcode;
  &changes(1);
}

sub code_print
{
  my (@outext);
  my ($x0,$x1,$y0,$y1)=(1000,0,1000,0);
  my $id;
  if($cnv_fullcode)
  {
    foreach $id (@canv_obj)
    {
      my ($par)=$canv_obj{$id}->{par};
      my @p;
      foreach (@$par)
      {
        push (@p,$_) unless (/^-\D/);
      }
      my %p=(@p);
      my ($x,$y);
      while(($x,$y)=each(%p))
      {
        $x0 = $x if $x<$x0; $x1 = $x if $x>$x1;
        $y0 = $y if $y<$y0; $y1 = $y if $y>$y1;
      }
    }
    push(@outext,"#!$perl\n\nuse strict;\nuse Tk;\nuse Tk::Canvas;\nmy \$mw=MainWindow->new();\n");
    push(@outext,"\nmy \$c=\$mw->Canvas(-width=>$x1,-height=>$y1)->pack;\n\n");
  }
  foreach (split("\n",$cnv_t))
  {
    push(@outext,"# $_");
  }
  push(@outext,"\$c->configure(-background=>'$cnv_bg');");
  foreach $id (@canv_obj)
  {
    my ($par)=$canv_obj{$id}->{par};
    my @p;
    foreach (@$par)
    {
      if(/^-\D/ || /^[^\.\d]/)
      {
        $_ = "'$_'" unless /^[-']/;
        push(@p,$_);
      }
      else
      {
        push(@p,sprintf("%.${precision}f",$_));
      }
    }
    push( @outext, sprintf("my \$$id = \$c->create('%s',%s,-tags=>['$id','cnv_obj']);",
        $obj2canvas{$canv_obj{$id}->{name}}, join(',',@p) ) );
  }
  if($cnv_fullcode)
  {
    push( @outext, "\nMainLoop;\n");
  }
  return (@outext);
}

sub menus_codeview
{
  my $db=$mw->DialogBox(-title => "Code preview",-buttons=>['Dismiss']);
  my $t = $db->Scrolled(qw/ROText -setgrid true -wrap none
  -scrollbars osoe -background white/);
  $t->pack(qw/-expand yes -fill both/);
  $t->tag(qw/configure variable -foreground darkgreen/);
  $t->tag(qw/configure keyword -foreground brown -font C_bold/);
  $t->tag(qw/configure constant -foreground violet/);
  $t->tag(qw/configure comment -foreground blue/);
  foreach my $line(&code_print)
  {
    last unless length $line;
    if($line=~/^\s*my\s+/)
    {
      $t->insert('end','my ','keyword');
      $line=~s/^\s*my\s+//;
    }
    while(length($line))
    {
      if($line=~/^\s*\$\w+/)
      {
        my ($var)=($line=~/^(\s*\$\w+)/);
        $t->insert('end',$var,'variable');
        $line=~s/^\s*\$\w+//;
      }
      elsif($line=~/^\s*#/)
      {
        my ($comment) = ($line=~/^\s*#(.*)/);
        $t->insert('end',"#$comment",'comment');
        $line="";
      }
      elsif($line=~/^\s*(-\w+|'[^']*')/)
      {
        my ($const)=($line=~/^(\s*(?:-\w+|'[^']*'))/);
        $t->insert('end',$const,'constant');
        $line=~s/^\s*(-\w+|'[^']*')//;
      }
      else
      {
        my ($txt)=($line=~/^(\s*(?:->)?[^-\$']+)/);
	    $txt=~s/->\s*/->\n  /;
        $t->insert('end',$txt);
        $line=~s/^\s*(->)?[^-\$']+//;
      }
    }
    $t->insert('end', "\n");
  }
  $t->mark(qw/set insert 0.0/);
  $db->resizable(1,0);
  $db->Show();
}

sub menus_repaint
{
  # erase selection
  &selection_remove($selected_id) if $selected_id;
  &menus_scale('1:1');
  $c->configure(-cursor=>'crosshair');
  # erase all canvas
  $c->delete('cnv_obj');
  # clean canvas list:
  $tf->delete('0','end');
  # re-paint them using internal objects
  foreach my $id (@canv_obj)
  {
    my ($par)=$canv_obj{$id}->{par};
    map(s/'//g,@$par);
    $c->create($obj2canvas{$canv_obj{$id}->{name}},@$par,-tags=>[$id,'cnv_obj']);
    $tf->insert(0,-data=>$id,-image=>$pic{lc("canv_$canv_obj{$id}->{name}")},-text=>$id);
  }
  &selection_create($selected_id) if $selected_id;
}

sub menus_order
{
  my ($op)=shift;

  return unless $selected_id;
  return unless grep(/$selected_id/,@canv_obj);
  my $i;
  my $j=0;
  if($op =~ /1/)
  {
    foreach (@canv_obj) {last if $_ eq $selected_id; $j++}
    # now $j is the index of element to be moved
    $i=($j+1) if $op eq '1+';
    $i=($j-1) if $op eq '1-';
    $i=$#canv_obj if $i>$#canv_obj;
    $i=0 if $i<0;
    return if $i == $j;
  }
  # save current state for undo
  &undo_save();
  if($op =~ /1/)
  {
    @canv_obj[$i,$j] = @canv_obj[$j,$i];
  }
  else
  {
    @canv_obj=grep(!/^$selected_id$/,@canv_obj);
    if($op eq '-'){unshift(@canv_obj,$selected_id)}
    else {push(@canv_obj,$selected_id)}
  }
  # Set modification flag on
  &changes(1);
  # repaint here:
  &menus_repaint();
}

sub edit_duplicate
{
  return unless $selected_id=~/^cnv_/;
  my $scale_save=$scale_h;
  &selection_remove;
  &menus_scale('1:1');
  $c->configure(-cursor=>'crosshair');
  # save current state for undo
  &undo_save();

  foreach my $id(split(' ',$selected_id))
  {
     my ($par)=$canv_obj{$id}->{par};
     map(s/'//g,@$par);
     &obj_create(1,$canv_obj{$id}->{name},@$par);
  }
  # Set modification flag on
  &changes(1);
  &menus_scale($scale_save);
  $selected_id=$canv_obj[$#canv_obj] unless $selected_id=~/ /;
  &selection_create($selected_id);
}

sub mouse_drag
{
  my ($x,$y) = (@_);
  my ($tag,$subtag)=$c->itemcget('current','-tags');
  if($mouse_drag eq 'move' || $mouse_drag=~/^sel_ref_/)
  {
    my ($sel_ref)=($mouse_drag=~/^sel_ref_(.*)/);
    &selection_remove($selected_id);
    if($mouse_drag eq 'move')
    {
      foreach my $id(split(' ',$selected_id))
      {
        $c->move($id,$x-$sx,$y-$sy);
      }
    }
    else
    {
      # move point only ?
    }
    # move internal structure too
    if($selected_id=~/ / && $mouse_drag eq 'move')
    {
      foreach my $id(split(' ',$selected_id))
      {
        my $obj=$canv_obj{$id};
	my $par=$obj->{par};
	my $toggle=0;
        foreach (@$par)
        {
          last if /^-\D/;
          if($toggle) { $_+=($y-$sy)/$scale; }
          else        { $_+=($x-$sx)/$scale; }
          $toggle=1-$toggle;
        }
        $canv_obj{$id}=$obj;
      }
    }
    else
    {
      my $obj=$canv_obj{$selected_id};
      my $par=$obj->{par};
      if($mouse_drag eq 'move')
      {
        my $toggle=0;
        foreach (@$par)
        {
          last if /^-\D/;
          if($toggle) { $_+=($y-$sy)/$scale; }
          else        { $_+=($x-$sx)/$scale; }
          $toggle=1-$toggle;
        }
      }
      else
      {
        # move point + internal object
        if($sel_ref=~/\d/)
        {
          if($obj->{name} =~ /Circle|Square/)
          {
            $$par[$sel_ref]+=($y-$sy)/$scale;
          }
          else
          {
            $$par[$sel_ref]+=($x-$sx)/$scale;
          }
          $$par[$sel_ref+1]+=($y-$sy)/$scale;
          &apply_properties($selected_id,$obj,0,@$par);
        }
        else
        {
          # change degree (start/extent)
          my %h=Drawing::hash(@$par);
          my $val=$h{"-$sel_ref"};
          $val+=($y-$sy+$x-$sx)/$scale;
          $val %= 360;
          &apply_properties($selected_id,$obj,1,Drawing::array(@$par),"-$sel_ref",$val);
        }
      }
      $canv_obj{$selected_id}=$obj;
    }
    # Set modification flag on
    &changes(1);
    &selection_create($selected_id);
    ($sx,$sy)=($x,$y);
  }
}

sub menus_scale
{
  my ($factor)=shift;
  
  return if $scale_h eq $factor;
  my ($n1,$n2)=split(':',$factor);
  my ($o1,$o2)=split(':',$scale_h);
  $scale_h=$factor;
  $sc_b->configure(-text=>"Scale $scale_h");
  $factor=$n1/$n2;
  $scale=$o1/$o2;
  
  my ($x0,$y0,$x1,$y1)=$c->bbox('all');
  &selection_remove($selected_id) if($selected_id);
  $c->scale("all", ($x0+$x1)/2, ($y0+$y1)/2, $factor/$scale, $factor/$scale);
  &selection_create($selected_id) if($selected_id);
  $scale=$factor;
}

sub file_new
{
  return unless &check_changes;
  &canv_new;
  &changes(0);
}

sub canv_new
{
  %canv_obj=();
  @canv_obj=();
  $cnv_t='';
  $cnv_fullcode = 0;
  $cnv_bg = $bg_color;
  $c->configure(-background=>$cnv_bg);
  $c->delete('cnv_obj');
  &selection_remove($selected_id); $selected_id='';
  &menus_scale('1:1');
}

sub index_of
{
  my $tag=shift || return undef;

  my $index=0;
  while($canv_obj[$index] ne $tag)
  {
    $index++;
    return undef if $index > $#canv_obj;
  }
  return $#canv_obj-$index;
}

sub tlist_select
{
  my @tags;
  foreach my $i(split(' ',$tf->info('selection')))
  {
    next unless length $i;
    push(@tags,$canv_obj[$#canv_obj-$i]);
  }
  &selection_remove($selected_id);
  $selected_id=join(' ',@tags);
  &selection_create($selected_id) if $selected_id;
}

sub selection_create
{
  my ($tag)=shift;
  # repaint canvas selection list
  $tf->selectionClear('0','end');
  if ($tag =~ / /)
  {
    $status->configure(-text=>"Selected: $tag");
    # draw multiple selection
    foreach my $t(split(' ',$tag))
    {
      my ($x0,$y0,$x1,$y1)=$c->bbox($t);
      foreach my $x($x0,$x1)
      {
        foreach my $y($y0,$y1)
        {
          $c->create('rectangle',$x-3,$y-3,$x+3,$y+3, -fill=>'black',-tags=>['selection','move']);
        }
      }
      $tf->selectionSet(&index_of($t));
    }
    return;
  }
  my ($x0,$y0,$x1,$y1)=$c->bbox($tag);
  my ($x,$y);
  my (@actions)=(qw/move configure erase resize/);

  return if $selection;
  $selection=1;

  # calculate layer:
  $x=0;
  foreach (@canv_obj) {last if $_ eq $tag;$x++}
  $x=$#canv_obj-$x;
  $status->configure(-text=>"Selected: $tag (layer $x)");
  
  if ($selection_type == 1)
  {
    foreach $x($x0,$x1)
    {
      foreach $y($y0,$y1)
      {
        $c->create('rectangle',$x-3,$y-3,$x+3,$y+3,
           -fill=>'black',-tags=>['selection',shift(@actions)]);
      }
    }
    $c->create('line',$x0-6,$y0-6,$x0+6,$y0+6,-arrow=>'both',-tags=>['selection','move']);
    $c->create('line',$x0-6,$y0+6,$x0+6,$y0-6,-arrow=>'both',-tags=>['selection','move']);
    $c->create('line',$x1,$y1,$x1+8,$y1,-arrow=>'last',-tags=>['selection','resize']);
    $c->create('line',$x1,$y1,$x1,$y1+8,-arrow=>'last',-tags=>['selection','resize']);
    $c->create('line',$x1-5,$y0-5,$x1+5,$y0+5,-width=>1.8,-tags=>['selection','erase']);
    $c->create('line',$x1-5,$y0+5,$x1+5,$y0-5,-width=>1.8,-tags=>['selection','erase']);
    $c->create('rectangle',$x0-7,$y1-1,$x0-1,$y1+7,-fill=>'white',-tags=>['selection','configure']);
  }
  else
  {
    my (@p)=$c->coords($tag);
    my $obj_type=$canv_obj{$tag}->{name};
    if($obj_type =~ /Oval|Circle|Rectangle|Square|Pie|Chord/)
    {
      # 2 resizing points
      # normalize points order ?
      foreach my $i(0, 2)
      {
        my $x=$p[$i];
        my $y=$p[$i+1];
        $c->create('rectangle',$x-3,$y-3,$x+3,$y+3,
           -fill=>'black',-tags=>['selection','sel_type_resize',"sel_ref_$i"]);
      }
      if($obj_type =~ /Pie|Chord/)
      {
	my $ptr=$canv_obj{$tag}->{par};
	my %ptr=(@$ptr);
        my ($extent)=$ptr{-extent};
        my ($start)=$ptr{-start} || 0;
	$extent=90 if $extent eq '';
        # degree-resizing points:
	# 1. calculate max radius (R)
	# R=max(x2-x1,y2-y1)/2
	my $R=$p[2]-$p[0];
	$R=$p[3]-$p[1] if ($p[3]-$p[1]) > $R;
	$R/=2;
	# 2. calculate center point (xc,yc)
	# xc=(x1+x2)/2; yc=(y1+y2)/2;
	my $xc=($p[2]+$p[0])/2;
	my $yc=($p[3]+$p[1])/2;
	# 3. for each degree calculate projection to circle (xc,yc,R)
	# x=xc+cos(alfa)*R
	my (%p)=(start=>$start*3.1415926/180,extent=>($start+$extent)*3.1415926/180);
	foreach (keys %p)
	{
	  my $x=$xc+cos($p{$_})*$R;
	  my $y=$yc-sin($p{$_})*$R;
	  $c->create('line',$xc,$yc,$x,$y,-tags=>['selection','sel_type_resize',"sel_ref_$_"]);
          $c->create('oval',$x-5,$y-5,$x+5,$y+5,-outline=>'black',
           -fill=>'white',-tags=>['selection','sel_type_resize',"sel_ref_$_"]);
	}
      }
    }
    elsif ($obj_type =~ /Line|PolyLine|Curve|Polygon|Splash/)
    {
      for (my $i=0;$i<$#p;$i+=2)
      {
        my $x=$p[$i];
        my $y=$p[$i+1];
        $c->create('rectangle',$x-3,$y-3,$x+3,$y+3,
           -fill=>'black',-tags=>['selection','sel_type_resize',"sel_ref_$i"]);
	next if $obj_type =~ /^Line/;
	if($i+2<=$#p || $obj_type =~ /Polygon|Splash/ )
	{
	  # scissor-point on each segment
	  my ($x2,$y2)=($p[$i+2],$p[$i+3]);
	  ($x2,$y2)=($p[0],$p[1]) if($i+2>$#p && $obj_type =~ /Polygon|Splash/);
	  $x=($p[$i]+$x2)/2;
	  $y=($p[$i+1]+$y2)/2;
          $c->create('oval',$x-7,$y-3,$x+7,$y+7,-fill=>'white',-outline=>'white',-tags=>['selection','sel_type_cut',"sel_ref_$i"]);
	  $c->create('line',$x-4,$y-4,$x+4,$y+4,-tags=>['selection','sel_type_cut',"sel_ref_$i"]);
	  $c->create('line',$x-4,$y+4,$x+4,$y-4,-tags=>['selection','sel_type_cut',"sel_ref_$i"]);
	  $c->create('oval',$x-7,$y+3,$x-3,$y+7,-tags=>['selection','sel_type_cut',"sel_ref_$i"]);
	  $c->create('oval',$x+3,$y+3,$x+7,$y+7,-tags=>['selection','sel_type_cut',"sel_ref_$i"]);
	}
      }
    }
  }
  # repaint canvas list:
  $tf->delete('0','end');
  map($tf->insert(0,-data=>$_,-image=>$pic{lc("canv_$canv_obj{$_}->{name}")},-text=>$_),@canv_obj);
  $tf->selectionSet(&index_of($tag)) if $tag;
}

sub selection_remove
{
  my ($tag)=shift;
  $c->delete('selection');
  $tf->selectionClear('0','end');
  $selection=0;
  $status->configure(-text=>'No selection');
}

# Interface for point-level editing:
#  Figure:      Resizing points   Conversion point    Scissors
#  * square           1                  1
#  * circle           1                  1               1
#  * line             1                                  1
#  * oval             2                  1               1
#  * rectangle        2                  1
#  * polyline         n                  1(end)          n-1
#  * curve            n                  1(end)          n-1
#  * polygon          n                  n               n
#  * freeform         n                  n               n
#  * sector           4                  1
#  * pie ?

sub menus_point_edit
{
  # get object id or return;
  my ($obj_id)=shift || $selected_id;
  return unless $obj_id;
  # create selection 'type 2'
  &selection_remove($selected_id);
  $selection_type=2;
  $c->configure(-cursor=>'crosshair');
  &selection_create($obj_id);
  # tags:
  # selection, sel_type_<resize/convert/cut>, sel_ref_<index>
}

sub mouse_click
{
  my ($tag)=$c->itemcget('current','-tags');
  if($tag=~/^cnv_/)
  {
    if($selected_id ne $tag)
    {
      # remove selection
      &selection_remove($selected_id);
      # select new object
      $selected_id=$tag;
      $selection_type=1;
      &selection_create($tag);
    }
    else # switch selection type
    {
      &selection_remove($selected_id);
      $selection_type=(2-$selection_type)+1; # toggle 2<->1
      &selection_create($selected_id);
    }
  }
  else
  {
    my (@tags)=$c->gettags('current');
    $mouse_drag='';
    if (grep(/selection/,@tags))
    {
      ($sx,$sy) = ($Tk::event->x,$Tk::event->y);
      if(grep(/erase/,@tags))
      {
        &edit_delete( $selected_id );
      }
      elsif(grep(/move/,@tags))
      {
        # save current state for undo
        &undo_save();
	$mouse_drag='move';
      }
      elsif(grep(/^resize/,@tags))
      {
        &menus_point_edit();
      }
      elsif(grep(/configure/,@tags))
      {
	&edit_properties($selected_id);
      }
      elsif(grep(/sel_type_resize/,@tags))
      {
        # save current state for undo
        &undo_save();
        ($mouse_drag)=grep(/sel_ref_/,@tags);
      }
      elsif(grep(/sel_type_cut/,@tags))
      {
        # immidiate cut:
        my ($sel_ref)=grep(/sel_ref/,@tags);
	$sel_ref=~s/.*_//;
	my $obj=$canv_obj{$selected_id};
	my $par=$obj->{par};
	my (@p)=@$par;
	map (s/'//g,@p);
	my ($x2,$y2)=($p[0],$p[1]);
	($x2,$y2)=($p[$sel_ref+2],$p[$sel_ref+3]) if $sel_ref+3<=$#p;
	my $x=($p[$sel_ref]  +$x2)/2;
	my $y=($p[$sel_ref+1]+$y2)/2;
	splice(@p,$sel_ref+2,0,$x,$y);
        # save current state for undo
        &undo_save();
        &apply_properties($selected_id,$obj,0,@p);
      }
      return;
    }
    &selection_remove($selected_id) if($selected_id);
    $selected_id='';
  }
}

sub mark_start
{
  my($x,$y) = @_;

  $iinfo{areaX1} = $iinfo{areaX2} = $c->canvasx($x);
  $iinfo{areaY1} = $iinfo{areaY2} = $c->canvasy($y);
  &selection_remove($selected_id) if($selected_id);
  $selected_id='';
  $c->delete('sel_area');
  $c->delete('selection');
  $c->configure(-cursor=>'top_left_arrow');
}

sub mark_stroke
{
  my($x,$y) = @_;

  $x = $c->canvasx($x);
  $y = $c->canvasy($y);
  if (($iinfo{areaX1} != $x) and ($iinfo{areaY1} != $y)) 
  {
    $c->delete('sel_area');
    $c->addtag('sel_area', 'withtag', $c->create('rectangle',
        $iinfo{areaX1}, $iinfo{areaY1}, $x, $y, -outline => 'black'));
    $iinfo{areaX2} = $x;
    $iinfo{areaY2} = $y;
    $c->configure(-cursor=>'top_left_arrow');
  }
}

sub mark_end
{
  $c->delete('sel_area');
  my @objects = ();
  $c->dtag('all','mark_selection');
  $c->addtag('mark_selection','enclosed', $iinfo{areaX1},
            $iinfo{areaY1}, $iinfo{areaX2}, $iinfo{areaY2});
  foreach my $item ($c->find('withtag', 'mark_selection'))
  {
    my ($tag) = grep(/^cnv_[^o][^b][^j]/,$c->gettags($item));
    if ($tag) 
    {
      push @objects, grep(!/^cnv_obj/,$tag);
    }
  }
  $selected_id=join(' ',@objects) if @objects;
  $selection_type=1;
  &selection_create($selected_id) if $selected_id;
}

sub canv_create
{
  my($figure,$obj_id,@canv_par)=(@_);
  return unless $obj2canvas{$figure};
  # add to canvas $c
  $c->create($obj2canvas{$figure},@canv_par,-tags=>[$obj_id,'cnv_obj']);
  # - store in internal structures
  map(s/'//g,@canv_par);
  my $new_obj=Drawing->new($figure,$obj_id,@canv_par);
  $canv_obj{$obj_id}=$new_obj;
  push(@canv_obj,$obj_id);
}

sub rand_int
{
  my ($from,$to)=(@_);
  return int(rand($to-$from)+$from)*$scale;
}

sub menus_create
{
  my $scale_save=$scale_h;
  &menus_scale('1:1');
  $c->configure(-cursor=>'crosshair');
  # save current state for undo
  &undo_save();
  &obj_create(0,@_);
  &menus_scale($scale_save);
  # Set modification flag on
  &changes(1);
  # repaint canvas list:
  $tf->delete('0','end');
  map($tf->insert(0,-data=>$_,-image=>$pic{lc("canv_$canv_obj{$_}->{name}")},-text=>$_),@canv_obj);
}

sub obj_create
{
  my $duplicate=shift;
  my $figure=shift;

  # 1. Create new object with initial values:
  # - open dialog box for object naming/config
  $obj_count++;
  my $obj_id="cnv_${figure}_$obj_count";
  my (@canv_par);
  if(@_)
  {
    (@canv_par)=(@_);
    foreach (@canv_par)
    {
      last if /^-\D/;
      $_+=4 if $duplicate;
    }
  }
  else
  {
    (@canv_par)=
      (rand_int(10,40),rand_int(10,40),rand_int(50,110),rand_int(50,110));
    $canv_par[2]=$canv_par[0]+($canv_par[3]-$canv_par[1])
       if $figure =~ /Circle|Square/;
    push(@canv_par,rand_int(10,40),rand_int(50,110)) if $figure =~ /Curve|Poly|Splash/;
    push(@canv_par,-smooth=>1) if $figure =~ /Curve|Splash/;
    push(@canv_par,-style=>'chord') if $figure =~ /Chord/;
    # or dialog box here?
    # - if Ok:
    return unless scalar(@canv_par);
  }
  &canv_create($figure,$obj_id,@canv_par);
}

sub middle_point
{
  my ($c,$id)=(@_);
  my ($x0,$y0,$x1,$y1)=$c->bbox($id);

  return (($x1+$x0)/2,($y1+$y0)/2);
}

sub menus_resize
{
  my $obj_id=shift || $selected_id;
  my ($obj)=$canv_obj{$obj_id};
  return unless $obj;
  if($scale_h ne '1:1'){ &menus_error("resize with scale $scale_h"); return; }
  # Open re-size dialog box
  my ($xs,$ys)=(100,100);
  my $db=$mw->DialogBox(-title=>"Object $obj_id resizing",
    -buttons=>['Accept','Cancel']);#,'Preview']);
  my $xf=$db->Frame()->pack(-side=>'top',-fill=>'x');
  $xf->Label(-text=>'X scale (%)')->pack(-side=>'left');
  &NumEntry($xf,-textvariable=>\$xs,-width=>4)->pack(-side=>'left');
  my $yf=$db->Frame()->pack(-side=>'top',-fill=>'x');
  $yf->Label(-text=>'Y scale (%)')->pack(-side=>'left');
  &NumEntry($yf,-textvariable=>($obj->{name}=~/Circle|Square/)?\$xs : \$ys,-width=>4)->pack(-side=>'left');
  my $reply=$db->Show();
  # if user says 'Ok':
  return if $reply eq 'Cancel';
  $ys=$xs if $obj->{name}=~/Circle|Square/;
  $xs/=100; $ys/=100; $xs=1 if $xs<=0; $ys=1 if $ys<=0;
  # find object middle-point
  my $par=$obj->{par};
  my @p=Drawing::array(@$par);
  my ($mpx,$mpy)=&middle_point($c,$obj_id);
  # re-calculate all points
  for (my $i=0;$i<$#p;$i+=2)
  {
    $p[$i]  =$mpx+($p[$i]  -$mpx)*$xs;
    $p[$i+1]=$mpy+($p[$i+1]-$mpy)*$ys;
  }
  # save current state for undo
  &undo_save();
  # configure and re-paint object
  &apply_properties($obj_id,$obj,0,@p);
}

sub menus_x_mirror 
{
  my $obj_id=shift || $selected_id;
  my ($obj)=$canv_obj{$obj_id};
  return unless $obj;
  return if $obj->{name} =~ /Oval|Circle|Square|Rectangle|Pie|Chord/;
  if($scale_h ne '1:1'){ &menus_error("x_mirror with scale $scale_h"); return; }
  # find object middle-point
  my $par=$obj->{par};
  my @p=Drawing::array(@$par);
  my ($mpx,$mpy)=&middle_point($c,$obj_id);
  # re-calculate all points
  for (my $i=0;$i<$#p;$i+=2)
  {
    $p[$i]  =$mpx-($p[$i]  -$mpx);
  }
  # save current state for undo
  &undo_save();
  # configure and re-paint object
  &apply_properties($obj_id,$obj,0,@p);
}

sub menus_y_mirror
{
  my $obj_id=shift || $selected_id;
  my ($obj)=$canv_obj{$obj_id};
  return unless $obj;
  return if $obj->{name} =~ /Oval|Circle|Square|Rectangle|Pie|Chord/;
  if($scale_h ne '1:1'){ &menus_error("y_mirror with scale $scale_h"); return; }
  # find object middle-point
  my $par=$obj->{par};
  my @p=Drawing::array(@$par);
  my ($mpx,$mpy)=&middle_point($c,$obj_id);
  # re-calculate all points
  for (my $i=0;$i<$#p;$i+=2)
  {
    $p[$i+1] =$mpy-($p[$i+1]-$mpy);
  }
  # save current state for undo
  &undo_save();
  # configure and re-paint object
  &apply_properties($obj_id,$obj,0,@p);
}

sub free_rotate
{
  my $obj_id=shift || $selected_id;
  my ($obj)=$canv_obj{$obj_id};
  return unless $obj;
  # can't rotate: circle/oval/rectangle/square/pie/chord
  return if $obj->{name} =~ /Oval|Circle|Square|Rectangle|Pie|Chord/;
  if($scale_h ne '1:1'){ &menus_error("free_rotate with scale $scale_h"); return; }
  
#  my $par=$obj->{par};
  my @p=Drawing::array(@{$obj->{par}});

  # Show dialog and get angle:
  my $db=$mw->DialogBox(-title=>"Free rotate $obj_id",
    -buttons=>['Accept','Cancel']);#,'Preview']);
  my $alfa=0;
  #$db->LabEntry ( -labelPack=>[-side=>'left'=>-anchor=>'n'],
  #  -label=>'Angle:',-textvariable=>\$alfa,-width=>4 )->pack();
  $db->Label(-text=>'Angle:')->pack(-side=>'left',-padx=>5,-pady=>15);
  &NumEntry($db,-textvariable=>\$alfa,
      -width=>4)->pack(-side=>'left',-padx=>5,-pady=>15);
  my $reply=$db->Show();
  return if $reply eq 'Cancel';
  # save current state for undo
  &undo_save();
  # find object middle-point
  my ($Cx,$Cy)=&middle_point($c,$obj_id);
  my $cosA=cos($alfa*3.1415926/180);
  my $sinA=sin($alfa*3.1415926/180);
  for(my $i=0;$i<$#p;$i+=2)
  {
    my $Xr=$p[$i]  -$Cx;
    my $Yr=$p[$i+1]-$Cy;
    $p[$i]   = $Xr*$cosA-$Yr*$sinA+$Cx;
    $p[$i+1] = $Yr*$cosA+$Xr*$sinA+$Cy;
  }
  # configure and re-paint object
  &apply_properties($obj_id,$obj,0,@p);
}

sub edit_properties
{
  my ($obj_id)=shift;
  $obj_id=$selected_id unless $obj_id=~/^cnv_/;
  # find object in internal array by ID
  my ($obj)=$canv_obj{$obj_id};
  return unless $obj;
  
  # get properties via dialog box
  my $par=$obj->{par};
  map (s/'//g,@$par);
  my ($result,@par)=&get_properties($obj_id,$obj->{type},@$par);
  return unless $result;
  # save current state for undo
  &undo_save();
  &apply_properties($obj_id,$obj,1,@par);
}

sub apply_properties
{
  my ($obj_id,$obj,$appl_type,@par)=(@_);
  my $scale_save=$scale_h;
  &menus_scale('1:1');
  &selection_remove($selected_id);
  # re-configure object and canvas picture
  # for simmetric objects - re-order points
  my $obj_type=$canv_obj{$obj_id}->{name};
  if($obj_type=~/Oval|Circle|Square|Rectangle|Pie|Chord/)
  {
    my ($x0,$y0,$x1,$y1)=@par;
    ($x0,$x1)=($x1,$x0) if($x0>$x1);
    ($y0,$y1)=($y1,$y0) if($y0>$y1);
    $par[0,1,2,3]=($x0,$y0,$x1,$y1);
  }
  $obj->config($appl_type,@par);
  $canv_obj{$obj_id}=$obj;
  # Set modification flag on
  &changes(1);
  &menus_repaint();
  &menus_scale($scale_save);
  &selection_create($selected_id);
}

sub get_properties
{
  my($obj_id,$obj_type,@obj_par)=(@_);
  return 0 unless $obj_id;
  my (@new_par)=@obj_par;
  # 1. create dialog box according to obj. type
  my $db=$mw->DialogBox(-title=>"Object $obj_id properties",
    -buttons=>['Accept','Cancel']);#,'Preview']);
  my (@pack)=qw/-side top -padx 10 -pady 5 -fill x/;
  # ======================= configurable dialog here ============
  $obj_type=$canv_obj{$obj_id}->{name} unless $obj_type;
  my $p=$attr{$obj_type};
  map (s/'//g,@$p);
  my (%pr)=(@$p);
  my (%val)=Drawing::hash(@obj_par);
  # check for array legal length
  $val{'points'}=join(', ',Drawing::array(@obj_par));
  foreach my $k(sort keys %pr)
  {
    my $f=$db->Frame()->pack(@pack);
    $f->Label(-text=>$k)->pack(-side=>'left');
    if($k eq 'points')
    {
      $f->Entry(-textvariable=>\$val{'points'})->pack(-side=>'right');
    }
    elsif($pr{$k} eq 'color')
    {
      my $cl=$f->Menubutton(qw/-text Color -relief raised/)->pack(-side=>'right');
      my $m = $cl->Menu(-tearoff => 0);
      my $var=($val{$k})?1:0;
      my $i=1;
      foreach (qw/Brown Red pink wheat2 orange
        Yellow DarkKhaki LightSeaGreen Green DarkSeaGreen
        green4 DarkGreen Cyan LightSkyBlue Blue
        NavyBlue plum magenta1 Magenta3 purple3
        White gray90 gray75 gray50 Black/)
 	{ 
 	  $m->command(-label => $_, -columnbreak=>(($i-1) % 5)?0:1,
	    -command=>
	    [sub{$val{$k}=shift;$var=1;$cl->configure(-background=>$val{$k})},$_]);
 	  my $i1 = $m->Photo(qw/-height 16 -width 16/);
          $i1->put('gray50', qw/-to 0 0 16 1/);
          $i1->put('gray50', qw/-to 0 1 1 16/);
          $i1->put('gray75', qw/-to 0 15 16 16/);
          $i1->put('gray75', qw/-to 15 1 16 15/);
          $i1->put($_, qw/-to 1 1 15 15/);
 	  $m->entryconfigure($i, -image => $i1);
 	  $i++;
 	}
      $cl->configure(-menu => $m);
      $cl->configure(-background=>$val{$k}) if $val{$k};
      my $cb=$f->Checkbutton(-text => 'enabled',-relief => 'flat',
        -variable=>\$var,
        -command => sub{ $val{$k}='' unless $var; }
	)->pack(-side=>'right');
    }
    elsif($pr{$k} eq 'arrowside')
    {
      my (@as)=qw/none first last both/;
      my (%as)=(none=>'----',first=>'<---',last=>'--->',both=>'<-->');
      $val{$k}='none' unless $val{$k};

      my $am=$f->Menubutton(-text=>$as{$val{$k}},-relief=>'raised')->pack(-side=>'right');
      my $rc=$am->Menu(-tearoff => 0);
      foreach (@as)
      {
	$rc->radiobutton(-label=>$as{$_},-variable=>\$val{$k},-value=>$_,
	  -command=>sub{$am->configure(-text=>$as{$val{$k}})});
      }
      $am->configure( -menu => $rc);
    }
    elsif($pr{$k} eq 'linewidth')
    {
      &NumEntry($f,-textvariable=>\$val{$k},
          -width=>4,-minvalue=>0)->pack(-side=>'right');
    }
    elsif($pr{$k} =~ /^menu\(/)
    {
      my $menu=$pr{$k};
      $menu=~s/.*\(//;$menu=~s/\)//;
      if(split('\|',$menu)>2)
      {
        $f->Optionmenu(-options=>[split('\|',$menu)],-textvariable=>\$val{$k})
          ->pack(-side=>'right');
      }
      else
      {
        my ($on,$off)=split('\|',$menu);
        $val{$k}=$on unless $val{$k};
        $f->Button(-textvariable=>\$val{$k},-relief=>'flat',
          -command=>sub{$val{$k}=($val{$k} eq $on)?$off:$on;})->pack(-side=>'right');
      }
    }
  }

  # 2. run it and get reply status
  my $reply = # dialog box ...
    $db->Show();
  @new_par=split(/,\s*/,$val{'points'});
  # correct according to scale
  delete $val{'points'};
  push(@new_par,%val);
  # 3. if accept - return parameters
  return (0,@obj_par) if $reply eq 'Cancel';
  return (1,@new_par);
}

sub undo_save
{
  @redo=(); push(@undo,join("\n",&code_print()));
}

sub redo
{
  return unless @redo;
  my $scale_save=$scale_h;
  &menus_scale('1:1');
  $c->configure(-cursor=>'crosshair');
  push(@undo,join("\n",&code_print())); # undo <= current
  &canv_new;
  &code_read(split("\n",pop(@redo)));
  &menus_scale($scale_save);
  # repaint canvas list:
  $tf->delete('0','end');
  map($tf->insert(0,-data=>$_,-image=>$pic{lc("canv_$canv_obj{$_}->{name}")},-text=>$_),@canv_obj);
}

sub undo
{
  return unless @undo;
  my $scale_save=$scale_h;
  &menus_scale('1:1');
  $c->configure(-cursor=>'crosshair');
  # clear current design and restore from backup:
  push(@redo,join("\n",&code_print())); # redo <= current
  &canv_new;
  &code_read(split("\n",pop(@undo)));
  &menus_scale($scale_save);
  # repaint canvas list:
  $tf->delete('0','end');
  map($tf->insert(0,-data=>$_,-image=>$pic{lc("canv_$canv_obj{$_}->{name}")},-text=>$_),@canv_obj);
}

sub edit_delete
{
  my $obj_id=shift;
  $obj_id=$selected_id unless $obj_id=~/^cnv_/; # say warning?
  return unless $obj_id=~/^cnv_/;
  $c->configure(-cursor=>'crosshair');
  # save current state for undo
  &undo_save();
  foreach my $id(split(' ',$obj_id))
  {
    # 1. delete from data structures
    delete $canv_obj{$id};
    # 2. erase from canvas
    $c->delete($id);
    @canv_obj = grep (!/^$id$/,@canv_obj);
  }
  &selection_remove($selected_id); $selected_id='';
  &changes(1);
  # repaint canvas list:
  $tf->delete('0','end');
  map($tf->insert(0,-data=>$_,-image=>$pic{lc("canv_$canv_obj{$_}->{name}")},-text=>$_),@canv_obj);
}

sub menus_error
{
  $mw->Dialog(-bitmap=>'error',-text=> "@{_}? Still not implemented!\n")->Show();
}

# limited HTML format read
# 1. Text is pre-formatted
# 2. Each line associated with bold_text/regular_text/picture
sub read_html
{
  my $file_name=shift;
  my @result=();

  open (HTML,$file_name) || return 0;
  my @file=<HTML>;
  close HTML;
  my $body=0;
  my ($line,$type);
  foreach (@file)
  {
    $body=1 if/<body/i;
    $body=0 if/<\/body>/i;
    s/.*<body[^>]+>//i;
    s/<\/body>.*//i;
    if ($body)
    {
      next if /<.?pre>/;
      $type='text';
      if(/<b>.*<\/b>/i)
      {
        $line=$_;
	$line=~s/<.?b>//ig;
        $type ='bold';
      }
      elsif(/<img src=/i)
      {
        ($line) = (/<img src=["']([^'"]+)\.gif['"]/i);	
        $type ='gif';
      }
      else
      {
        $line=$_;
	$line=~s/<[^>]+>//g;
      }
      push(@result,"$type $line");
    }
  }
  return (@result);
}

sub help
{
  my $hd=$mw->DialogBox(-title=>'Help');
  my $t=$hd->Scrolled(qw/Text -scrollbars e -wrap word/)->pack(-fill=>'both');
  $t->tag(qw/configure bold -font C_bold/);
  $t->insert('0.0',"");
  foreach (@html_help)
  {
    my ($type,$line)=(/(\S+)\s(.*)/);
    if($type eq 'bold')
    {
      $t->insert('end',"$line\n",'bold');
    }
    elsif($type eq 'gif')
    {
      $t->imageCreate('end',-image=>$pic{$line});
      $t->insert('end',"\n");
    }
    else
    {
      $t->insert('end',"$line\n");
    }
  }
  $t->configure(-state=>'disabled');
  $hd->resizable(1,0);
  $hd->Show;
}

sub check_changes
{
  if($changes)
  {
    # ask for save
    
    my $reply=$mw->Dialog(-bitmap=>'question',
     -text=>"File not saved!\nDo you want to save the changes?",
        -title => "You have some changes", 
        -buttons => ['Save','Don\'t save', 'Cancel'])->Show;
    if($reply eq 'Save')
    {
      $reply=&file_save('Save As');
    }
    return 0 if($reply eq 'Cancel');
  }
  return 1; # Ok
}

sub file_open
{
  &file_new();
  $c->configure(-cursor=>'crosshair');

  $mw->Busy;
  # open file save dialog box
  my @types = ( ["Perl files",'.pl'], ["All files", '*'] );
  my $file = $lastfile;
  $file=~s#.*[/\\]([^/\\]+)$#$1#;
  if($ENV{OS}=~/(^win)|(^$)/i)
  {
    $file = $mw->getOpenFile(-filetypes => \@types,
                          -initialfile => $file,
                          -defaultextension => '.pl',
                          -title=>'file to read');
  }
  else
  {
    $file = $mw->FileSelect(-directory => '.',
                          -initialfile => $file,
                          -title=>'file to read')->Show;
  }
  $mw->Unbusy;
  # return 'Cancel' if file not selected
  return 'Cancel' unless($file);
  &file_read($file);
}

sub file_read
{
  my ($file)=shift;
  $lastfile=$file;
 
  unless(open (DATA,$file))
  {
    # report error
    $mw->Dialog(-text=>"File $file read - $!\n",-buttons=>['Continue'])->Show();
    return 'Cancel';
  }
  else
  {
    &code_read(<DATA>);
    @redo=(); @undo=(); # nothing to undo
    &changes(0);
    # repaint canvas list:
    $tf->delete('0','end');
    map($tf->insert(0,-data=>$_,-image=>$pic{lc("canv_$canv_obj{$_}->{name}")},-text=>$_),@canv_obj);
    close DATA;
  }
}

sub code_read
{
  $obj_count=0;
  $cnv_t = '';
  $cnv_bg = $bg_color;
  $cnv_fullcode = 0;
  foreach (@_)
  {
    chomp;
    if(/^\s*#!/) { $cnv_fullcode = 1; next; }
    if(/^\s*#/) { s/^\s*#\s*//; $cnv_t .= "$_ "; next; }
    if(/^\s*\$c->configure/) { ($cnv_bg) = m/-background=>'([^']+)'/; next; }
    s/^my \$//;
    s/\s+=.*create\([^,]+,/,/;
    s/,-tags=>.*//;
    s/'//g;
    my ($id,@pars)=split(/\s*,\s*/);
    my $type=(split('_',$id))[1];
    # map(s/'//g,@pars);
    &obj_create(0,$type,@pars);
  }
  $c->configure(-background=>$cnv_bg);
}

sub file_save
{
  my ($type)=shift;
  unless($type)
  {
    return unless $changes;
  }
  $c->configure(-cursor=>'crosshair');
  $mw->Busy;
  # open file save dialog box
  my @types = ( ["Perl files",'.pl'], ["All files", '*'] );
  my $file = $lastfile;
  $file=~s#.*[/\\]([^/\\]+)$#$1#;
  if(! -f $lastfile || $type)
  {
    $file='newfile.pl';
    if($ENV{OS}=~/(^win)|(^$)/i)
    {
      $file = $mw->getSaveFile(-filetypes => \@types,
                          -initialfile => $file,
                          -defaultextension => '.pl',
                          -title=>'file to save');
    }
    else
    {
      $file = $mw->FileSelect(-directory => '.',
                          -initialfile => $file,
                          -title=>'file to save')->Show;
    }
  }
  $mw->Unbusy;
  # return 'Cancel' if file not selected
  return 'Cancel' unless($file);
  $lastfile=$file;

  # save data structure to file
  unless(open (DATA,">$file"))
  {
    # report error
    $mw->Dialog(-text=>"File $file write - $!\n",-buttons=>['Continue'])->Show();
    return 'Cancel';
  }
  else
  {
    print DATA join("\n",&code_print());
    close DATA;
  }
  # reset changes flag
  &changes(0);
  return 0;
}

sub wm_abandon
{
  return unless &check_changes;
  $mw->destroy;
}

sub abandon
{
  return unless &check_changes;
  exit;
}

# This code is partially copied from original NumEntry
# Reason: the original widget does not support -textvariable (sic!)
# Problems: No strict syntax control, No FireButton functionality
my $def_bitmaps = 0;

sub NumEntry
{
  my ($parent,%par)=@_;
  my $numentry;
  my $minvalue=delete $par{'-minvalue'};
  unless($def_bitmaps) 
  {
    my $bits = pack("b8"x5,
      "........",
      "...11...",
      "..1111..",
      ".111111.",
      "........"
    );

    $mw->DefineBitmap('INCBITMAP' => 8,5, $bits);

    # And of course, decrement is the reverse of increment :-)
    $mw->DefineBitmap('DECBITMAP' => 8,5, scalar reverse $bits);
    $def_bitmaps=1;
  }
  my $result=$parent->Frame();
  $numentry=$result->Entry(%par)->pack(-anchor=>'w', -side=>'left');
  $numentry->bind('<Up>',[\&inc_num_controlled,$par{'-textvariable'},1,$minvalue]);
  $numentry->bind('<Down>',[\&inc_num_controlled,$par{'-textvariable'},-1,$minvalue]);
  $result->Button(-bitmap=>'INCBITMAP',-cursor=>'left_ptr',-command=>
    [\&inc_num_controlled,$par{'-textvariable'},1,$minvalue])
    ->pack(-anchor=>'nw', -side=>'top');
  $result->Button(-bitmap=>'DECBITMAP',-cursor=>'left_ptr',-command=>
    [\&inc_num_controlled,$par{'-textvariable'},-1,$minvalue])
    ->pack(-anchor=>'nw', -side=>'top');
  return $result;
}

sub inc_num_controlled
{
  shift if ref($_[0]) ne 'SCALAR';
  my ($ptr,$inc,$minvalue,$maxvalue)=@_;

  my $value=$$ptr+$inc;
  return if length $minvalue && $value<$minvalue;
  return if length $maxvalue && $value>$maxvalue;
  $$ptr=$value;
}

# Data storing/decoding:
# - All objects stored in array
# - File stored as perl include-file using $c as base canvas

package Drawing;

sub hash
{
  my (@p);  my $s=0;
  foreach (@_)
  {
    $s=1 if /^-\D/;
    push (@p,$_) if $s;
  }
  return @p;
}

sub array
{
  my (@p);
  foreach (@_){ last if /^-\D/; push (@p,$_)}
  return @p;
}

sub data_merge
{
  my ($merge_type,$p_new,$p_old)=(@_);
  my (@a_new)=array(@$p_new);
  my (%h_old)=hash(@$p_old);
  return (@a_new,%h_old) if $merge_type == 0;
  my (@a_old)=array(@$p_old);
  map(s/'//g,@$p_new);
  my (%h_new)=hash(@$p_new);
  @a_new=@a_old unless scalar(@a_new);
  foreach (keys %h_old)
  {
    $h_new{$_}=$h_old{$_} unless defined $h_new{$_};
  }
  map {delete $h_new{$_} unless $h_new{$_}} (qw/-width -fill -outline -splinesteps -start -extent/);
  return (@a_new,%h_new);
}

# Example:
# my $x = Drawing->new(qw/Line canv_line_000/);
sub new
{
  my $class=shift;
  my $self={};
  bless ($self,$class);
  $self->{'name'} = shift;
  $self->{'id'} = shift;
  map (s/'//g,@_);
  $self->{'par'} = [@_];
  return $self;
}

# Example:
# $x->config(-posx=>2,-posy=>15,-arrow=>'both',-width=>'3');
# note! we are changing internal structure, not a real drawing!
sub config
{
  my ($self,$merge_type,@par)=(@_);
  unless (@par)
  {
    return;
  }
  my $oldpar=$self->{'par'};
  $self->{'par'} = [&data_merge($merge_type,\@par,$oldpar)];
}

__END__