- Timestamp:
- May 21, 2015 4:28:27 AM (9 years ago)
- Location:
- trunk
- Files:
-
- 3 edited
-
. (modified) (1 prop)
-
gui/scripts/balloon.tcl (modified) (7 diffs)
-
gui/scripts/histogram.tcl (modified) (12 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk
- Property svn:mergeinfo changed
/branches/1.3 merged: 5557-5561,5574-5575
- Property svn:mergeinfo changed
-
trunk/gui/scripts/balloon.tcl
r4661 r5592 1 # -*- mode: tcl; indent-tabs-mode: nil -*- 1 # -*- mode: tcl; indent-tabs-mode: nil -*- 2 2 # ---------------------------------------------------------------------- 3 3 # COMPONENT: Balloon - toplevel popup window, like a cartoon balloon … … 47 47 48 48 protected method _createStems {} 49 protected method _place {where placement w h sw sh} 49 50 50 51 protected variable _stems ;# windows for cartoon balloon stems … … 123 124 } 124 125 126 127 # ---------------------------------------------------------------------- 128 # USAGE: _place <where> <place> <pw> <ph> <screenw> <screenh> 129 # 130 # Called by activate. Returns the exact location information given 131 # the parameters. If the window will not fit on the screen with the 132 # requested placement, will loop through all possible placements to 133 # find the best alternative. 134 # ---------------------------------------------------------------------- 135 itcl::body Rappture::Balloon::_place {where place pw ph screenw screenh} { 136 # pw and ph are requested balloon window size 137 138 # set placement preference order 139 switch $place { 140 left {set plist {left above below right}} 141 right {set plist {right above below left}} 142 above {set plist {above below right left}} 143 below {set plist {below above right left}} 144 } 145 146 set ph_orig $ph 147 set pw_orig $pw 148 149 foreach placement $plist { 150 set pw $pw_orig 151 set ph $ph_orig 152 if {[winfo exists $where]} { 153 # location of top-left corner of root window 154 set rx [winfo rootx $where] 155 set ry [winfo rooty $where] 156 157 # size of widget we want to popup over 158 set width [winfo width $where] 159 set height [winfo height $where] 160 161 # x and y will be location for popup 162 set x [expr {$rx + $width/2}] 163 set y [expr {$ry + $height/2}] 164 165 switch -- $placement { 166 left { set x [expr {$rx + 5}] } 167 right { set x [expr {$rx + $width - 5}] } 168 above { set y [expr {$ry + 5}] } 169 below { set y [expr {$ry + $height - 5}] } 170 } 171 } elseif {[regexp {^@([0-9]+),([0-9]+)$} $where match x y]} { 172 # got x and y 173 } else { 174 error "bad location \"$where\": should be widget or @x,y" 175 } 176 177 # compute stem image size 178 set s $_stems($placement) 179 set sw [image width $_fills($placement)] 180 set sh [image height $_fills($placement)] 181 set offscreen 0 182 183 switch -- $placement { 184 left { 185 set sx [expr {$x-$sw+3}] 186 set sy [expr {$y-$sh/2}] 187 set px [expr {$sx-$pw+3}] 188 set py [expr {$y-$ph/2}] 189 190 # make sure that the panel doesn't go off-screen 191 if {$py < 0} { 192 incr offscreen [expr -$py] 193 set py 0 194 } 195 if {$py+$ph > $screenh} { 196 incr offscreen [expr {$py + $ph - $screenh}] 197 set py [expr {$screenh - $ph}] 198 } 199 if {$px < 0} { 200 incr offscreen [expr -$px] 201 set pw [expr {$pw + $px}] 202 set px 0 203 } 204 } 205 right { 206 set sx $x 207 set sy [expr {$y-$sh/2}] 208 set px [expr {$x+$sw-3}] 209 set py [expr {$y-$ph/2}] 210 211 # make sure that the panel doesn't go off-screen 212 if {$py < 0} { 213 incr offscreen [expr -$py] 214 set py 0 215 } 216 if {$py+$ph > $screenh} { 217 incr offscreen [expr {$py + $ph - $screenh}] 218 set py [expr {$screenh-$ph}] 219 } 220 if {$px+$pw > $screenw} { 221 incr offscreen [expr {$px + $pw - $screenw}] 222 set pw [expr {$screenw-$px}] 223 } 224 } 225 above { 226 set sx [expr {$x-$sw/2}] 227 set sy [expr {$y-$sh+3}] 228 set px [expr {$x-$pw/2}] 229 set py [expr {$sy-$ph+3}] 230 231 # make sure that the panel doesn't go off-screen 232 if {$px < 0} { 233 incr offscreen [expr -$px] 234 set px 0 235 } 236 if {$px+$pw > $screenw} { 237 incr offscreen [expr {$px + $pw - $screenw}] 238 set px [expr {$screenw-$pw}] 239 } 240 if {$py < 0} { 241 incr offscreen [expr -$py] 242 set ph [expr {$ph+$py}] 243 set py 0 244 } 245 } 246 below { 247 set sx [expr {$x-$sw/2}] 248 set sy $y 249 set px [expr {$x-$pw/2}] 250 set py [expr {$y+$sh-3}] 251 252 # make sure that the panel doesn't go off-screen 253 if {$px < 0} { 254 incr offscreen [expr -$px] 255 set px 0 256 } 257 if {$px+$pw > $screenw} { 258 incr offscreen [expr {$px + $pw - $screenw}] 259 set px [expr {$screenw-$pw}] 260 } 261 if {$py+$ph > $screenh} { 262 incr offscreen [expr {$py + $py - $screenh}] 263 set ph [expr {$screenh-$py}] 264 } 265 } 266 } 267 set res($placement) [list $placement $offscreen $pw $ph $px $py $sx $sy] 268 if {$offscreen == 0} { 269 return "$placement $pw $ph $px $py $sx $sy" 270 } 271 } 272 273 # In the unlikely event that we arrived here, it is because no 274 # placement allowed the entire balloon window to be displayed. 275 # Loop through the results and return the best-case placement. 276 set _min 10000 277 foreach pl $plist { 278 set offscreen [lindex $res($pl) 1] 279 if {$offscreen < $_min} { 280 set _min $offscreen 281 set _min_pl $pl 282 } 283 } 284 return "$_min_pl [lrange $res($_min_pl) 2 end]" 285 } 286 125 287 # ---------------------------------------------------------------------- 126 288 # USAGE: activate <where> <placement> … … 129 291 # <where> location, which should be a widget name or @X,Y. The 130 292 # <placement> indicates whether the panel should be left, right, 131 # above, or below the <where> coordinate. 293 # above, or below the <where> coordinate. Plecement is considered 294 # a suggestion and may be changed to fit the popup in the screen. 132 295 # ---------------------------------------------------------------------- 133 296 itcl::body Rappture::Balloon::activate {where placement} { … … 135 298 error "bad placement \"$placement\": should be [join [lsort [array names _stems]] {, }]" 136 299 } 137 set s $_stems($placement) 138 set sw [image width $_fills($placement)] 139 set sh [image height $_fills($placement)] 300 301 # if the panel is already up, take it down 302 deactivate 303 140 304 set p $itk_component(hull) 141 305 set screenw [winfo screenwidth $p] 142 306 set screenh [winfo screenheight $p] 143 144 if {[winfo exists $where]} {145 set x [expr {[winfo rootx $where]+[winfo width $where]/2}]146 set y [expr {[winfo rooty $where]+[winfo height $where]/2}]147 switch -- $placement {148 left { set x [expr {[winfo rootx $where]+5}] }149 right { set x [expr {[winfo rootx $where]+[winfo width $where]-5}] }150 above { set y [expr {[winfo rooty $where]+5}] }151 below { set y [expr {[winfo rooty $where]+[winfo height $where]-5}] }152 }153 } elseif {[regexp {^@([0-9]+),([0-9]+)$} $where match x y]} {154 # got x and y155 } else {156 error "bad location \"$where\": should be widget or @x,y"157 }158 159 # if the panel is already up, take it down160 deactivate161 307 162 308 set pw [winfo reqwidth $p] … … 165 311 if {$ph > $screenh} { set ph [expr {$screenh-10}] } 166 312 167 switch -- $placement { 168 left { 169 set sx [expr {$x-$sw+3}] 170 set sy [expr {$y-$sh/2}] 171 set px [expr {$sx-$pw+3}] 172 set py [expr {$y-$ph/2}] 173 174 # make sure that the panel doesn't go off-screen 175 if {$py < 0} { set py 0 } 176 if {$py+$ph > $screenh} { set py [expr {$screenh-$ph}] } 177 if {$px < 0} { set pw [expr {$pw+$px}]; set px 0 } 178 } 179 right { 180 set sx $x 181 set sy [expr {$y-$sh/2}] 182 set px [expr {$x+$sw-3}] 183 set py [expr {$y-$ph/2}] 184 185 # make sure that the panel doesn't go off-screen 186 if {$py < 0} { set py 0 } 187 if {$py+$ph > $screenh} { set py [expr {$screenh-$ph}] } 188 if {$px+$pw > $screenw} { set pw [expr {$screenw-$px}] } 189 } 190 above { 191 set sx [expr {$x-$sw/2}] 192 set sy [expr {$y-$sh+3}] 193 set px [expr {$x-$pw/2}] 194 set py [expr {$sy-$ph+3}] 195 196 # make sure that the panel doesn't go off-screen 197 if {$px < 0} { set px 0 } 198 if {$px+$pw > $screenw} { set px [expr {$screenw-$pw}] } 199 if {$py < 0} { set ph [expr {$ph+$py}]; set py 0 } 200 } 201 below { 202 set sx [expr {$x-$sw/2}] 203 set sy $y 204 set px [expr {$x-$pw/2}] 205 set py [expr {$y+$sh-3}] 206 207 # make sure that the panel doesn't go off-screen 208 if {$px < 0} { set px 0 } 209 if {$px+$pw > $screenw} { set px [expr {$screenw-$pw}] } 210 if {$py+$ph > $screenh} { set ph [expr {$screenh-$py}] } 211 } 212 } 213 if {[info exists _masks($placement)]} { 214 shape set $s -bound photo $_masks($placement) 215 } 313 foreach {place pw ph px py sx sy} [_place $where $placement $pw $ph $screenw $screenh] break 314 315 set s $_stems($place) 316 if {[info exists _masks($place)]} { 317 shape set $s -bound photo $_masks($place) 318 } 319 216 320 if { $pw < 1 || $ph < 1 } { 217 321 # I really don't know why this is happenning. I believe this occurs … … 308 412 # 309 413 # -------- --- LEFT STEM 310 # |..## | ^ 414 # |..## | ^ 311 415 # | ..## | | . = light color 312 416 # | ..##| | s @ = dark color -
trunk/gui/scripts/histogram.tcl
r3330 r5592 1 # -*- mode: tcl; indent-tabs-mode: nil -*- 2 1 # -*- mode: tcl; indent-tabs-mode: nil -*- 2 3 3 # ---------------------------------------------------------------------- 4 4 # COMPONENT: histogram - extracts data from an XML description of a field … … 37 37 protected method Build {} 38 38 private method Clear { {comp ""} } 39 private method ParseData { comp } 39 private method ParseData { comp } 40 40 41 41 private variable _xmlobj "" ;# ref to lib obj with histogram data 42 42 private variable _hist "" ;# lib obj representing this histogram 43 private variable _widths ;# array of vectors of bin widths 44 private variable _yvalues ;# array of vectors of bin heights along 43 private variable _widths ;# array of vectors of bin widths 44 private variable _yvalues ;# array of vectors of bin heights along 45 45 ;# y-axis. 46 private variable _xvalues ;# array of vectors of bin locations along 46 private variable _xvalues ;# array of vectors of bin locations along 47 47 ;# x-axis. 48 48 private variable _xlabels ;# array of labels … … 74 74 # don't destroy the _xmlobj! we don't own it! 75 75 itcl::delete object $_hist 76 Clear 77 } 78 79 # ---------------------------------------------------------------------- 80 # USAGE: mesh 76 Clear 77 } 78 79 # ---------------------------------------------------------------------- 80 # USAGE: mesh 81 81 # 82 82 # Returns the vector for the histogram bin locations along the … … 91 91 92 92 # ---------------------------------------------------------------------- 93 # USAGE: heights 93 # USAGE: heights 94 94 # 95 95 # Returns the vector for the histogram bin heights along the y-axis. … … 103 103 104 104 # ---------------------------------------------------------------------- 105 # USAGE: widths 105 # USAGE: widths 106 106 # 107 107 # Returns the vector for the specified histogram component <name>. … … 117 117 118 118 # ---------------------------------------------------------------------- 119 # USAGE: xlabels 119 # USAGE: xlabels 120 120 # 121 121 # Returns the vector for the specified histogram component <name>. … … 188 188 } 189 189 190 blt::vector create tmp 190 blt::vector create tmp 191 191 blt::vector create zero 192 192 foreach comp [array names _comphist] { … … 257 257 xdesc xaxis.description 258 258 xunits xaxis.units 259 xorient xaxis.orientation 259 xorient xaxis.orientation 260 260 xscale xaxis.scale 261 261 xmin xaxis.min … … 342 342 # Parse the components data representations. The following 343 343 # elements may be used <xy>, <xhw>, <namevalue>, <xvector>, 344 # <yvector>. Only one element is used for data. 344 # <yvector>. Only one element is used for data. 345 345 # 346 346 itcl::body Rappture::Histogram::ParseData { comp } { … … 354 354 if { $xydata != "" } { 355 355 set count 0 356 foreach line [split $xydata \n] { 357 if {[llength $line] == 2} { 358 foreach {name value} $line break 359 $_yvalues($comp) append $value 360 $_xvalues($comp) append $count 361 lappend _xlabels($comp) $name 362 incr count 363 } 364 } 356 foreach {name value} [regsub -all "\[ \t\n]+" $xydata { }] { 357 $_yvalues($comp) append $value 358 $_xvalues($comp) append $count 359 lappend _xlabels($comp) $name 360 incr count 361 } 365 362 set _comp2hist($comp) [list $_xvalues($comp) $_yvalues($comp)] 366 363 return … … 369 366 if { $xhwdata != "" } { 370 367 set count 0 371 foreach line [split $xhwdata \n] { 372 set n [scan $line {%s %s %s} name h w] 373 if {$n >= 2} { 374 lappend _xlabels($comp) $name 375 $_xvalues($comp) append $count 376 $_yvalues($comp) append $h 377 if { $n == 3 } { 378 $_widths($comp) append $w 379 } 380 incr count 381 } 382 } 368 foreach {name h w} [regsub -all "\[ \t\n]+" $xhwdata { }] { 369 lappend _xlabels($comp) $name 370 $_xvalues($comp) append $count 371 $_yvalues($comp) append $h 372 $_widths($comp) append $w 373 incr count 374 } 383 375 set _comp2hist($comp) [list $_xvalues($comp) $_yvalues($comp)] 384 376 return 385 386 # FIXME: There must be a width specified for each bin location. 387 # If this isn't true, we default to uniform widths 388 # (zero-length _widths vector == uniform). 389 if { [$_xvalues($comp) length] != [$_widths($comp) length] } { 390 $_widths($comp) set {} 391 } 392 set _comp2hist($comp) [list $_xvalues($comp) $_yvalues($comp)] 393 return 394 } 395 set xv [$_hist get $comp.xvector] 396 set yv [$_hist get $comp.yvector] 397 if { $xv != "" && $yv != "" } { 398 $_yvalues($comp) set $yv 399 $_xvalues($comp) seq 0 [$yv length] 400 set _xlabels($comp) 401 } 377 } 378 379 # If we reached here, must be <yvector> 380 $_yvalues($comp) set [$_hist get ${comp}.yvector] 381 $_xvalues($comp) length [$_yvalues($comp) length] 382 $_xvalues($comp) seq 1 [$_yvalues($comp) length] 383 set _xlabels($comp) [$_hist get ${comp}.xvector] 402 384 set _comp2hist($comp) [list $_xvalues($comp) $_yvalues($comp)] 403 385 } … … 422 404 } 423 405 if { [info exists _widths($comp)] } { 424 blt::vector destroy $_widths($comp) 406 blt::vector destroy $_widths($comp) 425 407 } 426 408 if { [info exists _yvalues($comp)] } { 427 blt::vector destroy $_yvalues($comp) 409 blt::vector destroy $_yvalues($comp) 428 410 } 429 411 if { [info exists _xvalues($comp)] } { 430 blt::vector destroy $_xvalues($comp) 412 blt::vector destroy $_xvalues($comp) 431 413 } 432 414 array unset _xvalues $comp
Note: See TracChangeset
for help on using the changeset viewer.
