From 45b13a34d777859147ce128a4271255e81c8c22c Mon Sep 17 00:00:00 2001 From: lecoanet Date: Fri, 22 Dec 2000 17:01:28 +0000 Subject: *** empty log message *** --- sandbox/controls.pl | 168 +++++++++++++++++++++++++++++++++++++++++++++++++++ sandbox/local.pl | 58 ++++++++++++++++++ sandbox/local.tcl | 12 +++- sandbox/testarc.tcl | 14 +++-- sandbox/testicon.tcl | 2 +- sandbox/testpoly.tcl | 4 +- sandbox/testtext.tcl | 13 ++-- sandbox/zinc.tcl | 4 +- 8 files changed, 257 insertions(+), 18 deletions(-) create mode 100644 sandbox/controls.pl create mode 100644 sandbox/local.pl (limited to 'sandbox') diff --git a/sandbox/controls.pl b/sandbox/controls.pl new file mode 100644 index 0000000..fcddda5 --- /dev/null +++ b/sandbox/controls.pl @@ -0,0 +1,168 @@ +$tlbbox = $zinc->add('group', $top, + -sensitive => 0, -visible => 0, + -tags 'currentbbox'); +$zinc->add('rectangle', $tlbbox, [-3, -3, +3, +3]); +$trbbox = $zinc->add('group', $top, + -sensitive => 0, -visible => 0, + -tags => 'currentbbox'); +$zinc->add('rectangle', $trbbox, [-3, -3, +3, +3]); +$blbbox = $zinc->add('group', $top, + -sensitive => 0, -visible => 0, + -tags => 'currentbbox'); +$zinc->add('rectangle', $blbbox, [-3, -3, +3, +3]); +$brbbox = $zinc->add('group', $top, + -sensitive => 0, -visible => 0, + -tags 'currentbbox'); +$zinc->add('rectangle', $brbbox, [-3, -3, +3, +3]); +$zinc->add('rectangle', $top, [0, 0, 1, 1], + -linecolor => 'red', -tags => 'lasso', + -visible => 0, -sensitive => 0); + +# +# Controls for the window transform. +# +proc press {lx ly action} { + global x y angle + set x $lx + set y $ly + set angle [expr atan2($y, $x)] + bind .r "" "$action %x %y" +} + +proc motion {lx ly} { + global x y + set it [.r find withtag controls] + if {$it != ""} { + set it [.r group [lindex $it 0]] + } + set res [.r transform $it "$lx $ly $x $y"] + set nx [lindex $res 0] + set ny [lindex $res 1] + set ox [lindex $res 2] + set oy [lindex $res 3] + .r translate controls [expr $nx - $ox] [expr $ny - $oy] + set x $lx + set y $ly +} + +proc zoom {lx ly} { + global x y + + if {$lx > $x} { + set maxx $lx + } else { + set maxx $x + } + if {$ly > $y} { + set maxy $ly + } else { + set maxy $y + } + set sx [expr 1.0 + double($lx - $x)/$maxx] + set sy [expr 1.0 + double($ly - $y)/$maxy] + set x $lx + set y $ly + .r scale controls $sx $sy +} + +proc rotate {lx ly} { + global angle + + set langle [expr atan2($ly, $lx)] + .r rotate controls [expr -($langle-$angle)] + set angle $langle +} + +proc release {} { + bind .r "" "" +} + +proc start_lasso {lx ly} { + global top x y cx cy + set x $lx + set y $ly + set cx $lx + set cy $ly + set coords [.r transform $top "$x $y"] + set fx [lindex $coords 0] + set fy [lindex $coords 1] + .r coords lasso "$fx $fy $fx $fy" + .r itemconfigure lasso -visible t + .r raise lasso + bind .r "" "lasso %x %y" +} + +proc lasso {lx ly} { + global top x y cx cy + set cx $lx + set cy $ly + set coords [.r transform $top "$x $y $lx $ly"] + set fx [lindex $coords 0] + set fy [lindex $coords 1] + set fcx [lindex $coords 2] + set fcy [lindex $coords 3] + .r coords lasso "$fx $fy $fcx $fcy" +} + +proc fin_lasso {} { + global x y cx cy + + bind .r "" "" + .r itemconfigure lasso -visible f +# puts "x=$x, y=$y, cx=$cx, cy=$cy" + puts "enclosed='[.r find enclosed $x $y $cx $cy]', overlapping='[.r find overlapping $x $y $cx $cy]'" +} + +proc getrect {x y} { + list [expr $x-3] [expr $y-3] [expr $x+3] [expr $y+3] +} + +proc showbox {} { + global top tlbbox trbbox blbbox brbbox + + if { ! [.r hastag current currentbbox]} { + if {[catch {.r find withtag current} item] } { + return + } + set coords [.r transform $top [.r bbox current]] + set xo [lindex $coords 0] + set yo [lindex $coords 1] + set xc [lindex $coords 2] + set yc [lindex $coords 3] + + .r coords $tlbbox "$xo $yo" + .r coords $trbbox "$xc $yo" + .r coords $brbbox "$xc $yc" + .r coords $blbbox "$xo $yc" + .r itemconfigure currentbbox -visible t + } +} + +proc hidebox {lx ly} { + set next [.r find closest $lx $ly] + if {[llength $next] > 1} { + set next [lindex $next 0] + } + if { $next == "" || ! [.r hastag $next currentbbox] ||\ + [.r hastag current currentbbox]} { + .r itemconfigure currentbbox -visible f + } +} + + +$zinc->bind('', "start_lasso %x %y"); +$zinc->bind('', \&fin_lasso); +$zinc->bind('', sub { $closest = $zinc->find('closest', %x %y); + print "at point=$closest\n" }); + +$zinc->bind('', "press %x %y motion"); +$zinc->bind('', \&release); + +$zinc->bind('', "press %x %y zoom"); +$zinc->bind('', \&release); + +$zinc->bind('' "press %x %y rotate"); +$zinc->bind('', \&release); + +$zinc->bind('current', '', \&showbox); +$zinc->bind('current', '', {hidebox %x %y}); diff --git a/sandbox/local.pl b/sandbox/local.pl new file mode 100644 index 0000000..ccebad0 --- /dev/null +++ b/sandbox/local.pl @@ -0,0 +1,58 @@ +#!/usr/bin/perl -w + +use Tk; +use Tk::Zinc; + +$mw = MainWindow->new(); +$logo = $mw->Photo(-file => "logo.gif"); +$papier = $mw->Photo(-file => "texture-paper.xpm"); +#$penguin = $mw->Photo(-file => "xpenguin.png"); + +$top = 1; +$zinc = $mw->Zinc(-localrender => 1, -relief => 'sunken'); +$zinc->pack(-expand => 1, -fill => 'both'); +$zinc->configure(-width => 500, -height => 500); +$gr1 = $zinc->add('group', $top); +$clip = $zinc->add('rectangle', $gr1, [50, 50, 399, 399], + -filled => 1, -fillcolor => 'pink', -linewidth => 0); +$zinc->itemconfigure($gr1, -clip => $clip); +$gr2 = $zinc->add('group', $gr1); +$clip2 = $zinc->add('rectangle', $gr2, [200, 200, 450, 450], + -filled => 1, -fillcolor => 'lavender', -linewidth => 0); +#$zinc->itemconfigure($gr2, -clip => $clip2); +$view = $zinc->add('group', $gr2, -tags => "controls"); +$zinc->lower($clip); +$zinc->lower($clip2); + +$rect = $zinc->add('rectangle', $view, [100, 100, 200, 200], + -linewidth => 4, -tile => $papier, + -fillcolor => 'pink', -fillalpha => 128, + -filled => 1); +$fvwm = $zinc->add('icon', $view, + -mask => '@fvwm.xbm', -position => [250, 120], + -anchor => 'center', -color => 'black', + -alpha => 255); +$rect2 = $zinc->add('rectangle', $view, [150, 50, 300, 300], + -linewidth => 0, -tile => $logo, + -fillcolor => 'white', -fillalpha => 90, + -filled => 1); +$x = 100; +$y = 100; +for ($i = 0; $i < 1; $i++) { + $x = $x+3; + $y = $y+3; + $zinc->add('text', $view, + -text => "BlaBla et tout et tout, bref...", + -position => [$x, $y], -anchor => 'nw', + -color => 'red', -alpha => 90); +} +#$peng = $zinc->add('icon', $view, +# -image => $penguin, -position => [300, 300], +# -anchor => 'center', -alpha => 128); +$zinc->translate($rect, -150, -150); +$zinc->rotate($rect, 35); +$zinc->translate($rect, 150, 150); + +#source controls.tcl +# +MainLoop(); diff --git a/sandbox/local.tcl b/sandbox/local.tcl index e6886ae..d42ba2a 100644 --- a/sandbox/local.tcl +++ b/sandbox/local.tcl @@ -1,4 +1,4 @@ -#!/usr/bin/wish -f +#!/usr/bin/wish8.0 -f load tkzinc3.1.so package require Img @@ -12,7 +12,15 @@ image create photo penguin -file xpenguin.png set r [zinc .r -relief sunken -localrender 1] pack .r -expand t -fill both .r configure -width 500 -height 500 -set view [.r add group $top -tags "controls"] +set gr1 [.r add group $top] +set clip [.r add rectangle $gr1 "50 50 399 399" -filled 1 -fillcolor pink -linewidth 0] +#.r itemconfigure $gr1 -clip $clip +set gr2 [.r add group $gr1] +set clip2 [.r add rectangle $gr2 "200 200 450 450" -filled 1 -fillcolor lavender -linewidth 0] +#.r itemconfigure $gr2 -clip $clip2 +set view [.r add group $gr2 -tags "controls"] +.r lower $clip +.r lower $clip2 set rect [.r add rectangle $view "100 100 200 200" -linewidth 4 \ -tile papier -fillcolor pink -fillalpha 128 -filled 1] diff --git a/sandbox/testarc.tcl b/sandbox/testarc.tcl index 23e961a..876bc97 100644 --- a/sandbox/testarc.tcl +++ b/sandbox/testarc.tcl @@ -1,4 +1,4 @@ -#!/usr/bin/wish -f +#!/usr/bin/wish8.0 -f load tkzinc3.1.so package require Img @@ -8,8 +8,9 @@ set top 1 image create photo logo -file logo.gif image create photo papier -file texture-paper.xpm image create photo penguin -file xpenguin.png +image create photo papier -file texture-paper.xpm -set r [zinc .r -backcolor gray -relief sunken] +set r [zinc .r -backcolor gray -relief sunken -localrender 1] pack .r -expand t -fill both .r configure -width 800 -height 500 #.r configure -drawbboxes t @@ -19,7 +20,9 @@ set view [.r add group $top -tags "controls"] set view2 [.r add group $top] .r translate $view2 300 -200 -set arc [.r add arc $view "50 -10 200 -100" -filled t -closed t -pieslice t -fillcolor "white darkslateblue 17" -gradient "50" -linewidth 1] +set arc [.r add arc $view "50 -10 200 -100" -filled t -closed t -pieslice f \ + -fillcolor "white darkslateblue 17" -gradient "50" -linewidth 1 \ + -startangle 0 -extent 120 -tile papier] #set arc [.r add arc $view "50 -10 200 -100" -filled t -closed t -pieslice t -fillcolor "#ff0000 #00ff00 17" -gradient "50" -linewidth 0] #.r add arc $view "60 -20 190 -90" -filled t -closed t -pieslice t -fillcolor "white darkslateblue 17" -gradient "50/180" -linewidth 1 -linecolor white #.r rotate $arc 10 @@ -28,10 +31,11 @@ set arc [.r add arc $view "50 -10 200 -100" -filled t -closed t -pieslice t -fil #.r translate $arc2 100 -100 .r add icon $view2 -image penguin -set cliparc [.r add arc $view2 "-100 100 100 -100" -filled t -fillcolor tan -visible t] +set cliparc [.r add arc $view2 "-100 100 100 -100" -filled t \ + -fillcolor tan -fillalpha 200] .r lower $cliparc #.r rotate $cliparc 20 .r translate $cliparc 100 -40 -.r itemconfigure $view2 -clip $cliparc +#.r itemconfigure $view2 -clip $cliparc source "controls.tcl" diff --git a/sandbox/testicon.tcl b/sandbox/testicon.tcl index 07a976e..81ad0bd 100644 --- a/sandbox/testicon.tcl +++ b/sandbox/testicon.tcl @@ -10,7 +10,7 @@ image create photo bouton -file bouton.xpm image create photo boutond -file bouton-down.xpm set mask "fvwm.xbm" -set r [zinc .r -backcolor gray -relief sunken] +set r [zinc .r -backcolor gray -relief sunken -localrender 0] pack .r -expand t -fill both .r configure -width 800 -height 500 #.r configure -drawbboxes t diff --git a/sandbox/testpoly.tcl b/sandbox/testpoly.tcl index 2363a82..837b8b5 100644 --- a/sandbox/testpoly.tcl +++ b/sandbox/testpoly.tcl @@ -1,4 +1,4 @@ -#!/usr/bin/wish -f +#!/usr/bin/wish8.0 -f load tkzinc3.1.so package require Img @@ -33,7 +33,7 @@ set show {\ image create photo logo -file /usr/share/toccata/images/logo.gif #image create photo papier -file /usr/share/toccata/images/dgtexture-dragstrip.xpm -set r [zinc .r -backcolor gray -relief sunken] +set r [zinc .r -backcolor gray -relief sunken -localrender 1] pack .r -expand t -fill both .r configure -width 1024 -height 800 .r scale $top 1 -1 diff --git a/sandbox/testtext.tcl b/sandbox/testtext.tcl index 818d8df..b0281f4 100644 --- a/sandbox/testtext.tcl +++ b/sandbox/testtext.tcl @@ -1,15 +1,16 @@ -#!/usr/bin/wish -f +#!/usr/bin/wish8.0 -f load tkzinc3.1.so package require Img -set top 1 set mask "/usr/X11R6/include/X11/bitmaps/fvwm.xbm" -set r [zinc .r -backcolor gray -relief sunken -insertbackground red -insertwidth 10] +set r [zinc .r -backcolor gray -relief sunken \ + -insertbackground red -insertwidth 10 -localrender 0] pack .r -expand t -fill both .r configure -width 800 -height 500 # .r configure -drawbboxes t +set top [.r add group 1] .r addtag controls withtag $top .r add rectangle $top "-50 0 +50 1" -composescale 0 @@ -68,19 +69,19 @@ set x [expr $x + 200.0] set x 150 set y 300 -.r add text $top -text "Ce texte tient sur plusieurs lignes.\nLes alignements :\n- à gauche\n-à droite\n-au centre\nsont également mis en évidence.\n" -position "$x $y" -anchor center +.r add text $top -text "Ce texte tient sur plusieurs lignes.\nLes alignements :\n- à gauche\n- à droite\n- au centre\nsont également mis en évidence.\n" -position "$x $y" -anchor center .r add rectangle $top [list [expr $x - 3.0] [expr $y - 3.0] \ [expr $x + 3.0] [expr $y + 3.0]] -filled 1 -fillcolor red set x 400 set y 300 -set anim [.r add text $top -text "Ce texte tient sur plusieurs lignes.\nLes alignements :\n- à gauche\n-à droite\n-au centre\nsont également mis en évidence.\nLe texte central montre l'utilisation\nd'un espacement des lignes programmable." -position "$x $y" -anchor center -alignment center -spacing -5 -font {times 14 bold italic}] +set anim [.r add text $top -text "Ce texte tient sur plusieurs lignes.\nLes alignements :\n- à gauche\n- à droite\n- au centre\nsont également mis en évidence.\nLe texte central montre l'utilisation\nd'un espacement des lignes programmable." -position "$x $y" -anchor center -alignment center -spacing -5 -font {times 14 bold italic}] .r add rectangle $top [list [expr $x - 3.0] [expr $y - 3.0] \ [expr $x + 3.0] [expr $y + 3.0]] -filled 1 -fillcolor red set x 650 set y 300 -.r add text $top -text "Ce texte tient sur plusieurs lignes.\nLes alignements :\n- à gauche\n-à droite\n-au centre\nsont également mis en évidence.\n" -position "$x $y" -anchor center -alignment right +.r add text $top -text "Ce texte tient sur plusieurs lignes.\nLes alignements :\n- à gauche\n- à droite\n- au centre\nsont également mis en évidence.\n" -position "$x $y" -anchor center -alignment right .r add rectangle $top [list [expr $x - 3.0] [expr $y - 3.0] \ [expr $x + 3.0] [expr $y + 3.0]] -filled 1 -fillcolor red diff --git a/sandbox/zinc.tcl b/sandbox/zinc.tcl index b47a702..74a76f0 100644 --- a/sandbox/zinc.tcl +++ b/sandbox/zinc.tcl @@ -1,4 +1,4 @@ -#!/usr/bin/wish -f +#!/usr/bin/wish8.0 -f load tkzinc3.1.so #package require Img @@ -222,7 +222,7 @@ set topclip [.r add rectangle $top "-400 -400 400 400" \ # proc borders {onoff} { set part [.r currentpart] - puts "$part" + puts "part $part $onoff" set contour noborder if { $onoff == "on" } { set contour "contour oblique" -- cgit v1.1