diff options
| -rw-r--r-- | Perl/Zinc.pm | 7 | ||||
| -rw-r--r-- | sandbox/controls.tcl | 4 | ||||
| -rw-r--r-- | sandbox/testbezier.tcl | 2 | ||||
| -rw-r--r-- | sandbox/testplug.pl | 54 | ||||
| -rw-r--r-- | sandbox/testpoly.tcl | 9 | ||||
| -rw-r--r-- | sandbox/testwind.tcl | 7 | ||||
| -rw-r--r-- | sandbox/testzinc.pl | 3 | ||||
| -rw-r--r-- | sandbox/zinc.tcl | 7 | ||||
| -rw-r--r-- | sandbox/zinc.test | 154 |
9 files changed, 230 insertions, 17 deletions
diff --git a/Perl/Zinc.pm b/Perl/Zinc.pm index 703da13..5b93743 100644 --- a/Perl/Zinc.pm +++ b/Perl/Zinc.pm @@ -19,10 +19,11 @@ sub Tk_cmd { \&Tk::zinc } Tk::Methods("add", "addtag", "anchorxy", "bbox", "becomes", "bind", "cget", "chggroup", "clone", "configure", "contour", "coords", "currentpart", "cursor", "dchars", "dtag", "find", "fit", "focus", "gettags", - "group", "hasanchors", "hasfields", "hasparts", "hastag", "index", + "group", "hasanchors", "hasfields", "hastag", "index", "insert", "itemcget", "itemconfigure", "lower", "monitor", - "raise", "remove", "rotate", "scale", "select", "smooth", "tdelete", - "transform", "translate", "treset", "trestore", "tsave", "type"); + "numparts", "postscript", "raise", "remove", "rotate", "scale", + "select", "smooth", "tapply", "tdelete", "transform", "translate", + "treset", "trestore", "tsave", "type", "verticeat"); 1; __END__ diff --git a/sandbox/controls.tcl b/sandbox/controls.tcl index 9301d1a..d865020 100644 --- a/sandbox/controls.tcl +++ b/sandbox/controls.tcl @@ -129,7 +129,7 @@ proc showbox {} { } proc hidebox {lx ly} { - set next [.r find atpoint $lx $ly] + set next [.r find closest $lx $ly] if {[llength $next] > 1} { set next [lindex $next 0] } @@ -143,7 +143,7 @@ proc hidebox {lx ly} { bind .r "<ButtonPress-1>" "start_lasso %x %y" bind .r "<ButtonRelease-1>" fin_lasso -bind .r "<ButtonPress-2>" {puts "at point='[.r find atpoint %x %y]'"} +bind .r "<ButtonPress-2>" {puts "at point='[.r find closest %x %y]'"} bind .r "<ButtonPress-3>" "press %x %y motion" bind .r "<ButtonRelease-3>" release diff --git a/sandbox/testbezier.tcl b/sandbox/testbezier.tcl index 3f1f25b..528ddac 100644 --- a/sandbox/testbezier.tcl +++ b/sandbox/testbezier.tcl @@ -124,5 +124,7 @@ focus .r bind .r "<a>" toggle_arrows bind .r "<c>" toggle_closed +bind .r "<Shift-1>" {set it [.r find closest %x %y]; puts "$it [.r verticeat $it %x %y]"} +bind .r "<Shift-ButtonRelease-1>" {break} source "controls.tcl" diff --git a/sandbox/testplug.pl b/sandbox/testplug.pl new file mode 100644 index 0000000..c298881 --- /dev/null +++ b/sandbox/testplug.pl @@ -0,0 +1,54 @@ +#!/usr/bin/perl + +use Tk; + +$mw = MainWindow->new(); + +$zinc = $mw->Zinc(-backcolor => 'gray', + -relief => 'sunken', + -width => 800, + -height => 500)->pack(-expand => 1, + -fill => 'both'); +$top = 1; +#$ent = $zinc->Entry(); +#$entryitem = $zinc->add('window', $top, +# -window => $ent, +# -position => [100, 100]); +$dcontainer = $zinc->Frame(-container => 1); +$did = $dcontainer->id(); +$vcontainer = $zinc->Frame(-container => 1); +$vid = $vcontainer->id(); +#print "container id is $id\n"; + +$dlabel = $zinc->add('text', $top, + -text => "Digistrips", + -position => [150, 30]); +$zinc->bind($dlabel, '<1>', sub { $zinc->itemconfigure($vlabel, -color => 'black'); + $zinc->itemconfigure($dlabel, -color => 'red'); + $zinc->itemconfigure($vcontitem, -visible => 0); + $zinc->itemconfigure($dcontitem, -visible => 1); }); +$vlabel = $zinc->add('text', $top, + -text => "Virtuosi", + -position => [250, 30]); +$zinc->bind($vlabel, '<1>', sub { $zinc->itemconfigure($dlabel, -color => 'black'); + $zinc->itemconfigure($vlabel, -color => 'red'); + $zinc->itemconfigure($dcontitem, -visible => 0); + $zinc->itemconfigure($vcontitem, -visible => 1); }); +$dcontitem = $zinc->add('window', $top, + -window => $dcontainer, + -position => [50, 75], + -visible => 0); +$vcontitem = $zinc->add('window', $top, + -window => $vcontainer, + -position => [50, 75], + -visible => 0); + +$ENV{DIGISTRIPS_PATH} = '/home/etienne/WORK/digistripsIII/src:/home/etienne/WORK/digistripsIII/data'; +$ENV{VIRTUOSI_PATH} = '/home/etienne/WORK/virtuosi/src:/home/etienne/WORK/virtuosi/data'; + +$mw->update(); + +system("/home/etienne/WORK/digistripsIII/src/digistrips -stan --use $did -style standalone-1024x768 &"); +system("/home/etienne/WORK/virtuosi/src/virtuosi -g 1024x768 -use $vid &"); + +MainLoop(); diff --git a/sandbox/testpoly.tcl b/sandbox/testpoly.tcl index b5637c3..2363a82 100644 --- a/sandbox/testpoly.tcl +++ b/sandbox/testpoly.tcl @@ -130,11 +130,7 @@ proc toggle_closed { } { global closed set closed [expr ! $closed] foreach curve [.r find withtag "poly"] { - if {$closed} { - .r coords $curve add [.r coords $curve 0] - } { - .r coords $curve remove -1 - } + .r itemconfigure $curve -closed $closed } } @@ -144,7 +140,8 @@ focus .r bind .r "<a>" toggle_arrows bind .r "<c>" toggle_closed bind .r "<m>" toggle_marks -#bind .r "<s>" toggle_smooth +bind .r "<Shift-1>" {set it [.r find closest %x %y]; puts "$it [.r verticeat $it %x %y]"} +bind .r "<Shift-ButtonRelease-1>" {break} source "controls.tcl" diff --git a/sandbox/testwind.tcl b/sandbox/testwind.tcl index 31723f9..8ad97e0 100644 --- a/sandbox/testwind.tcl +++ b/sandbox/testwind.tcl @@ -11,6 +11,9 @@ pack .r -expand t -fill both .r addtag controls withtag $top set ent [entry .r.entry] +set wind [.r add window $top -window $ent -position "100 100" -set wind [.r add window $top -window $ent -position "100 100"] - +set container [frame .r.cont -container t] +set id [winfo id $container] +puts "container id is $id\n" +set cont [.r add window $top -window $container -position "200 200"] diff --git a/sandbox/testzinc.pl b/sandbox/testzinc.pl index 37dc558..8c318e3 100644 --- a/sandbox/testzinc.pl +++ b/sandbox/testzinc.pl @@ -113,7 +113,7 @@ $zinc->itemconfigure($wp, $zinc->itemconfigure($wp, 0 ,-filled => 1 ,-backcolor => "tan",-text => "TO"); $zinc->itemconfigure($wp, 1 ,-filled => 1 ,-backcolor => "wheat",-text => "TO"); $zinc->itemconfigure($wp, 2 ,-border => "contour"); -$zinc->bind($wp, "<Enter>", [ \&borders, "on"]); +$zinc->bind($wp, "<Enter>", \&borders); $zinc->bind($wp, "<Leave>", [ \&borders, "off"]); ################################################### @@ -230,6 +230,7 @@ MainLoop; sub borders { my($widget, $onoff) = @_; + $onoff = "on" unless $onoff; my $part = $zinc->currentpart; my $contour = "noborder"; $contour = "contour" if ($onoff eq 'on'); diff --git a/sandbox/zinc.tcl b/sandbox/zinc.tcl index 55d09db..bcb6c69 100644 --- a/sandbox/zinc.tcl +++ b/sandbox/zinc.tcl @@ -106,8 +106,8 @@ set track [.r add track $view 6 -tags track -leaderanchors "|0|0"] -font "cenapii-etiquette-m17" .r itemconfigure $track 5 -text "450" -font "cenapii-etiquette-m17" -.r bind $track:-3 <Enter> ".r itemconfigure $track -speedvectorcolor red" -.r bind $track:-3 <Leave> ".r itemconfigure $track -speedvectorcolor salmon" +.r bind $track:speedvector <Enter> ".r itemconfigure $track -speedvectorcolor red" +.r bind $track:speedvector <Leave> ".r itemconfigure $track -speedvectorcolor salmon" set track2 [.r add track $view 4 -speedvector "-20 0" \ -symbolcolor salmon -speedvectorcolor salmon -leadercolor salmon \ @@ -219,11 +219,12 @@ set topclip [.r add rectangle $top "-400 -400 400 400" \ # proc borders {onoff} { set part [.r currentpart] + puts "$part" set contour noborder if { $onoff == "on" } { set contour "contour" } - if { $part >= 0 } { + if { [regexp {^[0-9]+$} $part] } { .r itemconfigure current $part -border $contour } } diff --git a/sandbox/zinc.test b/sandbox/zinc.test new file mode 100644 index 0000000..d5ce7fe --- /dev/null +++ b/sandbox/zinc.test @@ -0,0 +1,154 @@ +#-*- mode:tcl -*- + +if {[lsearch [namespace children] ::tcltest] == -1} { +# package require tcltest +# namespace import ::tcltest::* + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +proc setupHier {} { + set view [.r add group 1] + .r add rectangle $view "50 -150 100 -50" -tags "poly rectangle" + set model [.r add group $view] + .r add curve $model "50 -150 100 -50" -tags "poly foo" + .r add rectangle $model "50 -150 100 -50" -tags "rectangle" + .r add text $model -text "UnTexte" -tags "title" + .r clone $model + .r clone $model + .r clone $model + .r remove $model +} + +load tkzinc3.1.so +zinc .r +pack .r +update +setupHier + +test FindItems-1.0 {Test subcommand 'all' with no args} {} { + .r find all +} {2 3 16 19 18 17 12 15 14 13 8 11 10 9} + +test FindItems-1.1 {Test subcommand 'all' with top group} {} { + .r find all 1 +} {2 3 16 19 18 17 12 15 14 13 8 11 10 9} + +test FindItems-1.2 {Test subcommand 'all' with top group, non-recursive} {} { + .r find all 1 f +} {2} + +test FindItems-1.3 {Test subcommand 'all' with inner group} {} { + .r find all 2 +} {3 16 19 18 17 12 15 14 13 8 11 10 9} + +test FindItems-1.4 {Test subcommand 'all' with inner group, non-recursive} {} { + .r find all 2 f +} {3 16 12 8} + +test FindItems-1.5 {Test subcommand 'all' with inner most group} {} { + .r find all 8 +} {11 10 9} + +test FindItems-1.6 {Test subcommand 'all' with inner most group, non-recursive} {} { + .r find all 8 f +} {11 10 9} + +test FindItems-2.0 {Test subcommand 'above' with id} {} { + .r find above 9 +} {10} + +test FindItems-2.1 {Test subcommand 'above' with tag} {} { + .r find above foo +} {18} + +test FindItems-2.2 {Test subcommand 'above' with tag in group} {} { + .r find above foo 8 +} {10} + +test FindItems-2.3 {Test subcommand 'above' with tag in group} {} { + .r find above foo 2 f +} {} + +test FindItems-3.0 {Test subcommand 'below' with id} {} { + .r find below 10 +} {9} + +test FindItems-3.1 {Test subcommand 'below' with tag} {} { + .r find below title +} {10} + +test FindItems-3.2 {Test subcommand 'below' with tag in group} {} { + .r find below title 12 +} {14} + +test FindItems-3.3 {Test subcommand 'below' with tag in group, non-recursive} {} { + .r find below title 2 f +} {} + +test FindItems-4.0 {Test subcommand 'atpriority'} {} { + .r find atpriority 2 +} {3 19 18 17 15 14 13 11 10 9} + +test FindItems-4.1 {Test subcommand 'atpriority' in group} {} { + .r find atpriority 2 2 +} {3 19 18 17 15 14 13 11 10 9} + +test FindItems-4.2 {Test subcommand 'atpriority' in group, non-recursive} {} { + .r find atpriority 2 2 f +} {3} + +test FindItems-5.0 {Test subcommand 'withtag'} {} { + .r find withtag poly +} {3 17 13 9} + +test FindItems-5.1 {Test subcommand 'withtag' in group} {} { + .r find withtag poly 2 +} {3 17 13 9} + +test FindItems-5.2 {Test subcommand 'withtag' in group, non-recursive} {} { + .r find withtag poly 2 f +} {3} + +test FindItems-6.0 {Test subcommand 'withtype'} {} { + .r find withtype rectangle +} {3 18 14 10} + +test FindItems-6.1 {Test subcommand 'withtype' in group} {} { + .r find withtype rectangle 2 +} {3 18 14 10} + +test FindItems-6.2 {Test subcommand 'withtype' in group, non-recursive} {} { + .r find withtype rectangle 2 f +} {3} + +test FindItems-7.0 {Test tag operator '&&'} {} { + .r find withtag {poly && rectangle} +} {3} + +test FindItems-7.1 {Test tag operator '||'} {} { + .r find withtag {poly || rectangle} +} {3 18 17 14 13 10 9} + +test FindItems-7.2 {Test tag operator '!'} {} { + .r find withtag {!rectangle&&!poly} +} {2 16 19 12 15 8 11} + +test FindItems-7.3 {Test tag operator '^'} {} { + .r find withtag {rectangle^poly} +} {18 17 14 13 10 9} + +test FindItems-7.4 {Test tag grouping operator '()'} {} { + .r find withtag {!(rectangle&&poly)} +} {2 16 19 18 17 12 15 14 13 8 11 10 9} + +test FindItems-7.5 {Test not using tag grouping operator '()'} {} { + .r find withtag {!rectangle&&poly} +} {17 13 9} + +catch {destroy .r} +#zinc .r +#pack .r +#update + +::tcltest::cleanupTests +return |