From 284f06f678e37448d9c7b5bd97b322a67a67f62d Mon Sep 17 00:00:00 2001 From: lecoanet Date: Fri, 3 Oct 2003 14:47:31 +0000 Subject: Ported from Perl code. --- demos/groupsInAtcStrips.tcl | 1265 +++++++++++++++++++++---------------------- 1 file changed, 610 insertions(+), 655 deletions(-) (limited to 'demos') diff --git a/demos/groupsInAtcStrips.tcl b/demos/groupsInAtcStrips.tcl index c5739f1..b373b26 100644 --- a/demos/groupsInAtcStrips.tcl +++ b/demos/groupsInAtcStrips.tcl @@ -1,4 +1,3 @@ -#!/usr/bin/perl -w #----------------------------------------------------------------------------------- # # Copyright (C) 2002 @@ -45,6 +44,8 @@ if {![info exists zincDemo]} { error "This script should be run from the zinc-widget demo." } +#package require profiler +#::profiler::init set w .groupsInAtcStrips catch {destroy $w} @@ -53,6 +54,7 @@ wm title $w "Atc electronic strips using groups" wm iconname $w groupsInAtcStrips set defaultfont [font create -family Helvetica -size 10 -weight bold] +set imagePath [file join $zinc_library demos images] frame $w.buttons pack $w.buttons -side bottom -fill x -pady 2m @@ -89,823 +91,776 @@ zinc $w.zinc -render 1 -width 700 -height 500 -borderwidth 0 -lightangle 130 -ti pack $w.zinc -fill both -expand 1 +set stripGradients {} +set stripFontSet {} -my @stripGradiants; -my %stripFontset; -my %textures; -my $oldfkey; -my ($dx, $dy); - -my $delay = 50; # ms between each animation steps -my $steps = 6; # number of steps for the animation -my %scales; # this hash just memorizes the current x and y scaling ratio +set delay 50; # ms between each animation steps +set steps 6; # number of steps for the animation +# scales() # this hash just memorizes the current x and y scaling ratio # In a real appli, this should be memorized in strip objects #---------------------- # configuration data #---------------------- -my $fnb10 = 'cenapii-digistrips-b10'; -my $fnb10c = 'cenapii-digistrips-b10c'; -my $fnb11 = 'cenapii-digistrips-b11'; -my $fnb12 = 'cenapii-digistrips-b12'; -my $fnb15 = 'cenapii-radar-b15'; -my $fnm20 = 'cenapii-radar-m20'; -my $fne18 = 'cenapii-radar-m18'; - -my @ratio2fontset = ([1.2, 'normal'], - [10, 'large']); - -my %stripstyle = (-gradset => {'idnt' => '#ffffff 0|#ffeedd 30|#e9d1ca 90|#e9a89a/90', - 'back' => '#c1daff|#8aaaff/0', - 'shad' => '#000000:50 0|#000000:50 92|#000000:0 100[200 -100', - 'btn_outside' => '#ffeedd|#8a9acc/0', - 'btn_inside' => '#ffeedd|#8a9acc/180', - 'ch1' => '#8aaaff|#5B76ED/0', - }, - - -fontset => {'normal' => {'callsign' => $fnb15, - 'type1' => $fnb12, - 'type2' => $fnb10, - 'type3' => $fnb10c, - }, - - 'large' => {'callsign' => $fnm20, - 'type1' => $fne18, - 'type2' => $fnb15, - 'type3' => $fnb12, - }, - }, - - -width => 340, - -height => 86, - -shadowcoords => [8, 8, 374, 94], - -shadowcolor => 'shad', - - -strip => {-linewidth => 3, - -linecolor => '#aaccff', - -fillcolor => 'back', - -relief => 'roundraised', - }, - - -buttons => {-coords => [340, 0], - -clipcoords => [0, 0, 90, 83], - -zone => {-coords => [0, 0, 26, 85], - -fillcolor => 'btn_outside', - -linewidth => 0, - }, - - -btns => {'btnup' => {-coords => [0, 0, 26, 43], - -arrow => [14, 2, 24, 40, - 1, 40, 14, 2], - -linewidth => 1, - -linecolor => '#aabadd', - -fillcolor => 'btn_inside', - -label => {-coords => [13, 27], - -text => "+", - -font => $fnm20, - -color => '#ffffff', - -anchor => 'center', - }, - }, - - 'btndn' => {-coords => [0, 43, 26, 86], - -arrow => [14, 83, 24, 43, - 1, 43, 14, 83], - -linewidth => 1, - -linecolor => '#aabadd', - -fillcolor => 'btn_inside', - -label => {-coords => [13, 56], - -text => "-", - -font => $fnm20, - -color => '#ffffff', - -anchor => 'center', - }, - }, - }, - }, - - -clipcoords => [3, 3, 332, 80], - -zones => {'ident' => {-coords => [3, 3, 90, 50], - -atomic => 1, - -priority => 200, - -sensitive => 1, - -tags => "move", - -linewidth => 1, - -filled => 1, - -relief => 'sunken', - -linecolor => '#ffeedd', - -fillcolor => 'idnt', - -fields => {-callsign => {-coords => [10, 18], - -font => 'callsign', - -text => 'EWG361', - -anchor => 'w', - -color => '#000000', - }, - -company => {-coords => [10, 34], - -font => 'type2', - -text => 'Eurowing', - -anchor => 'w', - -color => '#444444', - }, - }, - }, - 'input' => {-coords => [3, 3, 334, 82], - -atomic => 1, - -priority => 100, - -sensitive => 1, - -tags => "scale", - -linewidth => 0, - -filled => 1, - -relief => 'flat', - -linecolor => 'white', - -fillcolor => 'back', #'#afb2cc', - -fields => {-type => {-coords => [100, 18], - -font => 'type1', - -text => 'TYPA', - -anchor => 'w', - -color => '#444444', - }, - -cfmu => {-coords => [200, 18], - -font => 'type1', - -text => '08:26', - -anchor => 'e', - -color => '#444444', - }, - -ptsid => {-coords => [100, 40], - -font => 'type2', - -text => 'NIPOR', - -anchor => 'w', - -color => '#444444', - }, - -confsid => {-coords => [158, 40], - -font => 'type2', - -text => '8G', - -anchor => 'center', - -color => '#444444', - }, - -park => {-coords => [200, 40], - -font => 'type2', - -text => 'G23', - -anchor => 'e', - -color => '#444444', - }, - - -dest => {-coords => [10, 66], - -font => 'type2', - -text => 'DEST', - -anchor => 'w', - -color => '#555555', - }, - -champ1 => {-type => 'rect', - -coords => [45, 56, - 135, 76], - -filled => 1, - -fillcolor => 'ch1', - -linecolor => 'white', - -linewidth => 0, - }, - -bret => {-coords => [200, 66], - -font => 'type2', - -text => 'Bret.', - -anchor => 'e', - -color => '#444444', - }, - }, - }, - - 'zreco' => {-coords => [210, 3, 346, 82], - -atomic => 1, - -priority => 200, - -texture => "stripped_texture.gif", - -sensitive => 1, - -tags => "edit", - -linewidth => 2, - -filled => 1, - -relief => 'sunken', - -linecolor => '#deecff', - -fillcolor => '#d3e5ff', - }, - - - }, - - -zinfo => {-coords => [0, 86], - -rectcoords => [0, 0, 340, 20], - -shadowcoords => [8, 8, 348, 28], - -shadowcolor => 'shad', - -atomic => 1, - -priority => 200, - -sensitive => 1, - -tags => "edit2", - -linewidth => 2, - -linecolor => '#aaccff', - -fillcolor => 'back', - -relief => 'roundraised', - -fields => {-ssr => {-coords => [4, 10], - -font => 'type3', - -text => '7656', - -anchor => 'w', - -color => '#444444', - }, - -pdep => {-coords => [47, 10], - -font => 'type3', - -text => 'G23', - -anchor => 'center', - -color => '#444444', - }, - -qfu => {-coords => [73, 10], - -font => 'type3', - -text => '09R', - -anchor => 'center', - -color => '#444444', - }, - -slabel => {-coords => [105, 10], - -font => 'type3', - -text => 'vit:', - -anchor => 'e', - -color => '#444444', - }, - -speed => {-coords => [106, 10], - -font => 'type3', - -text => '260', - -anchor => 'w', - -color => '#444444', - }, - -pper => {-coords => [142, 10], - -font => 'type3', - -text => 'EPL', - -anchor => 'center', - -color => '#444444', - }, - -rfl => {-coords => [166, 10], - -font => 'type3', - -text => '210', - -anchor => 'center', - -color => '#444444', - }, - -cautra => {-coords => [183, 10], - -font => 'type3', - -text => '8350', - -anchor => 'w', - -color => '#444444', - }, - -nsect => {-coords => [219, 10], - -font => 'type3', - -text => 'MOD', - -anchor => 'w', - -color => '#444444', - }, - -day => {-coords => [297, 10], - -font => 'type3', - -text => '21/05/02', - -anchor => 'e', - -color => '#444444', - }, - -hour => {-coords => [332, 10], - -font => 'type3', - -text => '13:50', - -anchor => 'e', - -color => '#444444', - }, - }, - - }, - ); - - - -#------------------------ -# creation du widget Zinc - - -my ($xn, $yn) = (10, 30); - -# test Strips -for (my $index = 0; $index < 4 ; $index++) { - - &createStrip($index, $xn, $yn, \%stripstyle); - $xn += 50; - $yn += 120; +set ratio2FontSet {{1.2 normal} {10 large}} +set stripStyle { + gradSet { + idnt {=axial 90|#ffffff 0|#ffeedd 30|#e9d1ca 90|#e9a89a} + back {#c1daff|#8aaaff} + shad {=path -40 -40|#000000;50 0|#000000;50 92|#000000;0 100} + btnOutside #ffeedd|#8a9acc + btnInside {=axial 180|#ffeedd|#8a9acc} + ch1 {#8aaaff|#5b76ed} + } + fontSet { + normal { + callsign cenapii-radar-b15 + type1 cenapii-digistrips-b12 + type2 cenapii-digistrips-b10 + type3 cenapii-digistrips-b10c + } + large { + callsign cenapii-radar-m20 + type1 cenapii-radar-m18 + type2 cenapii-radar-b15 + type3 cenapii-digistrips-b12 + } + } + width 340 + height 86 + shadowcoords {8 8 374 94} + shadowcolor shad + strip { + linewidth 3 + linecolor \#aaccff + fillcolor back + relief roundraised + } + buttons { + coords {340 0} + clipcoords {0 0 90 83} + zone { + coords {0 0 26 85} + fillcolor btnOutside + linewidth 0 + } + btns { + btnup { + coords {0 0 26 43} + arrow {14 2 24 40 1 40 14 2} + linewidth 1 + linecolor \#aabadd + fillcolor btnInside + label { + coords {13 27} + text + + font cenapii-radar-m20 + color \#ffffff + anchor center + } + } + btndn { + coords {0 43 26 86} + arrow {14 83 24 43 1 43 14 83} + linewidth 1 + linecolor \#aabadd + fillcolor btnInside + label { + coords {13 56} + text - + font cenapii-radar-m20 + color \#ffffff + anchor center + } + } + } + } + clipcoords {3 3 332 80} + zones { + ident { + coords {3 3 90 50} + atomic 1 + priority 200 + sensitive 1 + tags move + linewidth 1 + filled 1 + relief sunken + linecolor \#ffeedd + fillcolor idnt + fields { + callsign { + coords {10 18} + font callsign + text EWG361 + anchor w + color \#000000 + } + company { + coords {10 34} + font type2 + text Eurowing + anchor w + color \#444444 + } + } + } + input { + coords {3 3 334 82} + atomic 1 + priority 100 + sensitive 1 + tags scale + linewidth 0 + filled 1 + relief flat + linecolor white + fillcolor back # \#afb2cc + fields { + type { + coords {100 18} + font type1 + text TYPA + anchor w + color \#444444 + } + cfmu { + coords {200 18} + font type1 + text 08:26 + anchor e + color \#444444 + } + ptsid { + coords {100 40} + font type2 + text NIPOR + anchor w + color \#444444 + } + confsid { + coords {158 40} + font type2 + text 8G + anchor center + color \#444444 + } + park { + coords {200 40} + font type2 + text G23 + anchor e + color \#444444 + } + dest { + coords {10 66} + font type2 + text DEST + anchor w + color \#555555 + } + champ1 { + type rect + coords {45 56 135 76} + filled 1 + fillcolor ch1 + linecolor white + linewidth 0 + } + bret { + coords {200 66} + font type2 + text Bret. + anchor e + color \#444444 + } + } + } + zreco { + coords {210 3 346 82} + atomic 1 + priority 200 + texture stripped_texture.gif + sensitive 1 + tags edit + linewidth 2 + filled 1 + relief sunken + linecolor \#deecff + fillcolor \#d3e5ff + } + } + zinfo { + coords {0 86} + rectcoords {0 0 340 20} + shadowcoords {8 8 348 28} + shadowcolor shad + atomic 1 + priority 200 + sensitive 1 + tags edit2 + linewidth 2 + linecolor \#aaccff + fillcolor back + relief roundraised + fields { + ssr { + coords {4 10} + font type3 + text 7656 + anchor w + color \#444444 + } + pdep { + coords {47 10} + font type3 + text G23 + anchor center + color \#444444 + } + qfu { + coords {73 10} + font type3 + text 09R + anchor center + color \#444444 + } + slabel { + coords {105 10} + font type3 + text vit: + anchor e + color \#444444 + } + speed { + coords {106 10} + font type3 + text 260 + anchor w + color \#444444 + } + pper { + coords {142 10} + font type3 + text EPL + anchor center + color \#444444 + } + rfl { + coords {166 10} + font type3 + text 210 + anchor center + color \#444444 + } + cautra { + coords {183 10} + font type3 + text 8350 + anchor w + color \#444444 + } + nsect { + coords {219 10} + font type3 + text MOD + anchor w + color \#444444 + } + day { + coords {297 10} + font type3 + text 21/05/02 + anchor e + color \#444444 + } + hour { + coords {332 10} + font type3 + text 13:50 + anchor e + color \#444444 + } + } + + } } -&initBindings('move', 'scale'); - - - - -Tk::MainLoop; +proc TLGetHash {list tag} { + array set temp $list + if { [info exists temp($tag)] } { + return $temp($tag) + } + return "" +} -#----------------------------------------------------------------------- fin de MAIN +proc TLGet {list tag} { + foreach {key val} $list { + if { [string compare $key $tag] == 0 } { +# puts "TLGet found \"$val\" for \"$key\"" + return $val + } + } +# puts "Unknown tag $tag in $list" + return "" +} # Création du Strip -sub createStrip { - my ($index, $x, $y, $style) = @_; - - # initialise les gradiants - unless (@stripGradiants) { - my %gradiants = %{$style->{'-gradset'}}; - my ($name, $gradiant); - while (($name, $gradiant) = each(%gradiants)) { +proc createStrip {index x y style} { + global w stripGradients stripFontSet textures imagePath + + # initialise les gradients + if { [llength $stripGradients] == 0 } { + foreach {name gradient} [TLGet $style gradSet] { # création des gradiants nommés - $zinc->gname($gradiant, $name) unless $zinc->gname($gradiant); + if {! [$w.zinc gname $name]} { + $w.zinc gname $gradient $name + } # the previous test is usefull only # when this script is executed many time in the same process # (it is typically the case in zinc-demos) - - push(@stripGradiants, $name); + lappend stripGradients $name } } - + # initialise les jeux de fontes - unless (%stripFontset) { - %stripFontset = %{$style->{'-fontset'}}; + if { ![llength $stripFontSet] } { + set stripFontSet [TLGet $style fontSet] } - + # création du groupe de base : coords - my $g1 = $zinc->add('group', 1, -priority => 100, -tags => ["base".$index]); - $zinc->coords($g1, [$x, $y]); - + set g1 [$w.zinc add group 1 -priority 100 -tags "base$index"] + $w.zinc coords $g1 [list $x $y] + # group de transfo 1 : scaling (à partir du coin haut droit) - my $g2 = $zinc->add('group', $g1, -tags => ["scaling".$index]); - - + set g2 [$w.zinc add group $g1 -tags "scaling$index"] + #------------------------------------------------------------- # réalisation du strip lui même (papier support + ombre portée #------------------------------------------------------------- # params strip - my $stripw = $style->{'-width'}; - my $striph = $style->{'-height'}; + set stripw [TLGet $style width] + set striph [TLGet $style height] # ombre portée - $zinc->add('rectangle', $g2, - $style->{'-shadowcoords'}, - -filled => 1, - -linewidth => 0, - -fillcolor => $style->{'-shadowcolor'}, - -priority => 10, - -tags => ["shadow".$index], - ); - + $w.zinc add rectangle $g2 [TLGet $style shadowcoords] \ + -filled 1 -linewidth 0 -fillcolor [TLGet $style shadowcolor] \ + -priority 10 -tags "shadow$index" # strip - my $sstyle = $style->{'-strip'}; - my $strip = $zinc->add('rectangle', $g2, - [0, 0, $stripw, $striph], - -filled => 1, - -linewidth => $sstyle->{'-linewidth'}, - -linecolor => $sstyle->{'-linecolor'}, - -fillcolor => $sstyle->{'-fillcolor'}, - -relief => $sstyle->{'-relief'}, - -priority => 20, - -tags => ["strip".$index], - ); - - if ($sstyle->{'-texture'}) { - if (!exists($textures{'-strip'})) { - my $texture = $zinc->Photo($sstyle->{'-texture'}, -file => "$image_path/$sstyle->{'-texture'}"); - $textures{'-strip'} = $texture; + set sstyle [TLGet $style strip] + set strip [$w.zinc add rectangle $g2 [list 0 0 $stripw $striph] -filled 1 \ + -linewidth [TLGet $sstyle linewidth] \ + -linecolor [TLGet $sstyle linecolor] \ + -fillcolor [TLGet $sstyle fillcolor] \ + -relief [TLGet $sstyle relief] \ + -priority 20 -tags "strip$index"] + + set texName [TLGet $sstyle texture] + if { [llength $texName] != 0 } { + if { ! [info exists textures(strip)] } { + set textures(strip) [image create photo -file [file join $imagePath $texName]] } - - $zinc->itemconfigure($strip, -tile => $textures{'-strip'}); + $w.zinc itemconfigure $strip -tile $textures(strip) } #------------------------------------------------- # ajout de la zone des boutons (à droite du strip) #------------------------------------------------- - if ($style->{'-buttons'}) { - my $bstyle = $style->{'-buttons'}; - + set bStyle [TLGet $style buttons] + if { [llength $bStyle] != 0 } { # le groupe de la zone bouton - my $btngroup = $zinc->add('group', $g2, -priority => 40); - $zinc->coords($btngroup, $bstyle->{'-coords'}); + set btnGroup [$w.zinc add group $g2 -priority 40] + $w.zinc coords $btnGroup [TLGet $bStyle coords] # sa zone de clipping - my $btnclip = $zinc->add('rectangle', $btngroup, - $bstyle->{'-clipcoords'}, - -filled => 0, - -visible => 0, - ); + set btnClip [$w.zinc add rectangle $btnGroup [TLGet $bStyle clipcoords] \ + -filled 0 -visible 0] # le clipping du groupe bouton - $zinc->itemconfigure($btngroup, -clip => $btnclip); + $w.zinc itemconfigure $btnGroup -clip $btnClip # zone bouton - $zinc->add('rectangle', $btngroup, - $bstyle->{'-zone'}->{'-coords'}, - -filled => 1, - -linewidth => $bstyle->{'-zone'}->{'-linewidth'}, - -fillcolor => $bstyle->{'-zone'}->{'-fillcolor'}, - -composescale => 0, - -tags => ["content".$index], - ); - - - my %btns = %{$bstyle->{'-btns'}}; - my ($name, $btnstyle); - while (($name, $btnstyle) = each(%btns)) { -# print "bouton $name $btnstyle\n"; - - my $sgroup = $zinc->add('group', $btngroup, - -atomic => 1, - -sensitive => 1, - -composescale => 0, - -tags => [$name.$index, "content".$index], - ); - - $zinc->add('rectangle', $sgroup, - $btnstyle->{'-coords'}, - -filled => 1, - -visible => 0, - -priority => 100, - ); - - $zinc->add('curve', $sgroup, - $btnstyle->{'-arrow'}, - -closed => 1, - -filled => 1, - -linewidth => $btnstyle->{'-linewidth'}, - -linecolor => $btnstyle->{'-linecolor'}, - -fillcolor => $btnstyle->{'-fillcolor'}, - -priority => 50, - ); - - $zinc->add('text', $sgroup, - -position => $btnstyle->{'-label'}->{'-coords'}, - -text => $btnstyle->{'-label'}->{'-text'}, - -font => $btnstyle->{'-label'}->{'-font'}, - -color => $btnstyle->{'-label'}->{'-color'}, - -anchor => $btnstyle->{'-label'}->{'-anchor'}, - -priority => 60, - ); + set bZone [TLGet $bStyle zone] + $w.zinc add rectangle $btnGroup [TLGet $bZone coords] \ + -filled 1 -linewidth [TLGet $bZone linewidth] \ + -fillcolor [TLGet $bZone fillcolor] -composescale 0 \ + -tags "content$index" + + set btns [TLGet $bStyle btns] + foreach {name btnStyle} $btns { +# puts "bouton $name $btnStyle" + + set sGroup [$w.zinc add group $btnGroup -atomic 1 -sensitive 1 \ + -composescale 0 -tags [list "$name$index" "content$index"]] + + $w.zinc add rectangle $sGroup [TLGet $btnStyle coords] \ + -filled 1 -visible 0 -priority 100 + $w.zinc add curve $sGroup [TLGet $btnStyle arrow] \ + -closed 1 -filled 1 -priority 50 \ + -linewidth [TLGet $btnStyle linewidth] \ + -linecolor [TLGet $btnStyle linecolor] \ + -fillcolor [TLGet $btnStyle fillcolor] + set lab [TLGet $btnStyle label] + $w.zinc add text $sGroup -priority 60 \ + -position [TLGet $lab coords] -text [TLGet $lab text] \ + -font [TLGet $lab font] -color [TLGet $lab color] \ + -anchor [TLGet $lab anchor] } # bindings boutons Up et Down du Strip - $zinc->bind('btnup'.$index, '<1>', \&extendedStrip); - $zinc->bind('btndn'.$index, '<1>', \&smallStrip); + $w.zinc bind "btnup$index" <1> extendedStrip + $w.zinc bind "btndn$index" <1> smallStrip } # construction du contenu du strip - &buildContent($index, $g2, 100, $style); + buildContent $index $g2 100 $style # et de la barre d'extension info (extended format) - &buildExtent($index, $g2, $style->{'-zinfo'}); + buildExtent $index $g2 [TLGet $style zinfo] } # Construction des zones internes du Strips -sub buildContent { - my ($index, $parent, $priority, $style) = @_; - +proc buildContent {index parent priority style} { + global w textures stripFontSet imagePath + # group content - my $g3 = $zinc->add('group', $parent, -priority => $priority); + set g3 [$w.zinc add group $parent -priority $priority] # zone de clipping - my $clip = $zinc->add('rectangle', $g3, - $style->{'-clipcoords'}, - -filled => 0, - -visible => 0, - ); + set clip [$w.zinc add rectangle $g3 [TLGet $style clipcoords] \ + -filled 0 -visible 0] # clipping du groupe content - $zinc->itemconfigure($g3, -clip => $clip); + $w.zinc itemconfigure $g3 -clip $clip # création d'un group intermédiaire pour bloquer le scaling - my $g4 = $zinc->add('group', $g3, - -composescale => 0, - -tags => ["content".$index], - ); + set g4 [$w.zinc add group $g3 -composescale 0 -tags "content$index"] # création des zones - my %zones = %{$style->{'-zones'}}; - my ($name, $zonestyle); - while (($name, $zonestyle) = each(%zones)) { + set zones [TLGet $style zones] + foreach {name zoneStyle} $zones { # group de zone - my $gz = $zinc->add('group', $g4); - - if ($zonestyle->{'-atomic'}) { - $zinc->itemconfigure($gz, -atomic => 1, - -sensitive => $zonestyle->{'-sensitive'}, - -priority => $zonestyle->{'-priority'}, - -tags => [$name.$index, $zonestyle->{'-tags'}], - ); + set gz [$w.zinc add group $g4] + + if { [TLGet $zoneStyle atomic] } { + $w.zinc itemconfigure $gz -atomic 1 \ + -sensitive [TLGet $zoneStyle sensitive] \ + -priority [TLGet $zoneStyle priority] \ + -tags [concat "$name$index" [TLGet $zoneStyle tags]] } - my $rectzone = $zinc->add('rectangle', $gz, - $zonestyle->{'-coords'}, - -filled => $zonestyle->{'-filled'}, - -linewidth => $zonestyle->{'-linewidth'}, - -linecolor => $zonestyle->{'-linecolor'}, - -fillcolor => $zonestyle->{'-fillcolor'}, - -relief => $zonestyle->{'-relief'}, - -priority => 10, - -tags => [$name.$index], - ); - - if ($zonestyle->{'-texture'}) { - if (!exists($textures{$name})) { - my $texture = $zinc->Photo($zonestyle->{'-texture'}, -file => "$image_path/$zonestyle->{'-texture'}"); - $textures{$name} = $texture; + set rectZone [$w.zinc add rectangle $gz [TLGet $zoneStyle coords] \ + -filled [TLGet $zoneStyle filled] \ + -linewidth [TLGet $zoneStyle linewidth] \ + -linecolor [TLGet $zoneStyle linecolor] \ + -fillcolor [TLGet $zoneStyle fillcolor] \ + -relief [TLGet $zoneStyle relief] \ + -priority 10 -tags "$name$index"] + + set texName [TLGet $zoneStyle texture] + if { [llength $texName] != 0 } { + if { ! [info exists textures($name)] } { + set textures($name) [image create photo \ + -file [file join $imagePath $texName]] } - - $zinc->itemconfigure($rectzone, -tile => $textures{$name}); + $w.zinc itemconfigure $rectZone -tile $textures($name) } - - my %fields; - %fields = %{$zonestyle->{'-fields'}} if (defined $zonestyle->{'-fields'}) ; - my ($field, $fieldstyle); - my $fontsty = $stripFontset{'normal'}; - while ( ($field, $fieldstyle) = each(%fields) ) { - if ($fieldstyle->{'-type'} and $fieldstyle->{'-type'} eq 'rect') { - $zinc->add('rectangle', $gz, - $fieldstyle->{'-coords'}, - -filled => $fieldstyle->{'-filled'}, - -fillcolor => $fieldstyle->{'-fillcolor'}, - -linewidth => $fieldstyle->{'-linewidth'}, - -linecolor => $fieldstyle->{'-linecolor'}, - -priority => 20, - ); - } else { - - my $font = $fieldstyle->{'-font'}; -# print "buildContent field:$field font:$font\n"; - $zinc->add('text', $gz, - -position => $fieldstyle->{'-coords'}, - -text => $fieldstyle->{'-text'}, - -font => $fontsty->{$font}, - -color => $fieldstyle->{'-color'}, - -anchor => $fieldstyle->{'-anchor'}, - -priority => 30, - -tags => [$font.$index], - ); - } - + set fields [TLGet $zoneStyle fields] + set fontStyle [TLGet $stripFontSet normal] + foreach {field fieldStyle} $fields { + set fsType [TLGet $fieldStyle type] + if { $fsType == "rect" } { + $w.zinc add rectangle $gz [TLGet $fieldStyle coords] \ + -filled [TLGet $fieldStyle filled] \ + -fillcolor [TLGet $fieldStyle fillcolor] \ + -linewidth [TLGet $fieldStyle linewidth] \ + -linecolor [TLGet $fieldStyle linecolor] \ + -priority 20 + } else { + set font [TLGet $fieldStyle font] + # puts "buildContent field:$field font:$font" + $w.zinc add text $gz -position [TLGet $fieldStyle coords] \ + -text [TLGet $fieldStyle text] \ + -font [TLGet $fontStyle $font] \ + -color [TLGet $fieldStyle color] \ + -anchor [TLGet $fieldStyle anchor] \ + -priority 30 -tags "$font$index" + } } - } } # Construction de la barre d'extension info du Strip -sub buildExtent { - my ($index, $parent, $infostyle) = @_; - - # group content - my $extgroup = $zinc->add('group', $parent); - $zinc->coords($extgroup, $infostyle->{'-coords'}); +proc buildExtent {index parent infoStyle} { + global w textures stripFontSet imagePath - $zinc->itemconfigure($extgroup, - -atomic => $infostyle->{'-atomic'}, - -sensitive => $infostyle->{'-sensitive'}, - -priority => $infostyle->{'-priority'}, - -visible => 0, - -tags => ["zinfo".$index, $infostyle->{'-tags'}], - ); + # group content + set extGroup [$w.zinc add group $parent] + $w.zinc coords $extGroup [TLGet $infoStyle coords] + $w.zinc itemconfigure $extGroup -visible 0 \ + -atomic [TLGet $infoStyle atomic] \ + -sensitive [TLGet $infoStyle sensitive] \ + -priority [TLGet $infoStyle priority] \ + -tags [concat "zinfo$index" [TLGet $infoStyle tags]] # ombre portée - $zinc->add('rectangle', $extgroup, - $infostyle->{'-shadowcoords'}, - -filled => 1, - -linewidth => 0, - -fillcolor => $infostyle->{'-shadowcolor'}, - -priority => 10, - -tags => ["shadow".$index], - ); + $w.zinc add rectangle $extGroup [TLGet $infoStyle shadowcoords] \ + -filled 1 -linewidth 0 -priority 10 -tags "shadow$index" \ + -fillcolor [TLGet $infoStyle shadowcolor] - my $rectzone = $zinc->add('rectangle', $extgroup, - $infostyle->{'-rectcoords'}, - -filled => 1, - -linewidth => $infostyle->{'-linewidth'}, - -linecolor => $infostyle->{'-linecolor'}, - -fillcolor => $infostyle->{'-fillcolor'}, - -relief => $infostyle->{'-relief'}, - -priority => 20, - ); - - if ($infostyle->{'-texture'}) { - if (!exists($textures{'-zinfo'})) { - my $texture = $zinc->Photo($infostyle->{'-texture'}, -file => "$image_path/$infostyle->{'-texture'}"); - $textures{'-zinfo'} = $texture; + set rectZone [$w.zinc add rectangle $extGroup [TLGet $infoStyle rectcoords] \ + -filled 1 -priority 20 \ + -linewidth [TLGet $infoStyle linewidth] \ + -linecolor [TLGet $infoStyle linecolor] \ + -fillcolor [TLGet $infoStyle fillcolor] \ + -relief [TLGet $infoStyle relief]] + + set texName [TLGet $infoStyle texture] + if { [llength $texName] != 0 } { + if { ! [info exists textures(zinfo)] } { + set textures(zinfo) [image create photo \ + -file [file join $imagePath $texName]] } - $zinc->itemconfigure($rectzone, -tile => $textures{'-zinfo'}); - + $w.zinc itemconfigure $rectZone -tile $textures(zinfo) } - my %fields = %{$infostyle->{'-fields'}}; - my ($field, $fieldstyle); - my $fontsty = $stripFontset{'normal'}; - while (($field, $fieldstyle) = each(%fields)) { - if ($fieldstyle->{'-type'} and $fieldstyle->{'-type'} eq 'rect') { - $zinc->add('rectangle', $extgroup, - $fieldstyle->{'-coords'}, - -filled => $fieldstyle->{'-filled'}, - -fillcolor => $fieldstyle->{'-fillcolor'}, - -linewidth => $fieldstyle->{'-linewidth'}, - -linecolor => $fieldstyle->{'-linecolor'}, - -priority => 40, - ); + set fields [TLGet $infoStyle fields] + set fontStyle [TLGet $stripFontSet normal] + foreach {field fieldStyle} $fields { + set fsType [TLGet $fieldStyle type] + if { $fsType == "rect" } { + $w.zinc add rectangle $extGroup [TLGet $fieldStyle coords] \ + -filled [TLGet $fieldStyle filled] \ + -fillcolor [TLGet $fieldStyle fillcolor] \ + -linewidth [TLGet $fieldStyle linewidth] \ + -linecolor [TLGet $fieldStyle linecolor] \ + -priority 40 } else { - - my $font = $fieldstyle->{'-font'}; -# print "buildContent field:$field font:$font\n"; - $zinc->add('text', $extgroup, - -position => $fieldstyle->{'-coords'}, - -text => $fieldstyle->{'-text'}, - -font => $fontsty->{$font}, - -color => $fieldstyle->{'-color'}, - -anchor => $fieldstyle->{'-anchor'}, - -priority => 50, - -tags => [$font.$index], - ); - } - + set font [TLGet $fieldStyle font] + # puts "buildContent field:$field font:$font" + $w.zinc add text $extGroup -position [TLGet $fieldStyle coords] \ + -text [TLGet $fieldStyle text] \ + -font [TLGet $fontStyle $font] \ + -color [TLGet $fieldStyle color] \ + -anchor [TLGet $fieldStyle anchor] \ + -priority 50 -tags "$font$index" + } } - } # initialisation des bindings généraux dy Strip -sub initBindings { - my ($movetag, $scaletag) = @_; - - $zinc->bind($movetag, '<1>', \&catchStrip); - $zinc->bind($movetag, '', \&releaseStrip); - $zinc->bind($movetag, '', \&motionStrip); +proc initBindings {moveTag scaleTag} { + global w - $zinc->bind($scaletag, '', \µStrip); + $w.zinc bind $moveTag <1> "catchStrip %x %y" + $w.zinc bind $moveTag releaseStrip + $w.zinc bind $moveTag "motionStrip %x %y" + $w.zinc bind $scaleTag microStrip } # Callback CATCH de début de déplacement du Strip -sub catchStrip { - my $index = substr(($zinc->itemcget('current', -tags))[0], 5); - - my ($x, $y) = $zinc->coords("base".$index); - my $ev = $zinc->XEvent; - ($dx, $dy) = ($x - $ev->x, $y - $ev->y); - - $zinc->itemconfigure("base".$index, -priority => 200); - +proc catchStrip {x y} { + global w dx dy + + set index [string range [lindex [$w.zinc itemcget current -tags] 0] 5 end] + set p [$w.zinc coords "base$index"] + set lx [lindex [lindex $p 0] 0] + set ly [lindex [lindex $p 0] 1] +# foreach {lx ly} $p {} + set dx [expr $lx - $x] + set dy [expr $ly - $y] + + $w.zinc itemconfigure "base$index" -priority 200 } # Callback MOVE de fin de déplacement du Strip -sub motionStrip { - my $index = substr(($zinc->itemcget('current', -tags))[0], 5); - my $ev = $zinc->XEvent; - $zinc->coords("base".$index, [$ev->x + $dx, $ev->y + $dy]); - +proc motionStrip {x y} { + global w dx dy + + set index [string range [lindex [$w.zinc itemcget current -tags] 0] 5 end] + $w.zinc coords "base$index" [list [expr $x + $dx] [expr $y + $dy]] } # Callback RELEASE de fin de déplacement du Strip -sub releaseStrip { - my $index = substr(($zinc->itemcget('current', -tags))[0], 5); - $zinc->itemconfigure("base".$index, -priority => 100); +proc releaseStrip {} { + global w + + set index [string range [lindex [$w.zinc itemcget current -tags] 0] 5 end] + $w.zinc itemconfigure "base$index" -priority 100 } # Zoom Strip : normal format -sub normalStrip { - my $index = substr(($zinc->itemcget('current', -tags))[0], 5); +proc normalStrip {} { + global w - $zinc->itemconfigure("input".$index, -sensitive => 1); + set index [string range [lindex [$w.zinc itemcget current -tags] 0] 5 end] + $w.zinc itemconfigure "input$index" -sensitive 1 - &displayRecoZone($index, 1); - &displayExtentZone($index, 0); - &configButtons($index, \&extendedStrip, \&smallStrip); - &changeStripFormat($index, 1, 1, 0, 1); + displayRecoZone $index 1 + displayExtentZone $index 0 + configButtons $index extendedStrip smallStrip + changeStripFormat $index 1 1 0 1 } # Zoom Strip : small format (lignes 1 et 2) -sub smallStrip { - my $index = substr(($zinc->itemcget('current', -tags))[0], 5); +proc smallStrip {} { + global w + + set index [string range [lindex [$w.zinc itemcget current -tags] 0] 5 end] - &displayRecoZone($index, 0); - &configButtons($index, \&normalStrip, 0); - &changeStripFormat($index, 1, .63, 0, 1); + displayRecoZone $index 0 + configButtons $index normalStrip 0 + changeStripFormat $index 1 0.63 0 1 } # Zoom Strip : micro format (zone ident) -sub microStrip { - my $index = substr(($zinc->itemcget('current', -tags))[0], 5); +proc microStrip {} { + global w + set index [string range [lindex [$w.zinc itemcget current -tags] 0] 5 end] - &configButtons($index, \&normalStrip, 0); - &changeStripFormat($index, .28, .63, 0, 1); + configButtons $index normalStrip 0 + changeStripFormat $index 0.28 0.63 0 1 } # Zoom Strip : extendedFormat -sub extendedStrip { - my $index = substr(($zinc->itemcget('current', -tags))[0],5); - - $zinc->itemconfigure("input".$index, -sensitive => 0); - $zinc->itemconfigure("base".$index, -priority => 150); - &displayRecoZone($index, 0); - &displayExtentZone($index, 1); - &configButtons($index, 0, \&normalStrip); - &changeStripFormat($index, 1.3, 1.3, 1, 1.3); +proc extendedStrip {} { + global w + + set index [string range [lindex [$w.zinc itemcget current -tags] 0] 5 end] + + $w.zinc itemconfigure "input$index" -sensitive 0 + $w.zinc itemconfigure "base$index" -priority 150 + displayRecoZone $index 0 + displayExtentZone $index 1 + configButtons $index 0 normalStrip + changeStripFormat $index 1.3 1.3 1 1.3 } # affiche/masque la zone Reco -sub displayRecoZone { - my ($index, $state) = @_; - my $priority = ($state) ? 200 : 0; - $zinc->itemconfigure("zreco".$index, -priority => $priority); +proc displayRecoZone {index state} { + global w + + set priority [expr $state ? 200 : 0] + $w.zinc itemconfigure "zreco$index" -priority $priority } # affiche/masque la zone Extent -sub displayExtentZone { - my ($index, $state) = @_; +proc displayExtentZone {index state} { + global w - $zinc->itemconfigure("zinfo".$index, - -visible => $state, - -sensitive => $state); + $w.zinc itemconfigure "zinfo$index" -visible $state -sensitive $state } # Configure affichage et callbacks des boutons du Strip -sub configButtons { - my ($index, $funcUp, $funcDown) = @_; +proc configButtons {index funcUp funcDown} { + global w # button Up - $zinc->itemconfigure("btnup".$index, -visible => $funcUp); - $zinc->bind('btnup'.$index, '<1>', $funcUp) if $funcUp; + if { $funcUp != 0 } { + $w.zinc itemconfigure "btnup$index" -visible 1 + $w.zinc bind "btnup$index" <1> $funcUp + } { + $w.zinc itemconfigure "btnup$index" -visible 0 + } # button Down - $zinc->itemconfigure("btndn".$index, -visible => $funcDown); - $zinc->bind('btndn'.$index, '<1>', $funcDown) if $funcDown; - + if { $funcDown != 0 } { + $w.zinc itemconfigure "btndn$index" -visible 1 + $w.zinc bind "btndn$index" <1> $funcDown + } { + $w.zinc itemconfigure "btndn$index" -visible 0 + } } # this function has been hacked to provide the user with an animation # The animation is (too) simple but provide a better feedback than without -sub changeStripFormat { - my ($index, $xratio, $yratio, $composeflag, $fontratio) = @_; +proc changeStripFormat {index xratio yratio composeflag fontratio} { + global w dx dy scales steps delay # réinitialisation du groupe scaling - $zinc->treset("scaling".$index); + $w.zinc treset "scaling$index" # configure le blocage de transformation du format des champs - $zinc->itemconfigure("content".$index, -composescale => $composeflag); + $w.zinc itemconfigure "content$index" -composescale $composeflag # applique le nouveau scaling - $scales{$index} = [1,1] unless defined $scales{$index}; - my ($oldXratio,$oldYratio) = @{$scales{$index}}; - $scales{$index}=[$xratio, $yratio]; - my $dx = ($xratio - $oldXratio) / $steps; - my $dy = ($yratio - $oldYratio) / $steps; - &_resize($index, $delay, $oldXratio+$dx, $oldYratio+$dy, $dx, $dy, $steps); + if { ![info exists scales($index)] } { + set scales($index) {1 1} + } + foreach {oldXratio oldYratio} $scales($index) {} + set scales($index) [list $xratio $yratio] + set dx [expr ($xratio - $oldXratio) / $steps] + set dy [expr ($yratio - $oldYratio) / $steps] + _resize $index $delay [expr $oldXratio+$dx] [expr $oldYratio+$dy] $dx $dy $steps + setFontes $index $yratio } -sub _resize { - my ($index, $delay, $newXratio, $newYratio, $dx, $dy, $steps) = @_; - $zinc->treset("scaling".$index); - $zinc->scale("scaling".$index, $newXratio, $newYratio); +proc _resize {index delay newXratio newYratio dx dy steps} { + global w + + $w.zinc treset "scaling$index" + $w.zinc scale "scaling$index" $newXratio $newYratio # jeu de fontes - &setFontes($index, $newYratio); - $steps--; - $zinc->after($delay, sub {&_resize ($index, $delay, $newXratio+$dx, $newYratio+$dy, $dx, $dy, $steps)}) - if $steps > 0; + incr steps -1 + if { $steps > 0 } { + after $delay [list _resize $index $delay [expr $newXratio+$dx] [expr $newYratio+$dy] $dx $dy $steps] + } +#puts [::profiler::print] } -sub getFKey { - my ($ratio) = @_; - my $newfkey; - - foreach my $param (@ratio2fontset) { - my ($maxratio, $fkey) = @{$param}; - $newfkey = $fkey; - if ($ratio < $maxratio) { - return $newfkey; +proc getFKey {ratio} { + global ratio2FontSet + + foreach param $ratio2FontSet { + foreach {maxRatio fKey} $param {} + set newfKey $fKey + if { $ratio < $maxRatio } { + return $newfKey; } } - - return $newfkey; + + return $newfKey; } -sub setFontes { - my ($index, $ratio) = @_; - my $newfkey = &getFKey($ratio); - - if (!$oldfkey or $oldfkey ne $newfkey) { - my $fontsty = $stripFontset{$newfkey}; -# print "setFontes $oldfkey -> $newfkey\n"; - if ($fontsty) { - foreach my $type ('callsign', 'type1', 'type2', 'type3') { - $zinc->itemconfigure($type.$index, -font => $fontsty->{$type}); +proc setFontes {index ratio} { + global w stripFontSet oldFKey + + set newFKey [getFKey $ratio] + if {![info exists oldFKey] || ([string compare $oldFKey $newFKey] != 0) } { + set fontStyle [TLGet $stripFontSet $newFKey] + #puts "setFontes $oldFKey -> $newFKey" + if { [llength $fontStyle] != 0 } { + foreach type {callsign type1 type2 type3} { + $w.zinc itemconfigure "$type$index" -font [TLGet $fontStyle $type] } } - - $oldfkey = $newfkey; + set oldFKey $newFKey } } + +# test Strips +for {set xn 10; set yn 30; set index 0} {$index < 4} {incr index; incr xn 50; incr yn 120} { + createStrip $index $xn $yn $stripStyle +} + +initBindings move scale -- cgit v1.1