@Tk::SlideShow::Arrow::ISA
=
qw(Tk::SlideShow::Link)
;
Tk::SlideShow::Placeable->AddClass(
'Tk::SlideShow::Arrow'
);
my
$chshape
=
sub
{
my
(
$s
,
$what
,
$how
) =
@_
;
$s
->{
'shape'
}[
$what
]+=
$how
;
$s
->show;
};
my
$chwidth
=
sub
{
my
(
$s
,
$how
) =
@_
;
$s
->{
'width'
} +=
$how
;
$s
->show;
};
sub
New {
my
$class
=
shift
;
my
$s
=
$class
->SUPER::New(
@_
);
bless
$s
;
$s
->{
'shape'
}=[8,10,3];
$s
->{
'width'
} = 1;
my
$id
=
$s
->id;
my
$c
= Tk::SlideShow->canvas;
$c
->CanvasBind(
'Tk::SlideShow'
,
'<Up>'
,[\
&Tk::SlideShow::exec_if_current
,
$id
,
$chshape
,
$s
,0,1]);
$c
->CanvasBind(
'Tk::SlideShow'
,
'<Control-Up>'
,[\
&Tk::SlideShow::exec_if_current
,
$id
,
$chshape
,
$s
,0,-1]);
Tk::SlideShow->addkeyhelp(
'Press <Up> key on an arroww'
,
'to increase the distance along the line from the neck of the arrowhead to its tip.'
);
Tk::SlideShow->addkeyhelp(
'Press <Control-Up> key on an arroww'
,
'to decrease the distance along the line from the neck of the arrowhead to its tip.'
);
$c
->CanvasBind(
'Tk::SlideShow'
,
'<Down>'
, [\
&Tk::SlideShow::exec_if_current
,
$id
,
$chshape
,
$s
,1,1]);
$c
->CanvasBind(
'Tk::SlideShow'
,
'<Control-Down>'
, [\
&Tk::SlideShow::exec_if_current
,
$id
,
$chshape
,
$s
,1,-1]);
Tk::SlideShow->addkeyhelp(
'Press <Down> key on an arroww'
,
'to increase the distance along the line from the trailing points of the arrowhead to the tip.'
);
Tk::SlideShow->addkeyhelp(
'Press <Control-Down> key on an arrow'
,
'to decrease the distance along the line from the trailing points of the arrowhead to the tip.'
);
$c
->CanvasBind(
'Tk::SlideShow'
,
'<Left>'
, [\
&Tk::SlideShow::exec_if_current
,
$id
,
$chshape
,
$s
,2,1]);
$c
->CanvasBind(
'Tk::SlideShow'
,
'<Control-Left>'
, [\
&Tk::SlideShow::exec_if_current
,
$id
,
$chshape
,
$s
,2,-1]);
Tk::SlideShow->addkeyhelp(
'Press <Left> key on an arrow'
,
'to increase the distance from the outside edge of the line to the trailing points.'
);
Tk::SlideShow->addkeyhelp(
'Press <Control-Left> key on an arrow'
,
'to decrease the distance from the outside edge of the line to the trailing points.'
);
$c
->CanvasBind(
'Tk::SlideShow'
,
'<Right>'
, [\
&Tk::SlideShow::exec_if_current
,
$id
,
$chwidth
,
$s
,1]);
$c
->CanvasBind(
'Tk::SlideShow'
,
'<Control-Right>'
,[\
&Tk::SlideShow::exec_if_current
,
$id
,
$chwidth
,
$s
,-1]);
Tk::SlideShow->addkeyhelp(
'Press <Right> key on an arroww'
,
'to increase the width.'
);
Tk::SlideShow->addkeyhelp(
'Press <Control-Right> key on an arroww'
,
'to decrease the width.'
);
return
$s
;
}
sub
evalplace {
my
$s
=
shift
;
return
sprintf
(
"ftpos(%d,%d)->width(%d)->shape(%d,%d,%d)"
,
$s
->fpos,
$s
->tpos,
$s
->width,@{
$s
->shape});
}
sub
shape {
my
(
$s
,
@vals
) =
@_
;
if
(
defined
@vals
and
@vals
== 3) {
$s
->{
'shape'
} = [
@vals
];
$s
->show;
return
$s
;
}
return
$s
->{
'shape'
};
}
sub
width {
my
(
$s
,
$val
) =
@_
;
if
(
defined
$val
) {
$s
->{
'width'
} =
$val
;
$s
->show;
return
$s
;
}
return
$s
->{
'width'
};
}
sub
trace_link {
my
(
$s
,
$fx
,
$fy
,
$tx
,
$ty
) =
@_
;
my
$id
=
$s
->id;
my
$can
= Tk::SlideShow->canvas;
$can
->createLine(
$fx
,
$fy
,
$tx
,
$ty
,-arrow,
'last'
,
'-arrowshape'
,
$s
->shape,
'-width'
,
$s
->width,
-tags,
$id
);
if
(
$s
->titre) {
my
$wid
=
$can
->createText((
$fx
+
$tx
)/2,(
$fy
+
$ty
)/2,
'-text'
,
$s
->titre, -tags,
$id
);
$can
->createRectangle(
$can
->bbox(
$wid
),-fill,
'lightYellow'
,-outline,
'red'
,-tags,
$id
);
$can
->raise(
$wid
);
}
return
$s
;
}