Statistics
| Branch: | Revision:

root / src / tkenv / modinsp2.tcl @ e1750c09

History | View | Annotate | Download (53 KB)

1 01873262 Georg Kunz
#=================================================================
2
#  MODINSP2.TCL - part of
3
#
4
#                     OMNeT++/OMNEST
5
#            Discrete System Simulation in C++
6
#
7
#=================================================================
8
9
#----------------------------------------------------------------#
10
#  Copyright (C) 1992-2008 Andras Varga
11
#
12
#  This file is distributed WITHOUT ANY WARRANTY. See the file
13
#  `license' for details on this and other legal matters.
14
#----------------------------------------------------------------#
15
16
#-----------------------------------------------------------------
17
#  Graphical compound module window stuff
18
#-----------------------------------------------------------------
19
20
#
21
# Note: tooltips on canvas come from the proc whose name is stored in
22
# $help_tips(helptip_proc). This is currently get_help_tip.
23
#
24
25
26
proc lookup_image {imgname {imgsize ""}} {
27
    global bitmaps icons
28
29
    if {[catch {set img $bitmaps($imgname,$imgsize)}] && \
30
        [catch {set img $bitmaps($imgname)}] && \
31
        [catch {set img $bitmaps(old/$imgname,$imgsize)}] && \
32
        [catch {set img $bitmaps(old/$imgname)}]} {
33
       set img $icons(unknown)
34
    }
35
36
    return $img
37
}
38
39
40
#
41
# helper function
42
#
43
proc dispstr_getimage {tags_i tags_is zoomfactor imagesizefactor} {
44
    global icons bitmaps imagecache
45
46
    set zoomfactor [expr $zoomfactor * $imagesizefactor]
47
    set iconminsize [opp_getsimoption iconminsize]
48
49
    set key "[join $tags_i ,]:[join $tags_is ,]:$zoomfactor:$iconminsize"
50
    if {![info exist imagecache($key)]} {
51
        # look up base image
52
        set imgsize [lindex $tags_is 0]
53
        if {$imgsize==""} {set imgsize "n"}
54
        set imgname [lindex $tags_i 0]
55
        if {$imgname=="" || ([catch {set img $bitmaps($imgname,$imgsize)}] && \
56
                             [catch {set img $bitmaps($imgname)}] && \
57
                             [catch {set img $bitmaps(old/$imgname,$imgsize)}] && \
58
                             [catch {set img $bitmaps(old/$imgname)}])} {
59
            set img $icons(unknown)
60
        }
61
        if {[catch {image type $img}]} {
62
            error "internal error: image referred to in bitmaps() doesn't exist"
63
        }
64
65
        # colorize if needed
66
        if {[llength $tags_i]>1} {
67
            # check destcolor and weight for icon colorizing
68
            # if destcolor=="", don't colorize at all
69
            set destc [lindex $tags_i 1]
70
            set cweight [lindex $tags_i 2]
71
            if {$destc!=""} {
72
                if {[string index $destc 0]== "@"} {set destc [opp_hsb_to_rgb $destc]}
73
                if {$cweight==""} {set cweight 30}
74
75
                set img2 [image create photo]
76
                $img2 copy $img
77
                opp_colorizeimage $img2 $destc $cweight
78
                set img $img2
79
            }
80
        }
81
82
        # rescale if needed
83
        if {$zoomfactor!=1} {
84
            set isx [image width $img]
85
            set isy [image height $img]
86
87
            # iconminsize should not cause icon to grow above its original size
88
            if {$isx < $iconminsize } { set iconminsize $isx}
89
            if {$isy < $iconminsize } { set iconminsize $isy}
90
91
            # modify zoomfactor so that both width/height > iconwidthsize, and aspect ratio is kept
92
            if {$zoomfactor * $isx < $iconminsize} {
93
                set zoomfactor [expr $iconminsize / double($isx)]
94
            }
95
            if {$zoomfactor * $isy < $iconminsize} {
96
                set zoomfactor [expr $iconminsize / double($isy)]
97
            }
98
99
            set newisx [expr int($zoomfactor * $isx)]
100
            set newisy [expr int($zoomfactor * $isy)]
101
            if {$newisx < 1} {set newisx 1}
102
            if {$newisy < 1} {set newisy 1}
103
            if {$newisx>500 || $newisy>500} {
104
                set img $icons(imagetoobig)
105
            } else {
106
                set img [resizeimage $img $newisx $newisy]
107
            }
108
        }
109
110
        set imagecache($key) $img
111
    }
112
    return $imagecache($key)
113
}
114
115
#
116
# helper function
117
#
118
proc get_submod_coords {c tag} {
119
120
   set id [$c find withtag $tag]
121
   if {$id==""} {error "$tag not found"}
122
   return [$c bbox $tag]  ;#-- this could be faster, but somehow doesn't work properly with senddirect animation
123
124
   if {[$c type $id]=="image"} {
125
       set pos [$c coords $id]
126
       set x [lindex $pos 0]
127
       set y [lindex $pos 1]
128
       set img [$c itemcget $id -image]
129
       set hwidth  [expr [image width $img] / 2]
130
       set hheight [expr [image height $img] / 2]
131
132
       set coords "[expr $x-$hwidth] [expr $y-$hheight] \
133
                       [expr $x+$hwidth] [expr $y+$hheight]"
134
   } else {
135
       set coords [$c coords $id]
136
   }
137
   return $coords
138
}
139
140
141
# draw_submod --
142
#
143
# This function is invoked from the module inspector C++ code.
144
#
145
proc draw_submod {c submodptr x y name dispstr scaling} {
146
   #puts "DEBUG: draw_submod $c $submodptr $x $y $name $dispstr $scaling"
147
   global icons inspectordata
148
149
   set zoomfactor $inspectordata($c:zoomfactor)
150
   if {$scaling!="" || $zoomfactor!=1} {
151
       if {$scaling==""} {set scaling 1.0}
152
       set scaling [expr $scaling*$zoomfactor]
153
   }
154
155
   set imagesizefactor $inspectordata($c:imagesizefactor)
156
157
   if [catch {
158
       opp_displaystring $dispstr parse tags $submodptr 1
159
160
       # scale (x,y)
161
       if {$scaling != ""} {
162
           set x [expr $scaling*$x]
163
           set y [expr $scaling*$y]
164
       }
165
166
       # set sx and sy (and look up image)
167
       set isx 0
168
       set isy 0
169
       set bsx 0
170
       set bsy 0
171
       if ![info exists tags(is)] {
172
           set tags(is) {}
173
       }
174
       if [info exists tags(i)] {
175
           set img [dispstr_getimage $tags(i) $tags(is) $zoomfactor $imagesizefactor]
176
           set isx [image width $img]
177
           set isy [image height $img]
178
       }
179
       if [info exists tags(b)] {
180
           set bsx [lindex $tags(b) 0]
181
           set bsy [lindex $tags(b) 1]
182
           if {$bsx=="" && $bsy==""} {
183
               set bsx 40
184
               set bsy 24
185
           }
186
           if {$bsx==""} {set bsx $bsy}
187
           if {$bsy==""} {set bsy $bsx}
188
           if {$scaling != ""} {
189
               set bsx [expr $scaling*$bsx]
190
               set bsy [expr $scaling*$bsy]
191
           }
192
       } elseif ![info exists tags(i)] {
193
           set img $icons(defaulticon)
194
           set isx [image width $img]
195
           set isy [image height $img]
196
       }
197
198
       set sx [expr {$isx<$bsx ? $bsx : $isx}]
199
       set sy [expr {$isy<$bsy ? $bsy : $isy}]
200
201
       if [info exists tags(b)] {
202
203
           set width [lindex $tags(b) 5]
204
           if {$width == ""} {set width 2}
205
206
           set x1 [expr $x - $bsx/2 + $width/2]
207
           set y1 [expr $y - $bsy/2 + $width/2]
208
           set x2 [expr $x + $bsx/2 - $width/2]
209
           set y2 [expr $y + $bsy/2 - $width/2]
210
211
           set sh [lindex $tags(b) 2]
212
           if {$sh == ""} {set sh rect}
213
214
           set fill [lindex $tags(b) 3]
215
           if {$fill == ""} {set fill #8080ff}
216
           if {$fill == "-"} {set fill ""}
217
           if {[string index $fill 0]== "@"} {set fill [opp_hsb_to_rgb $fill]}
218
           set outline [lindex $tags(b) 4]
219
           if {$outline == ""} {set outline black}
220
           if {$outline == "-"} {set outline ""}
221
           if {[string index $outline 0]== "@"} {set outline [opp_hsb_to_rgb $outline]}
222
223
           $c create $sh $x1 $y1 $x2 $y2 \
224
               -fill $fill -width $width -outline $outline \
225
               -tags "dx tooltip submod $submodptr"
226
227
           if [info exists tags(i)] {
228
               $c create image $x $y -image $img -anchor center -tags "dx tooltip submod $submodptr"
229
           }
230
           if {$inspectordata($c:showlabels)} {
231
               $c create text $x [expr $y2+$width/2+3] -text $name -anchor n -tags "dx"
232
           }
233
234
       } else {
235
           # draw an icon when no shape is present (only i tag, or neither i nor b tag)
236
           $c create image $x $y -image $img -anchor center -tags "dx tooltip submod $submodptr"
237
           if {$inspectordata($c:showlabels)} {
238
               $c create text $x [expr $y+$sy/2+3] -text $name -anchor n -tags "dx"
239
           }
240
       }
241
242
       # queue length
243
       if {[info exists tags(q)]} {
244
           set r [get_submod_coords $c $submodptr]
245
           set qx [expr [lindex $r 2]+1]
246
           set qy [lindex $r 1]
247
           $c create text $qx $qy -text "q:?" -anchor nw -tags "dx tooltip qlen qlen-$submodptr"
248
       }
249
250
       # modifier icon (i2 tag)
251
       if {[info exists tags(i2)]} {
252
           if ![info exists tags(is2)] {
253
               set tags(is2) {}
254
           }
255
           set r [get_submod_coords $c $submodptr]
256
           set mx [expr [lindex $r 2]+2]
257
           set my [expr [lindex $r 1]-2]
258
           set img2 [dispstr_getimage $tags(i2) $tags(is2) $zoomfactor $imagesizefactor]
259
           $c create image $mx $my -image $img2 -anchor ne -tags "dx tooltip submod $submodptr"
260
       }
261
262
       # text (t=<text>,<position>,<color>); multiple t tags supported (t1,t2,etc)
263
       foreach {ttag} [array names tags -regexp {^t\d*$} ] {
264
           set txt [lindex $tags($ttag) 0]
265
           set pos [lindex $tags($ttag) 1]
266
           if {$pos == ""} {set pos "t"}
267
           set color [lindex $tags($ttag) 2]
268
           if {$color == ""} {set color "#0000ff"}
269
           if {[string index $color 0]== "@"} {set color [opp_hsb_to_rgb $color]}
270
271
           set r [get_submod_coords $c $submodptr]
272
           if {$pos=="l"} {
273
               set tx [lindex $r 0]
274
               set ty [lindex $r 1]
275
               set anch "ne"
276
               set just "right"
277
           } elseif {$pos=="r"} {
278
               set tx [lindex $r 2]
279
               set ty [lindex $r 1]
280
               set anch "nw"
281
               set just "left"
282
           } elseif {$pos=="t"} {
283
               set tx [expr ([lindex $r 0]+[lindex $r 2])/2]
284
               set ty [expr [lindex $r 1]+2]
285
               set anch "s"
286
               set just "center"
287
           } else {
288
               error "wrong position in t= tag, should be `l', `r' or `t'"
289
           }
290
           $c create text $tx $ty -text $txt -fill $color -anchor $anch -justify $just -tags "dx"
291
       }
292
293
       # r=<radius>,<fillcolor>,<color>,<width>; multiple r tags supported (r1,r2,etc)
294
       foreach {rtag} [array names tags -regexp {^r\d*$} ] {
295
           set radius [lindex $tags($rtag) 0]
296
           if {$radius == ""} {set radius 0}
297
           set rfill [lindex $tags($rtag) 1]
298
           if {$rfill == "-"} {set rfill ""}
299
           if {[string index $rfill 0]== "@"} {set rfill [opp_hsb_to_rgb $rfill]}
300
           # if rfill=="" --> not filled
301
           set routline [lindex $tags($rtag) 2]
302
           if {$routline == ""} {set routline black}
303
           if {$routline == "-"} {set routline ""}
304
           if {[string index $routline 0]== "@"} {set routline [opp_hsb_to_rgb $routline]}
305
           set rwidth [lindex $tags($rtag) 3]
306
           if {$rwidth == ""} {set rwidth 1}
307
           if {$scaling != ""} {
308
               set radius [expr $scaling*$radius]
309
           }
310
           set radius [expr $radius-$rwidth/2]
311
312
           set x1 [expr $x - $radius]
313
           set y1 [expr $y - $radius]
314
           set x2 [expr $x + $radius]
315
           set y2 [expr $y + $radius]
316
317
           set circle [$c create oval $x1 $y1 $x2 $y2 \
318
               -fill $rfill -width $rwidth -outline $routline -tags "dx range"]
319
           # has been moved to the beginning of draw_enclosingmod to maintain relative z order of range indicators
320
           # $c lower $circle
321
       }
322
323
   } errmsg] {
324
       tk_messageBox -type ok -title Error -icon error -parent [winfo toplevel [focus]] \
325
                     -message "Error in display string of $name: $errmsg"
326
   }
327
}
328
329
330
# draw_enclosingmod --
331
#
332
# This function is invoked from the module inspector C++ code.
333
#
334
proc draw_enclosingmod {c ptr name dispstr scaling} {
335
   global icons bitmaps inspectordata
336
   # puts "DEBUG: draw_enclosingmod $c $ptr $name $dispstr $scaling"
337
338
   set zoomfactor $inspectordata($c:zoomfactor)
339
   if {$scaling!="" || $zoomfactor!=1} {
340
       if {$scaling==""} {set scaling 1.0}
341
       set scaling [expr $scaling*$zoomfactor]
342
   }
343
344
   if [catch {
345
346
       # lower all range indicators below the icons
347
       $c lower "range"
348
349
       # parse display string. note: we need "1" as last parameter (search
350
       # for $params in parent module too), because all tags get resolved
351
       # not only bg* ones.
352
       opp_displaystring $dispstr parse tags $ptr 1
353
354
       # determine top-left origin (bgp tag; currently not supported)
355
       #if {![info exists tags(bgp)]} {set tags(bgp) {}}
356
       #set bx [lindex $tags(bgp) 0]
357
       #set by [lindex $tags(bgp) 1]
358
       #if {$bx==""} {set bx 0}
359
       #if {$by==""} {set by 0}
360
       #if {$scaling != ""} {
361
       #    set bx [expr $scaling*$bx]
362
       #    set by [expr $scaling*$by]
363
       #}
364
       set bx 0
365
       set by 0
366
367
       # determine size
368
       if {![info exists tags(bgb)]} {set tags(bgb) {{} {} {}}}
369
       set sx [lindex $tags(bgb) 0]
370
       set sy [lindex $tags(bgb) 1]
371
       if {$scaling != ""} {
372
           if {$sx!=""} {set sx [expr $scaling*$sx]}
373
           if {$sy!=""} {set sy [expr $scaling*$sy]}
374
       }
375
376
       if {$sx=="" || $sy==""} {
377
           set bb [$c bbox submod]
378
           if {$bb==""} {
379
               if {$scaling==""} {
380
                   set bb [list $bx $by 300 200]
381
               } else {
382
                   set bb [list $bx $by [expr $scaling*300] [expr $scaling*200]]
383
               }
384
           }
385
           if {$sx==""} {set sx [expr [lindex $bb 2]+[lindex $bb 0]-2*$bx]}
386
           if {$sy==""} {set sy [expr [lindex $bb 3]+[lindex $bb 1]-2*$by]}
387
       }
388
389
       # determine colors and line width
390
       set fill [lindex $tags(bgb) 2]
391
       if {$fill == ""} {set fill grey82}
392
       if {$fill == "-"} {set fill ""}
393
       if {[string index $fill 0]== "@"} {set fill [opp_hsb_to_rgb $fill]}
394
       set outline [lindex $tags(bgb) 3]
395
       if {$outline == ""} {set outline black}
396
       if {$outline == "-"} {set outline ""}
397
       if {[string index $outline 0]== "@"} {set outline [opp_hsb_to_rgb $outline]}
398
       set width [lindex $tags(bgb) 4]
399
       if {$width == ""} {set width 2}
400
401
       # draw (note: width should grow *outside* the $sx-by-$sy inner rectangle)
402
       $c create rect [expr $bx-$width/2] [expr $by-$width/2] [expr $bx+$sx+$width/2] [expr $by+$sy+$width/2] \
403
           -fill $fill -width $width -outline $outline \
404
           -tags "dx mod $ptr"
405
       $c create text [expr $bx+3] [expr $by+3] -text $name -anchor nw -tags "dx tooltip modname $ptr"
406
407
       # background image
408
       if {![info exists tags(bgi)]} {set tags(bgi) {}}
409
       set imgname [lindex $tags(bgi) 0]
410
       set imgmode [lindex $tags(bgi) 1]
411
       if {$imgname!=""} {
412
          if {[catch {set img $bitmaps($imgname)}] && \
413
              [catch {set img $bitmaps(old/$imgname)}]} {
414
              set img $icons(unknown)
415
          }
416
          set isx [expr [image width $img]*$zoomfactor]
417
          set isy [expr [image height $img]*$zoomfactor]
418
          set imgx $bx
419
          set imgy $by
420
          set anchor nw
421
          if {[string index $imgmode 0]== "c"} {
422
              # image centered
423
              set imgx [expr $bx+$sx/2]
424
              set imgy [expr $by+$sy/2]
425
              set anchor center
426
              if {$sx < $isx || $sy < $isy} {
427
                 # image must be clipped. a new image created with new dimensions
428
                 if {$sx < $isx} {set minx $sx} else {set minx $isx}
429
                 if {$sy < $isy} {set miny $sy} else {set miny $isy}
430
                 set img [get_cached_image $img $zoomfactor [expr ($isx-$minx)/2] [expr ($isy-$miny)/2] [expr ($isx+$minx)/2] [expr ($isy+$miny)/2] $minx $miny 0]
431
              }
432
          } elseif {[string index $imgmode 0]== "s"} {
433
              # image stretched to fill the background area
434
              set img [get_cached_image $img $zoomfactor 0 0 $isx $isy $sx $sy 1]
435
          } elseif {[string index $imgmode 0]== "t"} {
436
              # image "tile" mode
437
              set img [get_cached_image $img $zoomfactor 0 0 $isx $isy $sx $sy 0]
438
          } else {
439
              # default mode: image top-left corner gets aligned to background top-left corner
440
              if {$sx < $isx || $sy < $isy || $zoomfactor != 1} {
441
                 # image must be cropped
442
                 if {$sx < $isx} {set minx $sx} else {set minx $isx}
443
                 if {$sy < $isy} {set miny $sy} else {set miny $isy}
444
                 set img [get_cached_image $img $zoomfactor 0 0 $minx $miny $minx $miny 0]
445
              }
446
          }
447
          $c create image $imgx $imgy -image $img -anchor $anchor -tags "dx mod $ptr"
448
       }
449
450
       # grid display
451
       if {![info exists tags(bgg)]} {set tags(bgg) {}}
452
       set gdist [lindex $tags(bgg) 0]
453
       set gminor [lindex $tags(bgg) 1]
454
       set gcolor [lindex $tags(bgg) 2]
455
       if {$gcolor == ""} {set gcolor grey}
456
       if {$gcolor == "-"} {set gcolor ""}
457
       if {[string index $gcolor 0]== "@"} {set gcolor [opp_hsb_to_rgb $gcolor]}
458
       if {$gdist!=""} {
459
           if {$scaling != ""} {
460
               set gdist [expr $scaling*$gdist]
461
           }
462
           if {$gminor=="" || $gminor < 1} {set gminor 1}
463
           for {set x $bx} {$x < $bx+$sx} {set x [expr $x+$gdist]} {
464
               set coords [list $x $by $x [expr $by+$sy]]
465
               $c create line $coords -width 1 -fill $gcolor -tags "dx mod $ptr"
466
               # create minor ticks
467
               set i 1
468
               for {set minorx [expr int($x+$gdist/$gminor)]} {$i < $gminor && $minorx < $bx+$sx} {
469
                                             set i [expr $i+1]} {
470
                   set minorx [expr int($x+$i*$gdist/$gminor)]
471
                   if {$minorx < $bx+$sx} {
472
                       set coords [list $minorx $by $minorx [expr $by+$sy]]
473
                       $c create line $coords -width 1 -dash . -fill $gcolor -tags "dx mod $ptr"
474
                   }
475
               }
476
           }
477
           for {set y $by} {$y < $by+$sy} {set y [expr $y+$gdist]} {
478
               set coords [list $bx $y [expr $bx+$sx] $y]
479
               $c create line $coords -width 1 -fill $gcolor -tags "dx mod $ptr"
480
               # create minor ticks
481
               set i 1
482
               for {set minory [expr int($y+$gdist/$gminor)]} {$i < $gminor && $minory < $by+$sy} {
483
                                             set i [expr $i+1]} {
484
                   set minory [expr int($y+$i*$gdist/$gminor)]
485
                   if {$minory < $by+$sy} {
486
                       set coords [list $bx $minory [expr $bx+$sx] $minory]
487
                       $c create line $coords -width 1 -dash . -fill $gcolor -tags "dx mod $ptr"
488
                   }
489
               }
490
           }
491
       }
492
493
       # text: bgt=<x>,<y>,<text>,<color>; multiple bgt tags supported (bgt1,bgt2,etc)
494
       foreach {bgttag} [array names tags -regexp {^bgt\d*$} ] {
495
           set x [lindex $tags($bgttag) 0]
496
           set y [lindex $tags($bgttag) 1]
497
           if {$x==""} {set x 0}
498
           if {$y==""} {set y 0}
499
           if {$scaling != ""} {
500
               set x [expr $scaling*$x]
501
               set y [expr $scaling*$y]
502
           }
503
           set txt [lindex $tags($bgttag) 2]
504
           set color [lindex $tags($bgttag) 3]
505
           if {$color == ""} {set color black}
506
           if {[string index $color 0]== "@"} {set color [opp_hsb_to_rgb $color]}
507
           $c create text $x $y -text $txt -fill $color -anchor nw -justify left -tags "dx"
508
       }
509
510
       $c lower mod
511
512
   } errmsg] {
513
       tk_messageBox -type ok -title Error -icon error -parent [winfo toplevel [focus]] \
514
                     -message "Error in display string of $name: $errmsg"
515
   }
516
}
517
518
519
# get_cached_image --
520
#
521
# Performs the following steps:
522
#  - first zooms the image by zoomfactor
523
#  - then takes the area (x1,y1,x2,y2) in the new (zoomed) coordinate system
524
#  - then either stretches or tiles it to (targetWidth,targetHeight) size
525
#  - result gets cached and returned
526
# NOTE:  (x1,y1,x2,y2) cliprect does NOT WORK for stretch mode! always the
527
# full image will be streched to the (targetWidth,targetHeight) size
528
#
529
proc get_cached_image {img zoomfactor x1 y1 x2 y2 targetWidth targetHeight doStretch} {
530
    global icons img_cache
531
532
    set x1 [expr int($x1)]
533
    set y1 [expr int($y1)]
534
    set x2 [expr int($x2)]
535
    set y2 [expr int($y2)]
536
    if {$x1>=$x2} {set x2 [expr $x1+1]}  ;# safety: Tk image copy may hang on zero-size source image
537
    if {$y1>=$y2} {set y2 [expr $y1+1]}
538
539
    set targetWidth [expr int($targetWidth)]
540
    set targetHeight [expr int($targetHeight)]
541
    if {$targetWidth<1} {set targetWidth 1}
542
    if {$targetHeight<1} {set targetHeight 1}
543
    if {$targetWidth>2500 || $targetHeight>2000} {return $icons(imagetoobig)}
544
545
    set key "$img:$zoomfactor:$x1:$y1:$x2:$y2:$targetWidth:$targetHeight:$doStretch"
546
547
    if {![info exists img_cache($key)]} {
548
        if {!$doStretch} {
549
            # "tile" mode: implementation relies on Tk "image copy" command's behavior
550
            # to tile the image if dest area is larger than source area
551
            # NOTE: "image copy" is incredibly slow! need to reimplement it ourselves in C++!
552
            if {$zoomfactor!=1} {
553
                set zoomedisx [expr int([image width $img]*$zoomfactor)]
554
                set zoomedisy [expr int([image height $img]*$zoomfactor)]
555
                set img [resizeimage $img $zoomedisx $zoomedisy]
556
            }
557
            set newimg [image create photo -width $targetWidth -height $targetHeight]
558
            $newimg copy $img -from $x1 $y1 $x2 $y2 -to 0 0 $targetWidth $targetHeight
559
        } else {
560
            # stretch
561
            # IMPORTANT: (x1,y1,x2,y2) gets ignored -- this proc may only be invoked with the full image!
562
            set newimg [resizeimage $img $targetWidth $targetHeight]
563
        }
564
565
        set img_cache($key) $newimg
566
    }
567
    return $img_cache($key)
568
}
569
570
571
#
572
# creates and returns a new image, resized to the given size
573
#
574
proc resizeimage {img sx sy} {
575
    set destimg [image create photo -width $sx -height $sy]
576
    opp_resizeimage $destimg $img
577
    return $destimg
578
}
579
580
581
# draw_connection --
582
#
583
# This function is invoked from the module inspector C++ code.
584
#
585
proc draw_connection {c gateptr dispstr srcptr destptr chanptr src_i src_n dest_i dest_n two_way} {
586
    global inspectordata
587
588
    # puts "DEBUG: draw_connection $c $gateptr $dispstr $srcptr $destptr $src_i $src_n $dest_i $dest_n $two_way"
589
590
    if [catch {
591
       set src_rect [get_submod_coords $c $srcptr]
592
       set dest_rect [get_submod_coords $c $destptr]
593
    } errmsg] {
594
       # skip this connection if source or destination of the arrow cannot be found
595
       return
596
    }
597
598
    if [catch {
599
600
       opp_displaystring $dispstr parse tags $chanptr 1
601
602
       if {![info exists tags(m)]} {set tags(m) {a}}
603
604
       set mode [lindex $tags(m) 0]
605
       if {$mode==""} {set mode "a"}
606
       set src_anch  [list [lindex $tags(m) 1] [lindex $tags(m) 2]]
607
       set dest_anch [list [lindex $tags(m) 3] [lindex $tags(m) 4]]
608
609
       # puts "DEBUG: src_rect=($src_rect) dest_rect=($dest_rect)"
610
       # puts "DEBUG: src_anch=($src_anch) dest_anch=($dest_anch)"
611
612
       regexp -- {^.[^.]*} $c win
613
614
       # switch off the connection arrangement if the option is not enabled
615
       # all connection are treated as the first one in an array with size 1
616
       if {![opp_getsimoption arrangevectorconnections]} {
617
           set src_n "1"
618
           set dest_n "1"
619
           set src_i "0"
620
           set dest_i "0"
621
       }
622
623
       set arrow_coords [eval [concat opp_inspectorcommand $win arrowcoords \
624
                  $src_rect $dest_rect $src_i $src_n $dest_i $dest_n \
625
                  $mode $src_anch $dest_anch]]
626
627
       # puts "DEBUG: arrow=($arrow_coords)"
628
629
       if {![info exists tags(ls)]} {set tags(ls) {}}
630
       set fill [lindex $tags(ls) 0]
631
       if {$fill == ""} {set fill black}
632
       if {$fill == "-"} {set fill ""}
633
       set width [lindex $tags(ls) 1]
634
       if {$width == ""} {set width 1}
635
       if {$width == "0"} {set fill ""}
636
       set style [lindex $tags(ls) 2]
637
       if {[string match "da*" $style]} {
638
           set pattern "-"
639
       } elseif {[string match "d*" $style]} {
640
           set pattern "."
641
       } else {
642
           set pattern ""
643
       }
644
645
       set state "normal"
646
       if {$inspectordata($c:showarrowheads) && !$two_way} {
647
           set arrow last
648
       } else {
649
           set arrow none
650
       }
651
652
       $c create line $arrow_coords -arrow $arrow -fill $fill -dash $pattern -width $width -tags "dx tooltip conn $gateptr"
653
654
       # if we have a two way connection we should draw only in one direction
655
       # the other line will be hidden (lowered under anything else)
656
       if {[string compare $srcptr $destptr] >=0 && $two_way} {
657
           $c lower $gateptr "dx"
658
       }
659
660
       if {[info exists tags(t)]} {
661
           set txt [lindex $tags(t) 0]
662
           # TODO implement: second par is text position
663
           set color [lindex $tags(t) 2]
664
           if {$color == ""} {set color "#005030"}
665
           if {[string index $color 0]== "@"} {set color [opp_hsb_to_rgb $color]}
666
           set x1 [lindex $arrow_coords 0]
667
           set y1 [lindex $arrow_coords 1]
668
           set x2 [lindex $arrow_coords 2]
669
           set y2 [lindex $arrow_coords 3]
670
           set x [expr ($x1+$x2+$x2)/3]
671
           set y [expr ($y1+$y2+$y2)/3]
672
           if {($x1<$x2) == ($y1<=$y2)} {
673
              set anch "n"
674
           } else {
675
              set anch "s"
676
           }
677
           set just "center"
678
           $c create text $x $y -text $txt -fill $color -anchor $anch -justify $just -tags "dx"
679
       }
680
681
    } errmsg] {
682
       tk_messageBox -type ok -title Error -icon error -parent [winfo toplevel [focus]] \
683
                     -message "Error in display string of a connection: $errmsg"
684
    }
685
}
686
687
688
# draw_message --
689
#
690
# This function is invoked from the message animation code.
691
#
692
proc draw_message {c msgptr x y} {
693
    global fonts inspectordata
694
695
    set zoomfactor $inspectordata($c:zoomfactor)
696
    set imagesizefactor $inspectordata($c:imagesizefactor)
697
698
    set dispstr [opp_getobjectfield $msgptr displayString]
699
    set msgkind [opp_getobjectfield $msgptr kind]
700
701
    if {$dispstr=="" && [opp_getsimoption penguin_mode]} {
702
        # following lines were used for testing only...
703
        #set dispstr "b=15,15,rect;o=white,kind,5"
704
        #set dispstr "b="
705
        #set dispstr "o=kind"
706
        #set dispstr "b=15,15,oval;o=kind,white,6"
707
        #set dispstr "i=handset2_s"
708
        set dispstr "i=penguin"
709
    }
710
711
    if {$dispstr==""} {
712
713
        # default presentation: red or msgkind%8-colored ball
714
        if [opp_getsimoption animation_msgcolors] {
715
            set color [lindex {red green blue white yellow cyan magenta black} [expr $msgkind % 8]]
716
        } else {
717
            set color red
718
        }
719
        set ball [$c create oval -5 -5 5 5 -fill $color -outline $color -tags "dx tooltip msg $msgptr"]
720
        $c move $ball $x $y
721
722
        set labelx $x
723
        set labely $y
724
725
    } else {
726
        # use display string
727
728
        # supports "b","i" and "o" tags, they work just as with submodules only default
729
        # is different (small red ball), plus special color "kind" is supported which
730
        # gives the original, message kind dependent colors
731
        opp_displaystring $dispstr parse tags [opp_null] 1
732
733
        # set sx and sy
734
        if ![info exists tags(is)] {
735
            set tags(is) {}
736
        }
737
        if [info exists tags(i)] {
738
739
            if {[lindex $tags(i) 1] == "kind"} {
740
                set kindcolor [lindex {red green blue white yellow cyan magenta black} [expr $msgkind % 8]]
741
                set tags(i) [lreplace $tags(i) 1 1 $kindcolor]
742
            }
743
744
            set img [dispstr_getimage $tags(i) $tags(is) $zoomfactor $imagesizefactor]
745
            set sx [image width $img]
746
            set sy [image height $img]
747
        } elseif [info exists tags(b)] {
748
            set sx [lindex $tags(b) 0]
749
            if {$sx==""} {set sx 10}
750
            set sy [lindex $tags(b) 1]
751
            if {$sy==""} {set sy $sx}
752
        } else {
753
            set tags(b) {10 10 oval}
754
            set sx 10
755
            set sy 10
756
        }
757
758
        if [info exists tags(i)] {
759
760
            $c create image $x $y -image $img -anchor center -tags "dx tooltip msg $msgptr"
761
762
            set labelx $x
763
            set labely [expr $y+$sy/2+3]
764
765
        } elseif [info exists tags(b)] {
766
767
            set x1 [expr $x - $sx/2]
768
            set y1 [expr $y - $sy/2]
769
            set x2 [expr $x + $sx/2]
770
            set y2 [expr $y + $sy/2]
771
772
            set sh [lindex $tags(b) 2]
773
            if {$sh == ""} {set sh oval}
774
775
            set fill [lindex $tags(b) 3]
776
            if {$fill == ""} {set fill red}
777
            if {$fill == "kind"} {
778
                set fill [lindex {red green blue white yellow cyan magenta black} [expr $msgkind % 8]]
779
            }
780
            set outline [lindex $tags(b) 4]
781
            if {$outline == ""} {set outline ""}
782
            if {$outline == "kind"} {
783
                set outline [lindex {red green blue white yellow cyan magenta black} [expr $msgkind % 8]]
784
            }
785
            set width [lindex $tags(b) 5]
786
            if {$width == ""} {set width 1}
787
788
            $c create $sh $x1 $y1 $x2 $y2 -fill $fill -width $width -outline $outline -tags "dx tooltip msg $msgptr"
789
790
            set labelx $x
791
            set labely [expr $y2+$width/2+3]
792
        }
793
    }
794
795
    # display message label: "(classname)name"
796
    set msglabel ""
797
    if [opp_getsimoption animation_msgclassnames] {
798
        set msglabel "([opp_getobjectshorttypename $msgptr])"
799
    }
800
    if [opp_getsimoption animation_msgnames] {
801
        append msglabel "[opp_getobjectfullname $msgptr]"
802
    }
803
    if {$msglabel!=""} {
804
        $c create text $labelx $labely -text $msglabel -anchor n -font $fonts(msgname) -tags "dx tooltip msgname $msgptr"
805
    }
806
807
}
808
809
proc animcontrol {w} {
810
    global priv
811
812
    scale $w -orient horizontal -length 50 -sliderlength 8 -showvalue 0 -bd 1
813
    $w config -from .5 -to 3 -resolution 0.01 -variable priv(animspeed)
814
815
    # following line is too new (Tcl8.4) -- not understood by Tcl8.3
816
    #trace add variable priv(animspeed) write animSpeedChanged
817
    trace variable priv(animspeed) w animSpeedChanged
818
}
819
820
proc create_graphicalmodwindow {name geom} {
821
    global icons help_tips inspectordata config
822
    global B2 B3
823
824
    if {$config(layout-may-resize-window)} {
825
        # remove size from geom
826
        regsub -- {^[0-9]+x[0-9]+} $geom {} geom
827
    }
828
829
    set w $name
830
    create_inspector_toplevel $w $geom
831
832
    # create toolbar
833
    pack_iconbutton $w.toolbar.ascont  -image $icons(asobject) -command "inspect_this $w {As Object}"
834
    pack_iconbutton $w.toolbar.win     -image $icons(asoutput) -command "inspect_this $w {Module output}"
835
    pack_iconbutton $w.toolbar.sep1    -separator
836
837
    moduleinspector_add_run_buttons $w
838
839
    animcontrol $w.toolbar.animspeed
840
    pack $w.toolbar.animspeed -anchor c -expand 0 -fill none -side left -padx 5 -pady 0
841
842
    pack_iconbutton $w.toolbar.sep2    -separator
843
    pack_iconbutton $w.toolbar.redraw  -image $icons(redraw) -command "graphmodwin_relayout $w"
844
    pack_iconbutton $w.toolbar.zoomin  -image $icons(zoomin)  -command "graphmodwin_zoomin $w"
845
    pack_iconbutton $w.toolbar.zoomout -image $icons(zoomout) -command "graphmodwin_zoomout $w"
846
    pack_iconbutton $w.toolbar.showlabels -image $icons(modnames) -command "graphmodwin_togglelabels $w"
847
    pack_iconbutton $w.toolbar.showarrowheads -image $icons(arrowhead) -command "graphmodwin_togglearrowheads $w"
848
849
    set help_tips($w.toolbar.owner)   {Inspect parent module}
850
    set help_tips($w.toolbar.ascont)  {Inspect as object}
851
    set help_tips($w.toolbar.win)     {See module output}
852
    set help_tips($w.toolbar.redraw)  {Re-layout (Ctrl+R)}
853
    set help_tips($w.toolbar.animspeed) {Animation speed -- see Options dialog}
854
    set help_tips($w.toolbar.zoomin)  {Zoom in (Ctrl+M)}
855
    set help_tips($w.toolbar.zoomout) {Zoom out (Ctrl+N}
856
    set help_tips($w.toolbar.showlabels) {Show module names (Ctrl+D)}
857
    set help_tips($w.toolbar.showarrowheads) {Show arrowheads (Ctrl+A)}
858
859
    # add zoom status
860
    label $w.infobar.zoominfo -text "" -anchor e -relief flat -justify right
861
    pack $w.infobar.zoominfo -anchor n -side right -expand 0 -fill none -pady 1
862
863
    # create canvas
864
    set c $w.c
865
866
    # init some state vars
867
    set inspectordata($c:zoomfactor) 1
868
    set inspectordata($c:imagesizefactor) 1
869
    set inspectordata($c:showlabels) 1
870
    set inspectordata($c:showarrowheads) 1
871
872
    frame $w.grid
873
    scrollbar $w.hsb -orient horiz -command "$c xview"
874
    scrollbar $w.vsb -command "$c yview"
875
    canvas $c -background "#a0e0a0" -relief raised -closeenough 2 \
876
        -xscrollcommand "$w.hsb set" \
877
        -yscrollcommand "$w.vsb set"
878
    pack $w.grid -expand yes -fill both -padx 1 -pady 1
879
    grid rowconfig    $w.grid 0 -weight 1 -minsize 0
880
    grid columnconfig $w.grid 0 -weight 1 -minsize 0
881
882
    grid $c -in $w.grid -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news
883
    grid $w.vsb -in $w.grid -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news
884
    grid $w.hsb -in $w.grid -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news
885
886
    # mouse bindings
887
    $c bind submod <Double-1> "graphmodwin_dblclick $w"
888
    $c bind conn <Double-1> "graphmodwin_dblclick $w"
889
    $c bind msg <Double-1> "graphmodwin_dblclick $w"
890
    $c bind msgname <Double-1> "graphmodwin_dblclick $w"
891
    $c bind qlen <Double-1> "graphmodwin_qlen_dblclick $w"
892
893
    $c bind submod <$B3> "graphmodwin_rightclick $w %X %Y %x %y"
894
    $c bind conn <$B3> "graphmodwin_rightclick $w %X %Y %x %y"
895
    $c bind msg <$B3> "graphmodwin_rightclick $w %X %Y %x %y"
896
    $c bind msgname <$B3> "graphmodwin_rightclick $w %X %Y %x %y"
897
    $c bind mod <$B3> "graphmodwin_rightclick $w %X %Y %x %y"
898
    $c bind modname <$B3> "graphmodwin_rightclick $w %X %Y %x %y"
899
    $c bind qlen <$B3> "graphmodwin_qlen_rightclick $w %X %Y %x %y"
900
901
    # keyboard shortcuts
902
    bind $w <Control-m> "graphmodwin_zoomin $w"
903
    bind $w <Control-n> "graphmodwin_zoomout $w"
904
    bind $w <Control-i> "graphmodwin_zoomiconsby $w 1.25"
905
    bind $w <Control-o> "graphmodwin_zoomiconsby $w 0.8"
906
    bind $w <Control-r> "graphmodwin_relayout $w"
907
    bind $w <Control-d> "graphmodwin_togglelabels $w"
908
    bind $w <Control-a> "graphmodwin_togglearrowheads $w"
909
910
    if {$inspectordata($c:showlabels)} {
911
        $w.toolbar.showlabels config -relief sunken
912
    }
913
    if {$inspectordata($c:showarrowheads)} {
914
        $w.toolbar.showarrowheads config -relief sunken
915
    }
916
917
    #update idletasks
918
    update
919
    if [catch {
920
       opp_inspectorcommand $w relayout
921
    } errmsg] {
922
       tk_messageBox -type ok -title Error -icon error -parent [winfo toplevel [focus]] \
923
                     -message "Error displaying network graphics: $errmsg"
924
    }
925
926
    graphmodwin_adjust_windowsize_and_zoom $w
927
}
928
929
proc graphmodwin_adjust_windowsize_and_zoom {w} {
930
    global config
931
932
    if {!$config(layout-may-resize-window) && !$config(layout-may-change-zoom)} {
933
        graphmodwin_setscrollregion $w 1
934
        return
935
    }
936
937
    set c $w.c
938
939
    # if needed, resize window to fit graphics; if not enough, additionally zoom out as well
940
    set bb [$c bbox "mod"] ;# bounding box of the compound module
941
    set graphicswidth [expr [lindex $bb 2]-[lindex $bb 0]]
942
    set graphicsheight [expr [lindex $bb 3]-[lindex $bb 1]]
943
944
    if {!$config(layout-may-resize-window)} {
945
        # do not resize, but change zoom so that graphics fills the window
946
        # note: $config(layout-may-change-zoom) is TRUE here because of the above "if"
947
        set canvaswidth [winfo width $c]
948
        set canvasheight [winfo height $c]
949
        set canvaswidth2 [expr $canvaswidth - 20]  ;# deduce 10px border around compound module
950
        set canvasheight2 [expr $canvasheight - 20]
951
952
        set zoomx [expr $canvaswidth2 / double($graphicswidth)]
953
        set zoomy [expr $canvasheight2 / double($graphicsheight)]
954
        set zoom [math_min $zoomx $zoomy]
955
956
        if {$zoom < 1.0} {
957
            graphmodwin_zoomby $w $zoom
958
        }
959
        graphmodwin_setscrollregion $w 1
960
961
    } else {
962
        # we'll need to resize the window, and then either zoom out or not
963
964
        # compute maximum available canvas size first that would fit on the screen
965
        wm_getdesktopbounds $w desktop ;# fills $desktop(top), $desktop(width), etc.
966
        wm_getdecorationsize border    ;# fills $border(top), $border(left), etc.
967
        set maxwinwidth [expr $desktop(width) - $border(left) - $border(right) - 30]
968
        set maxwinheight [expr $desktop(height) - $border(top) - $border(bottom) - 20]
969
970
        set chromewidth [expr [winfo width $w] - [winfo width $c]]
971
        set chromeheight [expr [winfo height $w] - [winfo height $c]]
972
        set scrollbarwidth 24
973
        set scrollbarheight 24
974
975
        set margin 10  ;# 10px space around compound module
976
977
        set maxcanvaswidth [expr $maxwinwidth - $chromewidth - $scrollbarwidth - $margin]
978
        set maxcanvasheight [expr $maxwinheight - $chromeheight - $scrollbarheight - $margin]
979
980
        # compute zoomby factor; this is either 1.0 (no change), or less than 1.0 (zoom out)
981
        if {!$config(layout-may-change-zoom)} {
982
            set zoom 1
983
        } else {
984
            set zoomx 1.0
985
            set zoomy 1.0
986
            if {$graphicswidth > $maxcanvaswidth} {
987
                set zoomx [expr $maxcanvaswidth / double($graphicswidth)]
988
            }
989
            if {$graphicsheight > $maxcanvasheight} {
990
                set zoomy [expr $maxcanvasheight / double($graphicsheight)]
991
            }
992
            if {$zoomx < $zoomy} {set zoom $zoomx} else {set zoom $zoomy}
993
        }
994
995
        set zoomedgraphicswidth [expr $zoom * $graphicswidth]
996
        set zoomedgraphicsheight [expr $zoom * $graphicsheight]
997
998
        set canvaswidth [expr [math_min $zoomedgraphicswidth $maxcanvaswidth] + 30]
999
        set canvasheight [expr [math_min $zoomedgraphicsheight $maxcanvasheight] + 30]
1000
1001
        # set size and zoom
1002
        $c config -width $canvaswidth
1003
        $c config -height $canvasheight
1004
        graphmodwin_zoomby $w $zoom
1005
1006
        # allow the window to appear, so that scrollbars know their real size;
1007
        # this is needed for "$c xview moveto" inside graphmodwin_setscrollregion
1008
        # to work properly
1009
        update idletasks
1010
1011
        graphmodwin_setscrollregion $w 1
1012
1013
        # move the window so that it is fully on the screen -- this is not
1014
        # such a good idea in practice (can be annoying/confusing)
1015
        #move_to_screen $w
1016
    }
1017
}
1018
1019
#
1020
# Sets the scrolling region for a graphical module inspector.
1021
# NOTE: This method is invoked from C++.
1022
#
1023
proc graphmodwin_setscrollregion {w moveToOrigin} {
1024
    set c $w.c
1025
1026
    # scrolling region
1027
    set bb [$c bbox all]
1028
    set x1 [expr [lindex $bb 0]-10]
1029
    set y1 [expr [lindex $bb 1]-10]
1030
    set x2 [expr [lindex $bb 2]+10]
1031
    set y2 [expr [lindex $bb 3]+10]
1032
    $c config -scrollregion [list $x1 $y1 $x2 $y2]
1033
1034
    # scroll to top-left corner of compound module to top-left corner of window
1035
    if {$moveToOrigin} {
1036
        set enclosingmodbb [$c bbox mod]
1037
        set mx1 [expr [lindex $enclosingmodbb 0]-10]
1038
        set my1 [expr [lindex $enclosingmodbb 1]-10]
1039
1040
        $c xview moveto [expr ($mx1 - $x1) / double($x2 - $x1)]
1041
        $c yview moveto [expr ($my1 - $y1) / double($y2 - $y1)]
1042
    }
1043
}
1044
1045
proc math_min {a b} {
1046
    return [expr ($a < $b) ? $a : $b]
1047
}
1048
1049
proc math_max {a b} {
1050
    return [expr ($a > $b) ? $a : $b]
1051
}
1052
1053
proc graphmodwin_zoomin {w} {
1054
    global config
1055
    graphmodwin_zoomby $w $config(zoomby-factor) 1
1056
}
1057
1058
proc graphmodwin_zoomout {w} {
1059
    global config
1060
    graphmodwin_zoomby $w [expr 1.0 / $config(zoomby-factor)] 1
1061
}
1062
1063
proc graphmodwin_zoomby {w mult {snaptoone 0}} {
1064
    global inspectordata
1065
    set c $w.c
1066
    if {($mult<1 && $inspectordata($c:zoomfactor)>0.001) || ($mult>1 && $inspectordata($c:zoomfactor)<1000)} {
1067
        # update zoom factor and redraw
1068
        set inspectordata($c:zoomfactor) [expr $inspectordata($c:zoomfactor) * $mult]
1069
1070
        # snap to 1 (note: this is not desirable when zoom is set programmatically to fit network into window)
1071
        if {$snaptoone} {
1072
            set m [expr $mult < 1 ? 1.0/$mult : $mult]
1073
            set a [expr  1 - 0.9*(1 - 1.0/$m)]
1074
            set b [expr  1 + 0.9*($m - 1)]
1075
            if {$inspectordata($c:zoomfactor) > $a && $inspectordata($c:zoomfactor) < $b} {
1076
                set inspectordata($c:zoomfactor) 1
1077
            }
1078
        }
1079
1080
        opp_inspectorcommand $w redraw
1081
        graphmodwin_setscrollregion $w 0
1082
1083
        # update status display
1084
        set value [format "%.2f" $inspectordata($c:zoomfactor)]
1085
        $w.infobar.zoominfo config -text "Zoom: ${value}x"
1086
    }
1087
1088
    graphmodwin_pop_out_toolbar_buttons $w
1089
}
1090
1091
proc graphmodwin_pop_out_toolbar_buttons {w} {
1092
    # in Run or Fast mode with dynamic module creation, toolbar buttons may get stuck
1093
    # after clicking in "sunken" or "raised" state instead of returning to "flat",
1094
    # likely because events get lost during the grab during incremental layouting.
1095
    # No idea how this can be fixed properly.
1096
    # This is a weak attempt to fix it for the most commonly clicked buttons.
1097
    # This could be called from many more places for better results.
1098
    $w.toolbar.minfo config -relief flat
1099
    $w.toolbar.type config -relief flat
1100
    $w.toolbar.objs config -relief flat
1101
    $w.toolbar.owner config -relief flat
1102
    $w.toolbar.ascont config -relief flat
1103
    $w.toolbar.win config -relief flat
1104
    $w.toolbar.stop config -relief flat
1105
    $w.toolbar.redraw config -relief flat
1106
    $w.toolbar.zoomin config -relief flat
1107
    $w.toolbar.zoomout config -relief flat
1108
}
1109
1110
proc graphmodwin_zoomiconsby {w mult} {
1111
    global inspectordata
1112
    set c $w.c
1113
    if {($mult<1 && $inspectordata($c:imagesizefactor)>0.1) || ($mult>1 && $inspectordata($c:imagesizefactor)<5)} {
1114
        set inspectordata($c:imagesizefactor) [expr $inspectordata($c:imagesizefactor) * $mult]
1115
        if {abs($inspectordata($c:imagesizefactor)-1.0) < 0.1} {set inspectordata($c:imagesizefactor) 1}
1116
        opp_inspectorcommand $w redraw
1117
    }
1118
    #puts "icon size factor: $inspectordata($c:imagesizefactor)"
1119
}
1120
1121
proc graphmodwin_togglelabels {w} {
1122
    global inspectordata
1123
    set c $w.c
1124
    set inspectordata($c:showlabels) [expr !$inspectordata($c:showlabels)]
1125
    opp_inspectorcommand $w redraw
1126
1127
    if {$inspectordata($c:showlabels)} {set relief "sunken"} else {set relief "flat"}
1128
    $w.toolbar.showlabels config -relief $relief
1129
}
1130
1131
proc graphmodwin_togglearrowheads {w} {
1132
    global inspectordata
1133
    set c $w.c
1134
    set inspectordata($c:showarrowheads) [expr !$inspectordata($c:showarrowheads)]
1135
    opp_inspectorcommand $w redraw
1136
1137
    if {$inspectordata($c:showarrowheads)} {set relief "sunken"} else {set relief "flat"}
1138
    $w.toolbar.showarrowheads config -relief $relief
1139
}
1140
1141
proc graphmodwin_dblclick w {
1142
   set c $w.c
1143
   set item [$c find withtag current]
1144
   set tags [$c gettags $item]
1145
1146
   set ptr ""
1147
   if {[lsearch $tags "ptr*"] != -1} {
1148
      regexp "ptr.*" $tags ptr
1149
   }
1150
1151
   if {$ptr!=""} {
1152
      opp_inspect $ptr "(default)"
1153
   }
1154
}
1155
1156
# get the pointers of all objects under the mouse. If more than 1 ptr is returned
1157
# then bgrptr is removed from the list. x and y must be widget relative coordinate
1158
# (of the canvas object). The background module pointer is removed automatically
1159
# if more that 1 pointer is present. I.e. background is returned ONLY if the mouse
1160
# is directly over the background module.
1161
proc get_ptrs_under_mouse {c x y} {
1162
   set ptrs {}
1163
   # convert widget coordinates to canvas coordinates
1164
   set x [$c canvasx $x]
1165
   set y [$c canvasy $y]
1166
   set items [$c find overlapping [expr $x-2] [expr $y-2] [expr $x+2] [expr $y+2]]
1167
   foreach item $items {
1168
       set tags [$c gettags $item]
1169
       foreach tag $tags {
1170
           if [string match "ptr*" $tag] {
1171
               lappend ptrs $tag
1172
           }
1173
       }
1174
   }
1175
1176
   set ptrs2 {}
1177
   if {$ptrs != {}} {
1178
      # remove duplicate pointers and reverse the order
1179
      # so the topmost element will be the first in the list
1180
      foreach ptr $ptrs {
1181
          if {[lsearch -exact $ptrs2 $ptr] == -1 } {
1182
              set ptrs2 [lreplace $ptrs2 0 -1 $ptr]
1183
          }
1184
      }
1185
1186
      set bgptr ""
1187
      regexp {\.(ptr.*)-([0-9]+)} $c match bgptr dummy
1188
      # if more than one ptr present delete the background module's pointer
1189
      if { [llength $ptrs2] > 1 && $bgptr != "" } {
1190
          set bgindex [lsearch $ptrs2 $bgptr]
1191
          if { $bgindex >= 0 } {
1192
              set ptrs2 [lreplace $ptrs2 $bgindex $bgindex]
1193
          }
1194
      }
1195
   }
1196
   return $ptrs2
1197
}
1198
1199
proc graphmodwin_rightclick {w X Y x y} {
1200
   global inspectordata tmp
1201
   set c $w.c
1202
   set ptrs [get_ptrs_under_mouse $c $x $y]
1203
1204
   if {$ptrs != {}} {
1205
1206
      set popup [create_inspector_contextmenu $ptrs]
1207
1208
      set tmp($c:showlabels) $inspectordata($c:showlabels)
1209
      set tmp($c:showarrowheads) $inspectordata($c:showarrowheads)
1210
1211
      $popup add separator
1212
      $popup add checkbutton -label "Show module names" -command "graphmodwin_togglelabels $w" -accel "Ctrl+D" -variable tmp($c:showlabels)
1213
      $popup add checkbutton -label "Show arrowheads" -command "graphmodwin_togglearrowheads $w" -accel "Ctrl+A" -variable tmp($c:showarrowheads)
1214
1215
      $popup add separator
1216
      $popup add command -label "Increase icon size" -accel "Ctrl+I" -command "graphmodwin_zoomiconsby $w 1.25"
1217
      $popup add command -label "Decrease icon size" -accel "Ctrl+O" -command "graphmodwin_zoomiconsby $w 0.8"
1218
1219
      $popup add separator
1220
      $popup add command -label "Zoom in"  -accel "Ctrl+M" -command "graphmodwin_zoomin $w"
1221
      $popup add command -label "Zoom out" -accel "Ctrl+N" -command "graphmodwin_zoomout $w"
1222
      $popup add command -label "Re-layout" -accel "Ctrl+R" -command "opp_inspectorcommand $w relayout"
1223
1224
      $popup add separator
1225
      $popup add command -label "Layouting options..." -command "options_dialog $w l"
1226
      $popup add command -label "Animation options..." -command "options_dialog $w a"
1227
1228
      tk_popup $popup $X $Y
1229
   }
1230
}
1231
1232
# graphmodwin_relayout --
1233
#
1234
# Relayout the compound module, and resize the window accordingly.
1235
#
1236
proc graphmodwin_relayout {w} {
1237
    global config
1238
1239
    opp_inspectorcommand $w relayout
1240
1241
    if {$config(layout-may-resize-window)} {
1242
        wm geometry $w ""
1243
    }
1244
1245
    graphmodwin_adjust_windowsize_and_zoom $w
1246
}
1247
1248
# graphmodwin_draw_message_on_gate --
1249
#
1250
# Draw message near the head of the connection arrow.
1251
# Called from inspector C++ code.
1252
#
1253
proc graphmodwin_draw_message_on_gate {c gateptr msgptr} {
1254
1255
    #debug "graphmodwin_draw_message_on_gate $msgptr"
1256
1257
    global fonts
1258
1259
    # gate pointer + conn are the tags of the connection arrow
1260
    set conn_id ""
1261
    foreach id [$c find withtag $gateptr] {
1262
       if {[lsearch -exact [$c gettags $id] "conn"] != -1} {
1263
          set conn_id $id
1264
       }
1265
    }
1266
1267
    if {$conn_id == ""} {
1268
        # connection arrow not (no longer?) on canvas: forget animation
1269
        $c delete $msgptr;  # this also works if msg is not (yet) on canvas
1270
        return;
1271
    }
1272
1273
    set coords [$c coords $conn_id]
1274
    setvars {x1 y1 x2 y2} $coords
1275
    set endpos [graphmodwin_getmessageendpos $x1 $y1 $x2 $y2]
1276
    setvars {xx yy} $endpos
1277
1278
    draw_message $c $msgptr $xx $yy
1279
}
1280
1281
#
1282
# Calculates the position where a sent message ball should rest until its event
1283
# comes and it gets processed by the module
1284
#
1285
proc graphmodwin_getmessageendpos {x1 y1 x2 y2} {
1286
    set len [expr sqrt(($x2-$x1)*($x2-$x1)+($y2-$y1)*($y2-$y1))]
1287
    if {$len==0} {set len 1}
1288
    set dx [expr ($x2-$x1)/$len]
1289
    set dy [expr ($y2-$y1)/$len]
1290
1291
    set len2 [expr $len - 6]
1292
    if {$len2 < 1} {set len2 1}
1293
    set xx [expr $x1+$dx*$len2]
1294
    set yy [expr $y1+$dy*$len2]
1295
    return [list $xx $yy]
1296
}
1297
1298
# graphmodwin_draw_message_on_module --
1299
#
1300
# Draw message on submodule rectangle.
1301
# Called from inspector C++ code.
1302
#
1303
proc graphmodwin_draw_message_on_module {c modptr msgptr} {
1304
1305
    #debug "graphmodwin_draw_message_on_module $msgptr"
1306
    set r  [get_submod_coords $c $modptr]
1307
    set x [expr ([lindex $r 0]+[lindex $r 2])/2]
1308
    set y [expr ([lindex $r 1]+[lindex $r 3])/2]
1309
1310
    draw_message $c $msgptr $x $y
1311
}
1312
1313
# graphmodwin_draw_nexteventmarker --
1314
#
1315
# This function is invoked from the module inspector C++ code.
1316
#
1317
proc graphmodwin_draw_nexteventmarker {c modptr type} {
1318
    set src  [get_submod_coords $c $modptr]
1319
    set x1 [expr [lindex $src 0]-2]
1320
    set y1 [expr [lindex $src 1]-2]
1321
    set x2 [expr [lindex $src 2]+2]
1322
    set y2 [expr [lindex $src 3]+2]
1323
    # $type==1 compound module, $type==2 simple module
1324
    if {$type==1} {
1325
        #$c create rect $x1 $y1 $x2 $y2 -tags {nexteventmarker} -outline red -dash {.}
1326
        $c create rect $x1 $y1 $x2 $y2 -tags {nexteventmarker} -outline red -width 1
1327
    } else {
1328
        #$c create rect $x1 $y1 $x2 $y2 -tags {nexteventmarker} -outline red
1329
        $c create rect $x1 $y1 $x2 $y2 -tags {nexteventmarker} -outline red -width 2
1330
    }
1331
}
1332
1333
# graphmodwin_update_submod --
1334
#
1335
# This function is invoked from the module inspector C++ code.
1336
#
1337
proc graphmodwin_update_submod {c modptr} {
1338
    # currently the only thing to be updated is the number of elements in queue
1339
    set win [winfo toplevel $c]
1340
    set dispstr [opp_getobjectfield $modptr displayString]
1341
    set qname [opp_displaystring $dispstr getTagArg "q" 0 $modptr 1]
1342
    if {$qname!=""} {
1343
        #set qptr [opp_inspectorcommand $win getsubmodq $modptr $qname]
1344
        #set qlen [opp_getobjectfield $qptr length]
1345
        # TBD optimize -- maybe store and remember q pointer?
1346
        set qlen [opp_inspectorcommand $win getsubmodqlen $modptr $qname]
1347
        $c itemconfig "qlen-$modptr" -text "q:$qlen"
1348
    }
1349
}
1350
1351
#
1352
# Helper proc.
1353
#
1354
proc graphmodwin_qlen_getqptr_current {c} {
1355
   set item [$c find withtag current]
1356
   set tags [$c gettags $item]
1357
1358
   set modptr ""
1359
   if {[lsearch $tags "qlen-ptr*"] != -1} {
1360
       regexp "ptr.*" $tags modptr
1361
   }
1362
   if {$modptr==""} {return}
1363
1364
   return [graphmodwin_qlen_getqptr $c $modptr]
1365
1366
}
1367
1368
proc graphmodwin_qlen_getqptr {c modptr} {
1369
   set win [winfo toplevel $c]
1370
   set dispstr [opp_getobjectfield $modptr displayString]
1371
   set qname [opp_displaystring $dispstr getTagArg "q" 0 $modptr 1]
1372
   if {$qname!=""} {
1373
       set qptr [opp_inspectorcommand $win getsubmodq $modptr $qname]
1374
       return $qptr
1375
   }
1376
   return ""
1377
}
1378
1379
proc graphmodwin_qlen_dblclick w {
1380
   set c $w.c
1381
   set qptr [graphmodwin_qlen_getqptr_current $c]
1382
   if [opp_isnotnull $qptr] {
1383
       opp_inspect $qptr "(default)"
1384
   }
1385
}
1386
1387
proc graphmodwin_qlen_rightclick {w X Y} {
1388
   set c $w.c
1389
   set qptr [graphmodwin_qlen_getqptr_current $c]
1390
   if [opp_isnotnull $qptr] {
1391
       set popup [create_inspector_contextmenu $qptr]
1392
       tk_popup $popup $X $Y
1393
   }
1394
}
1395
1396
# graphmodwin_bubble --
1397
#
1398
# This function is invoked from the module inspector C++ code.
1399
#
1400
proc graphmodwin_bubble {c x y scaling txt} {
1401
    global inspectordata
1402
1403
    set zoom $inspectordata($c:zoomfactor)
1404
    if {$scaling == ""} {set scaling 1}
1405
1406
    set x [expr $x*$zoom*$scaling]
1407
    set y [expr $y*$zoom*$scaling]
1408
1409
    while {[string length $txt]<5} {set txt " $txt "}
1410
    set txtid  [$c create text $x $y -text " $txt " -anchor c -tags "bubble"]
1411
    set color #F8F8D8
1412
    set bb [$c bbox $txtid]
1413
1414
    set x1 [lindex $bb 0]
1415
    set y1 [lindex $bb 1]
1416
    set x2 [lindex $bb 2]
1417
    set y2 [lindex $bb 3]
1418
1419
    set x1o [expr $x1-2]
1420
    set y1o [expr $y1-2]
1421
    set x2o [expr $x2+2]
1422
    set y2o [expr $y2+2]
1423
1424
    set xm [expr ($x1+$x2)/2]
1425
    set ym [expr ($y1+$y2)/2]
1426
    set xme [expr $xm-10]
1427
    set yme [expr $y2o+15]
1428
1429
    set pp [list $x1o $y1  \
1430
                 $x1  $y1o \
1431
                 $xm  $y1o \
1432
                 $xm  $y1o \
1433
                 $x2  $y1o \
1434
                 $x2o $y1  \
1435
                 $x2o $ym  \
1436
                 $x2o $ym  \
1437
                 $x2o $y2  \
1438
                 $x2  $y2o \
1439
                 $xm  $y2o \
1440
                 $xm  $y2o \
1441
                 \
1442
                 $xme $yme \
1443
                 $xme $yme \
1444
                 $xme $y2o \
1445
                 $xme $y2o \
1446
                 \
1447
                 $x1  $y2o \
1448
                 $x1o $y2  \
1449
                 $x1o $ym  \
1450
                 $x1o $ym ]
1451
1452
    set bubbleid [$c create polygon $pp -outline black -fill $color -width 1 -smooth 1 -tags "bubble"]
1453
    $c lower $bubbleid $txtid
1454
1455
    set dx [expr $x-$xme]
1456
    set dy [expr $y-$yme]
1457
1458
    $c move $bubbleid $dx $dy
1459
    $c move $txtid $dx $dy
1460
1461
    set sp [opp_getsimoption animation_speed]
1462
    set ad [expr int(1000 / (0.1+$sp))]
1463
    after $ad [list catch [list $c delete $txtid $bubbleid]]
1464
}
1465
1466
1467
#
1468
# Called from Layouter::debugDraw()
1469
#
1470
proc layouter_debugDraw_finish {c msg} {
1471
    # create label
1472
    set bb [$c bbox bbox]
1473
    $c create text [lindex $bb 0] [lindex $bb 1] -tag bbox -anchor sw -text $msg
1474
    set bb [$c bbox bbox]
1475
1476
    # rescale to fit canvas
1477
    set w [expr [lindex $bb 2]-[lindex $bb 0]]
1478
    set h [expr [lindex $bb 3]-[lindex $bb 1]]
1479
    set cw [winfo width $c]
1480
    set ch [winfo height $c]
1481
    set fx [expr $cw/double($w)]
1482
    set fy [expr $ch/double($h)]
1483
    if {$fx>1} {set fx 1}
1484
    if {$fy>1} {set fy 1}
1485
    $c scale all 0 0 $fx $fy
1486
1487
    $c config -scrollregion [$c bbox bbox]
1488
    $c xview moveto 0
1489
    $c yview moveto 0
1490
    update idletasks
1491
}
1492
1493
proc layouter_startgrab {stopbutton} {
1494
    global opp help_tips
1495
1496
    # tooltip
1497
    set opp(grabSavedTooltip) $help_tips($stopbutton)
1498
    set help_tips($stopbutton) {Layouting -- click STOP to abort it}
1499
1500
    # prevent user from closing window (postpone close operation)
1501
    set win [winfo toplevel $stopbutton]
1502
    set opp(grabOrigCloseHandler) [wm protocol $win WM_DELETE_WINDOW]
1503
    wm protocol $win WM_DELETE_WINDOW [list opp_markinspectorfordeletion $win]
1504
1505
    set opp(oldGrab) [grab current $stopbutton]
1506
1507
    grab $stopbutton
1508
    focus $stopbutton
1509
}
1510
1511
proc layouter_releasegrab {stopbutton} {
1512
    global opp help_tips
1513
1514
    # restore everything messed up in layouter_startgrab
1515
    set help_tips($stopbutton) $opp(grabSavedTooltip)
1516
1517
    catch {grab release $stopbutton}
1518
    catch {grab release [grab current]}
1519
1520
    set win [winfo toplevel $stopbutton]
1521
    wm protocol $win WM_DELETE_WINDOW $opp(grabOrigCloseHandler)
1522
}
1523