开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 通讯编程 > 查看源码
build-ui.tcl
资源名称：ns-allinone-2.33.tar.gz　[点击查看]
上传用户：rrhhcc
上传日期：2015-12-11
资源大小：54129k
文件大小：33k
源码类别：

通讯编程

开发平台：

Visual C++

build-ui.tcl：源码内容
  2. # Copyright (C) 1998 by USC/ISI
  3. # All rights reserved.                                            
  4. #                                                                
  5. # Redistribution and use in source and binary forms are permitted
  6. # provided that the above copyright notice and this paragraph are
  7. # duplicated in all such forms and that any documentation, advertising
  8. # materials, and other materials related to such distribution and use
  9. # acknowledge that the software was developed by the University of
  10. # Southern California, Information Sciences Institute.  The name of the
  11. # University may not be used to endorse or promote products derived from
  12. # this software without specific prior written permission.
  13. # 
  14. # THIS SOFTWARE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
  15. # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
  16. # MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
  17. # 
  18. # $Header: /cvsroot/nsnam/nam-1/tcl/build-ui.tcl,v 1.32 2002/11/25 20:14:32 buchheim Exp $
  20. Animator instproc build-ui {} {
  21. $self instvar netView id_ tlw_ balloon_
  23. # Start our own toplevel widget
  24. set tlw_ .model$id_
  25. toplevel $tlw_
  27. # Create balloon help for this animator
  28. set balloon_ [new BalloonHelp $tlw_]
  30.         # build the menu bar
  31.         frame $tlw_.menu -borderwidth 0
  32. $self build-menus $tlw_.menu
  33.         pack $tlw_.menu -side top -fill x
  35. # Every netmodel has: view (zoom bar, scroll bar, 
  36. # monitor pane, layout pane, annotation pane, time slider)
  37. frame $tlw_.view
  38. $self build-view $tlw_.view
  40.         # build the control panel with rew, ffwd, play, etc
  41. frame $tlw_.ctrl0 -relief flat -borderwidth 0
  42. $self build-animation-ctrl $tlw_.ctrl0 
  43.         pack $tlw_.ctrl0 -side top -fill x
  45. frame $tlw_.ctrl -relief flat -borderwidth 0
  46. $self build-view-ctrl $tlw_.ctrl
  47. set windows(control) $tlw_.ctrl
  48. pack $tlw_.ctrl -side bottom -fill x
  50. pack $tlw_.view -side top -fill both -expand true
  52. wm minsize $tlw_ 200 200
  53.         $self window_bind $tlw_
  54.         $self view_bind $netView
  56. # Stop the animation if the window is destroyed by the window manager
  57. bind $netView <Destroy> "$self stop 1"
  59. # Set window title to "nam #instance: trace_file_name"
  60. $self instvar tracefile
  61. wm title $tlw_ "[tk appname]: $tracefile"
  62. }
  64. Animator instproc build-view w {
  65. $self tkvar showpanel
  66. $self instvar netModel netView netViews tlw_ windows
  68. # View
  69.         frame $w.f
  70.         #frame is just to sink the netview
  71.         frame $w.f.f -borderwidth 2 -relief sunken
  72. # $netModel view $w.f.f.net
  73. $netModel editview $w.f.f.net
  74.         set netView $w.f.f.net
  75. set netViews $netView
  76.         pack $w.f.f.net -side top -expand true -fill both
  78. # X scroll bar
  79.         $netView xscroll $w.f.hsb
  80.         scrollbar $w.f.hsb -orient horizontal -width 10 
  81. -borderwidth 1 -command "$netView xview"
  82.         $w.f.hsb set 0.0 1.0
  83.         pack $w.f.hsb -side bottom -fill x
  84.         pack $w.f.f -side top -fill both -expand true
  86. # Y scroll bar
  87.         frame $w.f2
  88.         $netView yscroll $w.f2.vsb
  89.         scrollbar $w.f2.vsb -orient vertical -width 10 
  90. -borderwidth 1 -command "$netView yview"
  91.         $w.f2.vsb set 0.0 1.0
  92.         pack $w.f2.vsb -side top -fill y -expand true
  93.         frame $w.f2.l -width 12 -height 12
  94.         pack $w.f2.l -side top
  96. # zoom bar
  97. frame $w.ctrl -borderwidth 2 -relief groove
  98. $self build-zoombar $netView $w.ctrl $w
  99. pack $w.ctrl -side left -fill y
  100.         pack $w.f2 -side right -fill y
  101.         pack $w.f -side left -fill both -expand true
  103. # monitor pane
  104. frame $tlw_.monwin -relief groove -borderwidth 2
  105. button $tlw_.monwin.l -bitmap monitors -borderwidth 2 -relief groove 
  106. -command "$self closepanel monitor"
  107. pack $tlw_.monwin.l -side left -fill y
  108. set windows(monitor) $tlw_.monwin
  109. trace variable showpanel(monitor) w 
  110. "$self displaypanel $tlw_.monwin $w monitor top x false"
  111. set showpanel(monitor) 0
  112. }
  114. Animator instproc build-view-ctrl {w} {
  115. $self tkvar showpanel
  116. $self instvar NETWORK_MODEL mintime maxtime now mslider pipemode 
  117. vslider
  119. # Time slider pane
  120. frame $w.p0b -relief flat -borderwidth 0
  122. # $self build-slider $w.p0b
  124. set mslider [new TimesliderModel $mintime $maxtime $now $self]
  125. set vslider [new TimesliderView $w.p0b $mslider]
  127. $mslider addObserver $vslider
  128. $mslider setpipemode $pipemode
  130. # annotation pane
  131. frame $w.tl -relief flat -borderwidth 0
  132. $self build-annotation $w.tl
  133. set showpanel(annotate) 1
  135. if {$NETWORK_MODEL == "NetworkModel/Auto"} {
  136.         set showpanel(autolayout) 1
  137.         trace variable showpanel(autolayout) w 
  138.     "$self displaypanel $w.p2 $w.p0b autolayout 
  139.      top x false"
  140. frame $w.p2 -relief flat -borderwidth 0
  141. $self build-layout $w.p2
  142. pack $w.p0b $w.p2 $w.tl  
  143. -side top -fill x
  144. } else {
  145.         set showpanel(autolayout) 0
  146. pack $w.p0b $w.tl -side top -fill x
  147. }
  148. }
  150. Animator instproc build-menus w {
  151. $self tkvar nam_record_animation nam_auto_ff showpanel isSync_
  152. $self tkvar showData_ showRouting_ showMac_
  153.         $self instvar NETWORK_MODEL netModel nam_name windows 
  155. frame $w.menu -relief groove -bd 2
  156.         pack $w.menu -side top -fill x
  158. set padx 4
  160. set mb $w.menu.file
  161. set m $mb.m
  162. menubutton $mb -text "File" -menu $m -underline 0 
  163. -borderwidth 1 
  164. menu $m
  165. #$m add command -label "Open..." -state disabled
  166. $m add command -label "Save layout" -command "$self save_layout"
  167. $m add command -label "Print" -command "$self print_view $netModel nam"
  168. $m add separator
  169. # NEEDSWORK: record animation should prompt for the
  170. # prefix to use (nam_record_filename) in a dialog box.
  171. # Also, the file opening/closing should be moved to Tcl
  172. # so I can write to a
  173. # filename "|xwdtoppm | ppmtogif > sequenceXXX.gif"
  174. # and have the Right Thing happen.
  175. # Finally, it would be nice to put the clock
  176. # actually into the image so it makes it into the mpeg.
  177. $m add checkbutton -label "Record animation" 
  178. -variable [$self tkvarname nam_record_animation]
  179. if ![info exists nam_record_animation] {
  180. set nam_record_animation 0
  181. }
  182. $m add checkbutton -label "Auto FastForward" 
  183. -variable [$self tkvarname nam_auto_ff]
  184. if ![info exists nam_auto_ff] {
  185. set nam_auto_ff 0
  186. }
  188. $m add separator
  189. $m add command -label "Close" -command "$self done"
  190. pack $mb -side left -padx $padx
  192. set mb $w.menu.views
  193. set m $mb.m
  194. set mp $m.filter
  195. set mp1 $mp.type1
  196. set mp2 $mp.type2
  197. menubutton $mb -text "Views" -menu $m -underline 0 
  198. -borderwidth 1 
  199. menu $m
  200. $m add command -label "New view" -command "$self new_view"
  201. # $m add command -label "Edit view" -command "$self new_editview"
  202. $m add separator
  204. $m add command -label "Node energy" -command "$self energy_view"
  206. #filter menu
  207. $m add cascade -label "Packet filter" -menu $mp
  208. menu $mp
  209.  
  210. $mp add cascade -label "Packet type" -menu $mp1
  211. $mp add command -label "Traffic type" -command "$self select-traffic"
  212. $mp add command -label "Source node" -command "$self select-src"
  213. $mp add command -label "Destination node" -command "$self select-dst"
  214. $mp add command -label "Flow id" -command "$self select-fid"
  215. $mp add command -label "Reset all" -command "$netModel resetFilter"
  216. menu $mp1
  217. set showData_ 1
  218. set showRouting_ 1
  219. set showMac_ 1
  220. $mp1 add checkbutton -label "Data" 
  221. -variable [$self tkvarname showData_]
  222. $mp1 add checkbutton -label "Routing" 
  223. -variable [$self tkvarname showRouting_]
  224. $mp1 add checkbutton -label "Mac" 
  225. -variable [$self tkvarname showMac_]
  228. $m add command -label "Highlight leaf trees" -command 
  229. "$self show_subtrees"
  230. $m add checkbutton -label "Show monitors" 
  231. -variable [$self tkvarname showpanel(monitor)]
  232.         if {$NETWORK_MODEL=="NetworkModel/Auto"} {
  233.     $m add checkbutton -label "Show autolayout" 
  234.     -variable [$self tkvarname showpanel(autolayout)]
  235. } else {
  236.     $m add checkbutton -label "Show autolayout" -state disabled
  237. }
  238. $m add checkbutton -label "Show annotations" 
  239. -variable [$self tkvarname showpanel(annotate)]
  240. $m add checkbutton -label "Sync" 
  241. -variable [$self tkvarname isSync_]
  242. if ![info exists isSync_] {
  243. set isSync_ 0
  244. }
  245. trace variable isSync_ w "$self on-change-sync"
  246. pack $mb -side left -padx $padx
  248. # -----------------------------
  249. # Analysis Tool
  250. set mb $w.menu.analysis
  251. set m $mb.m
  252. $self instvar analysis_OK
  253. if { $analysis_OK == 0 } {
  254.     menubutton $mb -text "Analysis" -menu $m -underline 0 
  255. -borderwidth 1 -state disabled
  256.         } else {
  257.     menubutton $mb -text "Analysis" -menu $m -underline 0 
  258. -borderwidth 1
  259. }
  261. menu $m
  262. $m add command -label "Active Sessions" -command "$self active_sessions"
  263. $m add command -label "Legend ..." -command "$self auto_legend"
  264. #$m add command -label "Saving ..." -command "$self manual_legend"
  265. pack $mb -side left -padx $padx
  266. # ------------------------------
  268. label $w.menu.name -text $nam_name -font [smallfont] 
  269. -width 30 -borderwidth 2 -relief groove 
  270.         set windows(title) $w.menu.name
  271. pack $w.menu.name -side left -fill x -expand true -padx 4 -pady 1
  273. # Help is moved to main menu
  274. }
  276. Animator instproc select-traffic {} {
  277.    $self tkvar trafficType_
  278.    toplevel .selectTraffic
  279.    set w .selectTraffic
  280.    wm title $w "Enter traffic type (CBR,TCP,...)"
  281.    label $w.label -text "Traffic type:"
  282.    entry $w.entry -width 50 -relief sunken 
  283.                    -textvariable [$self tkvarname trafficType_]
  284.    pack $w.label $w.entry -side left -fill both -expand true
  285.    bind $w.entry <Return> "$self filter-traffic $w"
  286. }
  288. Animator instproc filter-traffic {w} {
  289.    $self tkvar trafficType_
  290.    $self instvar netModel 
  291.    destroy $w
  292.    $netModel traffic_filter $trafficType_
  293. }
  295. Animator instproc select-src {} {
  296.    $self tkvar srcNode_
  297.    toplevel .selectSrc
  298.    set w .selectSrc
  299.    wm title $w "Enter source node"
  300.    label $w.label -text "Source node:"
  301.    entry $w.entry -width 50 -relief sunken 
  302.                    -textvariable [$self tkvarname srcNode_]
  303.    pack $w.label $w.entry -side left -fill both -expand true
  304.    bind $w.entry <Return> "$self filter-src $w"
  305. }
  307. Animator instproc filter-src {w} {
  308.    $self tkvar srcNode_
  309.    $self instvar netModel 
  310.    destroy $w
  311.    $netModel src_filter $srcNode_
  312. }
  314. Animator instproc select-dst {} {
  315.    $self tkvar dstNode_
  316.    toplevel .selectDst
  317.    set w .selectDst
  318.    wm title $w "Enter destination node"
  319.    label $w.label -text "Destination node:"
  320.    entry $w.entry -width 50 -relief sunken 
  321.                    -textvariable [$self tkvarname dstNode_]
  322.    pack $w.label $w.entry -side left -fill both -expand true
  323.    bind $w.entry <Return> "$self filter-dst $w"
  324. }
  326. Animator instproc filter-dst {w} {
  327.    $self tkvar dstNode_
  328.    $self instvar netModel 
  329.    destroy $w
  330.    $netModel dst_filter $dstNode_
  331. }
  333. Animator instproc select-fid {} {
  334.    $self tkvar flowId_
  335.    toplevel .selectFlow
  336.    set w .selectFlow
  337.    wm title $w "Enter flow id"
  338.    label $w.label -text "Flow id:"
  339.    entry $w.entry -width 50 -relief sunken 
  340.                    -textvariable [$self tkvarname flowId_]
  341.    pack $w.label $w.entry -side left -fill both -expand true
  342.    bind $w.entry <Return> "$self filter-fid $w"
  343. }
  345. Animator instproc filter-fid {w} {
  346.    $self tkvar flowId_
  347.    $self instvar netModel 
  348.    destroy $w
  349.    $netModel fid_filter $flowId_
  350. }
  353. Animator instproc selectColor {} {
  354.    $self colorPaletteReq .colorpalette 
  355.         {0000 3300 6600 9900 CC00 FF00} 
  356.         {0000 3300 6600 9900 CC00 FF00} 
  357.         {0000 3300 6600 9900 CC00 FF00} 
  358.         .colorsp
  359. }
  361. Animator instproc colorPaletteReq { name redlist greenlist bluelist replace } {
  362.          $self instvar SharedEnv netModel
  364.  # Setup
  365.  set w ${name}
  366.  if {[winfo exists $w]} {
  367.             wm deiconify $w
  368.     raise $w
  369.     return
  370.          }
  371.  set SharedEnv($name) $replace
  372.  eval toplevel $w ""
  373.  wm protocol $w WM_DELETE_WINDOW "wm withdraw $w"
  375.  frame $w.f
  377.  foreach red $redlist {
  378.          frame $w.f.rcol_${red}
  379.  foreach green $greenlist {
  380.           frame $w.f.grow_${red}${green}
  381.  foreach blue $bluelist {
  382.          if { [info exists SharedEnv($w.f.c${red}${green}${blue})] } {
  383.      frame $w.f.c${red}${green}${blue} 
  384.            -relief raised -height 2m -width 2m 
  385.    -highlightthickness 0 
  386.    -bd 1 -bg $SharedEnv($w.f.c${red }${green}${blue})
  387.                                  } else {
  388.      frame $w.f.c${red}${green}${blue} 
  389.            -relief raised -height 2m -width 2m 
  390.    -highlightthickness 0 
  391.    -bd 1 -bg "#${red}${green}${blue}"
  392.                                  }
  393.  pack $w.f.c${red}${green}${blue} -side left 
  394.  -in $w.f.grow_${red}${green} -fill both -expand true
  395.   bind $w.f.c${red}${green}${blue} <ButtonRelease-1> "
  396.        $self setcolor %W
  397.                                   "
  398.                           }
  399.                           pack $w.f.grow_${red}${green} -side top 
  400.        -in $w.f.rcol_${red} -fill both -expand true
  401.                  }
  402.  pack $w.f.rcol_${red} -side left -in $w.f -fill both 
  403.       -expand true
  404. }
  405. frame $w.f.c_none -width 4m -relief raised -bd 1 
  406.       -highlightthickness 0
  407.         pack $w.f.c_none -in $w.f -side left -fill y
  408. pack $w.f -in $w -expand true -fill both
  410. # Return
  411. wm geometry $w 400x100
  412. }
  414. Animator instproc setcolor {w} {
  415.          $self instvar netModel colorarea colorn
  417.  $w configure -relief raised
  418.  set colorv [$w cget -bg]
  419.  set rgb [winfo rgb $w $colorv]
  420.  set colorn "[$netModel lookupColorName [lindex $rgb 0] 
  421.      [lindex $rgb 1] [lindex $rgb 2]]"
  423. set rgb [winfo rgb . $colorn]
  424. set name "[$netModel lookupColorName [lindex $rgb 0] 
  425.                  [lindex $rgb 1] [lindex $rgb 2]]"
  426.         $netModel select-color $name
  428. if {[info exists colorarea] && [winfo exists $colorarea]} {
  429.     $colorarea delete 0.0 end
  430.     $colorarea insert 0.0 $colorn
  431.     catch { $colorarea tag add bgcolor 0.0 end }
  432.     $colorarea tag configure bgcolor -background $colorn
  433.         }
  434. }
  436. Animator instproc on-change-sync args {
  437. $self tkvar isSync_
  438. if $isSync_ {
  439. $self add-sync $self
  440. } else {
  441. $self remove-sync $self
  442. }
  443. }
  445. Animator instproc set_run { w } {
  446. $self instvar netView running
  447. focus $netView
  448. $self set_forward_dir 1
  449. if { $running != 1 } {
  450. $self play 1
  451. #$self renderFrame
  452. }
  453. $self highlight $w.bar.run 1
  454. }
  456. Animator instproc set_back { w } {
  457. $self instvar netView running
  458. focus $netView
  459. $self set_backward_dir 1
  460. if { $running != 1 } {
  461. $self play 1
  462. $self renderFrame
  463. }
  464. $self highlight $w.bar.back 1
  465. }
  467. Animator instproc on-rateslider-press {} {
  468. $self instvar currRate prevRate
  469. set prevRate $currRate
  470. }
  472. Animator instproc on-rateslider-motion { v } {
  473. $self instvar timeStep stepDisp
  474. set timeStep [expr pow(10, $v / 10.)]
  475. set stepDisp [step_format $timeStep]
  476. }
  478. Animator instproc build-animation-ctrl {w} {
  479.         $self instvar rateSlider granularity timeStep currRate prevRate 
  480. stepDisp running direction balloon_
  482. set f [smallfont]
  483. frame $w.bar -relief groove -borderwidth 2
  484.         frame $w.bar.rate -borderwidth 1 -relief sunken
  485. scale $w.bar.rate.s -orient horizontal -width 7p 
  486.         -label "Step:" -font [smallfont]
  487. -from -60 -to -1 -showvalue false 
  488. -relief flat
  489. -borderwidth 1 -highlightthickness 0 
  490. -troughcolor [option get . background Nam]
  491.         pack $w.bar.rate.s -side top -fill both -expand true
  492.         set rateSlider $w.bar.rate.s
  493. set granularity [option get . granularity Nam]
  494. set timeStep [time2real [option get . rate Nam]]
  495.         set stepDisp [step_format $timeStep]
  496.         set currRate [expr 10*log10($timeStep)]
  497.         set prevRate $currRate
  498. $rateSlider set $currRate
  499.         bind $rateSlider <ButtonRelease-1> "$self set_rate [%W get] 1"
  500. bind $rateSlider <ButtonPress-1> "$self on-rateslider-press"
  501. bind $rateSlider <B1-Motion> "$self on-rateslider-motion [%W get]"
  502. trace variable stepDisp w "$self displayStep"
  504. $self tkvar nowDisp
  505. label $w.bar.timerVal -textvariable [$self tkvarname nowDisp] 
  506. -width 14 -anchor w -font $f -borderwidth 1 
  507. -relief sunken -anchor e
  509.         frame $w.bar.run
  510. button $w.bar.run.b -bitmap play -borderwidth 1 -relief raised 
  511. -highlightthickness 0 -font $f  
  512. -command "$self set_run $w"
  513.         frame $w.bar.run.f -height 5 -relief sunken 
  514. -borderwidth 1
  515.         pack $w.bar.run.b -side top -fill both -expand true
  516.         pack $w.bar.run.f -side top -fill x
  517. $balloon_ balloon_for $w.bar.run.b "play forward" 1000
  519.         frame $w.bar.back
  520. button $w.bar.back.b -bitmap back -borderwidth 1 -relief raised 
  521. -highlightthickness 0 -font $f 
  522. -command "$self set_back $w"
  523. $balloon_ balloon_for $w.bar.back.b "play backward" 1000
  525. # hilight running labels as $running changes
  526. trace variable running w "$self trace_running_handler $w"
  528.         frame $w.bar.back.f -height 5 -relief sunken 
  529. -borderwidth 1
  530.         pack $w.bar.back.b -side top -fill both -expand true
  531.         pack $w.bar.back.f -side top -fill x
  532.         
  533.         frame $w.bar.stop
  534. button $w.bar.stop.b -bitmap stop -borderwidth 1 -relief raised 
  535. -highlightthickness 0 -font $f 
  536. -command "$self stop 1;
  537.           $self renderFrame;
  538.   $self highlight $w.bar.stop 1"
  539. $balloon_ balloon_for $w.bar.stop.b "stop" 1000
  540.         frame $w.bar.stop.f -height 5 -relief sunken 
  541. -borderwidth 1
  542.         pack $w.bar.stop.b -side top -fill both -expand true
  543.         pack $w.bar.stop.f -side top -fill x
  545.         frame $w.bar.rew
  546. button $w.bar.rew.b -bitmap rew -borderwidth 1 -relief raised 
  547. -highlightthickness 0 -font $f -command "$self rewind"
  548. $balloon_ balloon_for $w.bar.rew.b "rewind" 1000
  549.         frame $w.bar.rew.f -height 5 -relief sunken 
  550.                 -borderwidth 1
  551.         pack $w.bar.rew.b -side top -fill both -expand true
  552.         pack $w.bar.rew.f -side top -fill x
  554.         frame $w.bar.ff
  555. button $w.bar.ff.b -bitmap ff -borderwidth 1 -relief raised 
  556. -highlightthickness 0 -font $f -command "$self fast_fwd"
  557. $balloon_ balloon_for $w.bar.ff.b "fast forward" 1000
  558.         frame $w.bar.ff.f -height 5 -relief sunken 
  559.                 -borderwidth 1
  560.         pack $w.bar.ff.b -side top -fill both -expand true
  561.         pack $w.bar.ff.f -side top -fill x
  563. # button $w.bar.quit -bitmap eject -borderwidth 1 -relief raised 
  564. # -highlightthickness 0 -font $f -command "$self stop; $self done"
  565. # $balloon_ balloon_for $w.bar.quit "Quit Animator" 1000
  567. pack $w.bar.rate -side right -fill y
  568. pack $w.bar.timerVal -side right -pady 0 
  569. -ipady 1 -padx 1 -fill y
  570. #        pack $w.bar.quit -side right -padx 1 -pady 1 -fill both -expand true
  571.         pack $w.bar.ff -side right -padx 1 -pady 1 -fill both -expand true
  572.         pack $w.bar.run -side right -padx 1 -pady 1 -fill both -expand true
  573.         pack $w.bar.stop -side right -padx 1 -pady 1 -fill both -expand true
  574.         pack $w.bar.back -side right -padx 1 -pady 1 -fill both -expand true
  575.         pack $w.bar.rew -side right -padx 1 -pady 1 -fill both -expand true
  576. #        pack $w.help -side left -padx 1 -pady 1 -fill y 
  578. pack $w.bar -fill x -expand 1 -side right
  579.         $self instvar prevbutton
  580.         set prevbutton $w.bar.stop
  582. # start out stopped
  583. $self highlight $w.bar.stop 1
  584. }
  586. # tb - the name of the edit button
  587. # db1, db2 - names of the buttons to be enable/disabled
  588. Animator instproc toggle-edit { view tb db1 db2 } {
  589. $self instvar enable_edit_ balloon_
  590. set enable_edit_ [expr !$enable_edit_]
  591. if {$enable_edit_} {
  592. $self clear_view_bind $view
  593. $self editview_bind $view
  594. $tb configure -relief sunken
  595. $db1 configure -state normal
  596. $db2 configure -state normal
  597. $tb configure -bitmap "netview"
  598. $balloon_ balloon_for $db1 "NodeUp (enabled)"
  599. $balloon_ balloon_for $db2 "NodeDown (enabled)"
  600. } else {
  601. $self clear_editview_bind $view
  602. $self view_bind $view
  603. $tb configure -relief raised
  604. $db1 configure -state disabled
  605. $db2 configure -state disabled
  606. $tb configure -bitmap "netedit"
  607. $balloon_ balloon_for $db1 "NodeUp (disabled)"
  608. $balloon_ balloon_for $db2 "NodeDown (disabled)"
  609. }
  610. }
  612. # We need $w to put the control pane into, and $mainW to handle "close"
  613. Animator instproc build-zoombar {view w mainW} {
  614. $self instvar magnification viewOffset balloon_
  616. set magnification 1.0
  617. set viewOffset(x) 0.0
  618. set viewOffset(y) 0.0
  619.     
  620. frame $w.f
  621. pack $w.f -side top
  622. button $w.f.b1 -bitmap "zoomin" -command "$view zoom 1.6" 
  623. -highlightthickness 0 -borderwidth 1
  624. pack $w.f.b1 -side top -ipady 3
  625. button $w.f.b2 -bitmap "zoomout" -command "$view zoom 0.625" 
  626. -highlightthickness 0 -borderwidth 1
  627. pack $w.f.b2 -side top -ipady 3
  629. # Build edit enable/disable button 
  630. $self instvar enable_edit_
  631. # By default disable editing
  632. set enable_edit_ 0
  633. button $w.f.b3 -bitmap "netedit" -command 
  634. "$self toggle-edit $view $w.f.b3 $w.f.b4 $w.f.b5" 
  635. -highlightthickness 1 -borderwidth 1
  636. pack $w.f.b3 -side top -ipady 3
  638. # Node size up/down buttons
  639. $self instvar netModel 
  640. button $w.f.b4 -bitmap "nodeup" -command 
  641. "$netModel incr-nodesize 1.1" -state disabled
  642. button $w.f.b5 -bitmap "nodedown" -command 
  643. "$netModel decr-nodesize 1.1" -state disabled
  644. pack $w.f.b4 -side top -ipady 3
  645. pack $w.f.b5 -side top -ipady 3
  647. $balloon_ balloon_for $w.f.b1 "ZoomIn"
  648. $balloon_ balloon_for $w.f.b2 "ZoomOut"
  649. $balloon_ balloon_for $w.f.b3 "Edit/View"
  650. $balloon_ balloon_for $w.f.b4 "NodeUp (disabled)"
  651. $balloon_ balloon_for $w.f.b5 "NodeDown (disabled)"
  653. if {[winfo name $mainW] != "view"} {
  654. button $w.f.b6 -bitmap "eject" -command "destroy $mainW" 
  655. -highlightthickness 0 -borderwidth 1
  656. pack $w.f.b6 -side top -ipady 3
  657. }
  658. }
  660. Animator instproc setCurrentTime {time} {
  661. $self tkvar nowDisp
  662. set nowDisp $time
  663. }
  665. Animator instproc build-slider {w} {
  666. $self instvar timeslider timeslider_width timeslider_tag 
  667.     timeslider_pos nowDisp 
  669. frame $w.f -borderwidth 2 -relief groove
  670. pack $w.f -side top -fill x -expand 1
  671. set timeslider(height) 12
  672. set timeslider(swidth) 32
  673. set timeslider(width) 32
  674. set timeslider_width($w.f.c) 32
  675. set timeslider(canvas) $w.f.c
  676. lappend timeslider(canvas_set) $timeslider(canvas)
  677. set timeslider(frame) $w
  678. canvas $w.f.c -height $timeslider(height) -width 300 
  679. -background white -highlightthickness 0
  680. pack $w.f.c -side left -fill x -expand 1 -padx 0 -pady 0
  682. label $w.f.c.b -bitmap time -highlightthickness 0 -borderwidth 1 
  683. -relief raised
  684. set timeslider_tag($w.f.c) [$w.f.c create window 
  685. [expr $timeslider(swidth)/2] 0 -window $w.f.c.b 
  686. -height 12 -width $timeslider(swidth) -anchor n]
  687. set timeslider_pos($w.f.c) 0
  688. bind $w.f.c <ButtonPress-1> "$self timeslidertrough $w.f.c %x %y"
  689. bind $w.f.c.b <ButtonPress-1> "$self timesliderpress $w.f.c %x %y;break"
  690. bind $w.f.c.b <ButtonRelease-1> "$self timesliderrelease $w.f.c %x %y"
  691. bind $w.f.c.b <B1-Motion> "$self timeslidermotion $w.f.c %x %y"
  692. bind $w.f.c <Configure> "$self timeticks $w.f.c"
  693. }
  695. Animator instproc timeticks { wfc } {
  696. $self instvar timeslider mintime range timeslider_width 
  697. timeslider_tag maxtime mid_
  698. set timeslider(canvas) $wfc
  700. set st [lindex [split $wfc "."] 2]
  701. if { [string compare $st "ctrl"] == 0 } {
  702. set width [winfo width $timeslider(canvas)]
  703. } else {
  704.                 if { [string compare $st "slider"] == 0 } {
  705.                     set namgraphname_ [lindex [split $wfc "."] 1]
  706.                     set width [winfo width .$namgraphname_.main.c]
  707.                 } else {                    
  708.             set width [winfo width $tlw_.$st.main.c]
  709.                 }
  710. }
  711. if {$width == $timeslider_width($wfc)} { return }
  712. set timeslider(width) $width
  713. set timeslider_width($wfc) $width
  714. $timeslider(canvas) delete ticks
  716. #we really shouldn't need to do this but there's a redraw bug in the
  717. #tk canvas that we need to work around (at least in tk4.2) - mjh
  718. pack forget $timeslider(canvas)
  719. update
  720. update idletasks
  721. pack $timeslider(canvas) -side left -fill x -expand 1 -padx 0 -pady 0
  723. set width [winfo width $wfc]
  725. # We need a more adaptive way to draw the ticks. Otherwise for long 
  726. # and sparse simulations, it'll result in long startup time - haoboy
  727. set x [expr $timeslider(swidth)/2]
  728. # Unit of time represented by one pixel
  729. set tickIncr [expr $range / ($width-$timeslider(swidth))]
  730. # Should check if range is 0
  731. if {$range == 0} {
  732. set intertick [expr ($width - $timeslider(swidth)) / 10]
  733. } else {
  734. set intertick [expr ($width-$timeslider(swidth))/(10 * $range)]
  735. }
  736. if {$intertick < 2} {
  737. # This increment should be at least 2 pixel
  738. set intertick 2
  739. }
  740. for {set t $mintime} {$t < ($range+$mintime)} {set t [expr $t+$intertick*$tickIncr]} {
  741. set intx [expr int($x)]
  742. $timeslider(canvas) addtag ticks withtag 
  743. [$timeslider(canvas) create line 
  744. $intx [expr $timeslider(height)/2] 
  745. $intx $timeslider(height)]
  746. set x [expr $x+$intertick]
  747. }
  748. set x [expr $timeslider(swidth)/2]
  749. if {$range == 0} {
  750. set intertick [expr $width - $timeslider(swidth)]
  751. } else {
  752. set intertick [expr ($width-$timeslider(swidth))/($range)]
  753. }
  754. if {$intertick < 20} {
  755. set intertick 20
  756. }
  757. for {set t $mintime} {$t < ($range+$mintime)} {set t [expr $t+$intertick*$tickIncr]} {
  758. set intx [expr int($x)]
  759. $timeslider(canvas) addtag ticks withtag 
  760. [$timeslider(canvas) create line 
  761. $intx 0 $intx $timeslider(height)]
  762. set x [expr $x+$intertick]
  763. }
  765. set wfc_width [winfo width $wfc]
  767. if {$maxtime > 0} {
  768. set x [expr ($wfc_width-$timeslider(swidth))*$now/$maxtime]
  769. } else {
  770. set x [expr ($wfc_width-$timeslider(swidth))*$now]
  771. }
  773. $wfc coords $timeslider_tag($wfc) [expr $x + $timeslider(swidth)/2] 0
  774. }
  777. Animator instproc getmainslidermodel {} {
  778. $self instvar mslider
  779. return $mslider
  780. }
  782. Animator instproc setsliderPressed {v} {
  783. $self instvar sliderPressed
  784. set sliderPressed $v
  785. }
  787. Animator instproc getrunning {} {
  788. $self instvar running
  789. return $running
  790. }
  792. Animator instproc timesliderset {t} {
  793. $self instvar mslider
  794. $mslider setcurrenttime $t
  795. return
  796. }
  798. Animator instproc timesliderpress {w x y} {
  799. $self instvar timeslider sliderPressed 
  800. set timeslider(oldpos) $x
  801. #    set timeslider(width) [winfo width $timeslider(canvas)]
  802. $w.b configure -relief sunken
  803. set sliderPressed 1
  804. }
  806. Animator instproc timeslidertrough {w x y} {
  807. $self instvar timeslider sliderPressed timeslider_pos
  808. if {$timeslider_pos($w)>$x} {
  809. $self rewind
  810. } else {
  811. $self fast_fwd
  812.     }
  813. }
  815. Animator instproc timeslidermotion {wc x y} {
  816. $self instvar timeslider mintime range timeslider_tag 
  817.               timeslider_pos timeslider_width
  818. $self tkvar nowDisp
  820. set diff [expr $x - $timeslider(oldpos)]
  822. set timeslider(canvas) $wc
  824. $timeslider(canvas) move $timeslider_tag($wc) 
  825. $diff 0
  826.  
  827. set timeslider_pos($wc) [expr $timeslider_pos($wc) + $diff]
  828. if {$timeslider_pos($wc)<0} {
  829. $timeslider(canvas) move $timeslider_tag($wc) 
  830.                          [expr 0 - $timeslider_pos($wc)] 0
  831. set timeslider_pos($wc) 0
  832. }
  834. if {$timeslider_pos($wc)>[expr $timeslider_width($wc)-$timeslider(swidth)]} {
  835. $timeslider(canvas) move $timeslider_tag($wc) 
  836.                          [expr ($timeslider_width($wc) - $timeslider(swidth)) - 
  837.                          $timeslider_pos($wc)] 0
  839. set timeslider_pos($wc) [expr $timeslider_width($wc)-$timeslider(swidth)]
  840. }
  842.  set tick 0
  843. catch {
  844. set tick [expr 1000.0*$timeslider_pos($wc)/($timeslider_width($wc)-$timeslider(swidth))]
  845. }
  846. set now [expr ($tick * $range) / 1000. + $mintime]
  847. set nowDisp [format %.6f $now]
  848. set timeslider(tick) $tick
  850. $self timesliderset $now
  851. }
  853. Animator instproc timesliderrelease {w x y} {
  854. $self instvar timeslider sliderPressed running
  856. $self timeslidermotion $w $x $y
  857. $w.b configure -relief raised
  858. $self slidetime $timeslider(tick) 1
  859. set sliderPressed 0
  860. if $running {
  861. $self renderFrame
  862. }
  863. }
  865. Animator instproc nam-relayout {} {
  866. $self tkvar ITERATIONS KCa KCr Recalc 
  867. $self instvar now netModel
  869. $netModel do_relayout $ITERATIONS $KCa $KCr $Recalc
  870. $self settime $now
  871. update idletasks
  872. }
  874. Animator instproc set-layout-params { iter kca kcr } {
  875. $self tkvar ITERATIONS KCa KCr 
  876. set ITERATIONS $iter
  877. set KCa $kca 
  878. set KCr $kcr
  879. }
  881. Animator instproc build-layout {w} {
  882. $self tkvar ITERATIONS KCa KCr Recalc
  883. $self instvar NETWORK_MODEL 
  884. if {$NETWORK_MODEL != "NetworkModel/Auto"} {
  885. return
  886. }
  888. set f [smallfont]
  889. # frame $w.bar -relief ridge -borderwidth 2
  890.         label $w.label -text "Auto layout:" -font $f
  891. label $w.label_ca -text "Ca" -font $f
  892. entry $w.inputca -width 6 -relief sunken 
  893. -textvariable [$self tkvarname KCa] -font $f
  894. label $w.label_cr -text "Cr" -font $f
  895. entry $w.inputcr -width 6 -relief sunken 
  896. -textvariable [$self tkvarname KCr] -font $f
  897. label $w.label_iter -text "Iterations" -font $f
  898. entry $w.inputiter -width 6 -relief sunken 
  899. -textvariable [$self tkvarname ITERATIONS]
  901.         set Recalc 1
  902.         checkbutton $w.recalc -text Recalc -onvalue 1 -offvalue 0 
  903. -variable [$self tkvarname Recalc] -font $f 
  904. -highlightthickness 0
  906. $self instvar netModel
  907. button $w.reset -text reset -relief raised -font $f 
  908. -command "$netModel reset"
  910. button $w.relayout -text re-layout -relief raised -font $f 
  911. -command "$self nam-relayout"
  913. pack $w.label -side left -padx 1 -pady 1
  914. pack $w.label_ca -side left -padx 1 -pady 1 -fill x
  915. pack $w.inputca -side left -padx 1 -pady 1 -fill x
  916. pack $w.label_cr -side left -padx 1 -pady 1 -fill x
  917. pack $w.inputcr -side left -padx 1 -pady 1 -fill x
  919. pack $w.label_iter -side left -padx 1 -pady 1 -fill x
  920. pack $w.inputiter -side left -padx 1 -pady 1 -fill x
  921. pack $w.recalc -side left -padx 1 -pady 1 -fill both
  922. pack $w.reset -side right -padx 1 -pady 1 -fill both
  923. pack $w.relayout -side right -padx 1 -pady 1 -fill both
  924. # pack $w.bar -fill x -expand 1
  926. bind $w.inputca <Return> " $self nam-relayout"
  927. bind $w.inputcr <Return> " $self nam-relayout"
  928. bind $w.inputiter <Return> "$self nam-relayout"
  929. }
  931. # we'll build a new annotation listbox for this
  932. Animator instproc build-annotation { w } {
  933. $self tkvar showpanel
  934. $self instvar annoBox annoBoxHeight annoJump
  935.         frame $w.spaceral -borderwidth 0 -highlightthickness 0 
  936. -height 0 -width 10
  937.         pack $w.spaceral -side top -padx 0 -pady 0
  938.         frame $w.f -borderwidth 0 -highlightthickness 0
  939. frame $w.f.f
  941. set annoJump 0
  942. set annoBoxHeight 3
  943. listbox $w.f.f.a -xscrollcommand "$w.f.f.ah set" 
  944. -yscrollcommand "$w.f.f2.av set" -height $annoBoxHeight 
  945. -selectmode single 
  946. pack $w.f.f.a -fill both -side top -expand true 
  947. set annoBox $w.f.f.a
  949. scrollbar $w.f.f.ah -orient horizontal -width 10 -borderwidth 1 
  950. -command "$w.f.f.a xview"
  951. $w.f.f.ah set 0.0 1.0
  952. pack $w.f.f.ah -side bottom -fill x
  954. frame $w.f.f2
  955. pack $w.f.f2 -side left -fill y
  956. scrollbar $w.f.f2.av -orient vertical -width 10 -borderwidth 1 
  957. -command "$w.f.f.a yview"
  958. $w.f.f2.av set 0.0 1.0
  959. pack $w.f.f2.av -side top -fill y -expand true
  960.         pack $w.f.f -side left -fill both -expand true
  961.         trace variable showpanel(annotate) w 
  962. "$self displaypanel $w.f $w.spaceral annotate top both true"
  964. bind $w.f.f.a <Double-ButtonPress-1> "$self jump_to_annotation $w.f.f.a"
  965. bind $w.f.f.a <ButtonPress-3> "$self popup_annotation $w %x %y"
  966. }
  968. #
  969. # Helper functions
  970. #
  971. Animator instproc displaypanel {panel after name side fill expand args} {
  972. $self tkvar showpanel
  974. if {$showpanel($name) == 1} {
  975. set str "pack $panel -side $side -fill $fill -expand $expand"
  976. if {$after!=""} {
  977. set str "$str -after $after"
  978. }
  979. eval $str
  980. } else {
  981. pack forget $panel
  982. }
  983. }
  985. Animator instproc closepanel { name } {
  986. $self tkvar showpanel
  987. set showpanel($name) 0
  988. }
  990. Animator instproc highlight {w mode} {
  991.     $self instvar prevbutton
  992.     if {$mode==1} {
  993. $prevbutton.b configure -relief raised
  994. $prevbutton.f configure -background [option get . background Nam]
  995. set prevbutton $w
  996.     }
  997.     $w.f configure -background seagreen
  998.     $w.f configure -relief sunken
  999. }
  1001. Animator instproc trace_running_handler { w args } { 
  1002. $self instvar direction running
  1004. # $x == $running
  1005. if {$running == 0} {
  1006. $self highlight $w.bar.stop 1 
  1007. } elseif {($direction == 1)} {
  1008. $self highlight $w.bar.run 1
  1009. } else {
  1010. $self highlight $w.bar.back 1
  1011. }
  1012. }
  1014. #-----------------------------------------------------------------------
  1015. # Animator instproc window_bind {w}
  1016. #  - Add key and event bindings to the animation window
  1017. #-----------------------------------------------------------------------
  1018. Animator instproc window_bind {w} {
  1019. bind $w <q> "$self done"
  1020. bind $w <Q> "$self all_done"
  1021. bind $w <Control-w> "$self done"
  1022. bind $w <Control-W> "$self done"
  1023. bind $w <Control-q> "[AnimControl instance] done"
  1024. bind $w <Control-Q> "[AnimControl instance] done"
  1025. bind $w <Control-c> "$self done"
  1027. wm protocol $w WM_DELETE_WINDOW "$self done"
  1029. bind $w <b> "$self back_step"
  1030. bind $w <B> "$self back_step"
  1032. bind $w <c> "$self play 1"
  1033. bind $w <C> "$self play 1"
  1034. bind $w <f> "$self fast_fwd"
  1035. bind $w <F> "$self fast_fwd"
  1036. bind $w <n> "$self next_event"
  1037. bind $w <N> "$self next_event"
  1038. bind $w <p> "$self stop 1"
  1039. bind $w <P> "$self stop 1"
  1040. bind $w <r> "$self rewind"
  1041. bind $w <R> "$self rewind"
  1042. bind $w <u> "$self time_undo"
  1043. bind $w <U> "$self time_undo"
  1044. bind $w <x> "$self rate_undo"
  1045. bind $w <X> "$self rate_undo"
  1046. bind $w <period> "$self change_rate 1"
  1047. bind $w <greater> "$self change_rate 1"
  1048. bind $w <comma> "$self change_rate 0"
  1049. bind $w <less> "$self change_rate 0"
  1050. }
  1052. Animator instproc view_bind {netView} {
  1053. # We need these keys in input boxes, so only bind them to .view
  1054. bind $netView <space> "$self toggle_pause"
  1055. bind $netView <Control-d> "$self done"
  1056. bind $netView <Return> "$self single_step"
  1057. bind $netView <BackSpace> "$self back_step"
  1058. bind $netView <Delete> "$self back_step"
  1059. bind $netView <0> "$self reset"
  1061. bind $netView <ButtonPress-1> "$self start_info $netView %x %y left"
  1062. bind $netView <ButtonPress-3> "$self start_info $netView %x %y right"
  1063. bind $netView <ButtonPress-2> "$self view_drag_start $netView %x %y"
  1064. bind $netView <B2-Motion> "$self view_drag_motion $netView %x %y"
  1065. # bind $netView <ButtonRelease-3> "$self end_info $netView"
  1066. }
  1068. Animator instproc clear_view_bind { netView } {
  1069. bind $netView <ButtonPress-1> ""
  1070. bind $netView <ButtonPress-3> ""
  1071. bind $netView <ButtonPress-2> ""
  1072. bind $netView <B2-Motion> ""
  1073. }