namespace eval ::vtk { namespace export * # ------------------------------------------------------------------- # vtkTk(ImageViewer/Render)Widget callbacks. # vtkw: Tk pathname of the widget # renwin: render window embeded in the widget # x: X coord, widget relative # y: X coord, widget relative # w: width of an event or update # h: height of an event or update # ctrl: 1 if the Control key modifier was pressed, 0 otherwise # shift: 1 if the Control key modifier was pressed, 0 otherwise # delta: delta field for the MouseWheel event. # repeat: 1 if a mouse button is double clicked, 0 if single clicked # Called when a Tk mouse motion event is triggered. # Helper binding: propagate the event as a VTK event. proc cb_vtkw_motion_binding {vtkw renwin x y} { set iren [$renwin GetInteractor] $iren SetEventPositionFlipY $x $y $iren MouseMoveEvent } # Called when a Tk button mouse event is triggered. # Helper binding: propagate the event as a VTK event. # event: button state, Press or Release # pos: position of the button, Left, Middle or Right proc cb_vtkw_button_binding {vtkw renwin x y ctrl shift event pos repeat} { set iren [$renwin GetInteractor] $iren SetEventPositionFlipY $x $y $iren SetControlKey $ctrl $iren SetShiftKey $shift $iren ${pos}Button${event}Event $iren SetRepeatCount $repeat } # Called when a Tk wheel motion event is triggered. # Helper binding: propagate the event as a VTK event. proc cb_vtkw_wheel_motion_binding {vtkw renwin delta} { set iren [$renwin GetInteractor] if {$delta < 0} { $iren MouseWheelBackwardEvent } else { $iren MouseWheelForwardEvent } } # Called when a Tk key event is triggered. # Helper binding: propagate the event as a VTK event (indeed, two). # event: key state, Press or Release # keycode: keycode field # keysym: keysym field proc cb_vtkw_key_binding {vtkw renwin x y ctrl shift event keycode keysym} { set iren [$renwin GetInteractor] # Not a bug, two times keysym, since 5th param expect a char, and # $keycode is %k, which is a number $iren SetEventInformationFlipY $x $y $ctrl $shift $keysym 0 $keysym $iren Key${event}Event if {$event == "Press"} { $iren SetEventInformationFlipY $x $y $ctrl $shift $keysym 0 $keysym $iren CharEvent } } # Called when a Tk Expose/Configure event is triggered. # Helper binding: propagate the event as a VTK event. proc cb_vtkw_configure_binding {vtkw renwin w h} { set iren [$renwin GetInteractor] $iren UpdateSize $w $h $iren ConfigureEvent } proc cb_vtkw_expose_binding {vtkw renwin x y w h} { set iren [$renwin GetInteractor] $iren SetEventPositionFlipY $x $y $iren SetEventSize $w $h $iren ExposeEvent } # Called when a Tk Enter/Leave event is triggered. # Helper binding: propagate the event as a VTK event. # Note that entering the widget automatically grabs the focus so # that key events can be processed. proc cb_vtkw_enter_binding {vtkw renwin x y} { focus $vtkw set iren [$renwin GetInteractor] $iren SetEventPositionFlipY $x $y $iren EnterEvent } proc cb_vtkw_leave_binding {vtkw renwin x y} { set iren [$renwin GetInteractor] $iren SetEventPositionFlipY $x $y $iren LeaveEvent } # Set the above bindings for a vtkTkRenderWidget widget. proc create_vtkw_bindings {vtkw renwin} { global tcl_platform # Find the render window (which creates it if it was not set). # Find the interactor, create a generic one if needed. if {[$renwin GetInteractor] == ""} { # the duh is critical in the follwing line, it causes # vtkTclUtil.cxx to know that the object was created in # a Tcl script, otherwise if ${renwin} was a return value # from a C++ function it would be called vtkTemp### and # the interactor instance would have the same name causeing Tcl # to think it also was a C++ return value. set iren [vtkGenericRenderWindowInteractor duh_${renwin}_iren] $iren SetRenderWindow $renwin $iren Initialize } # Mouse motion bind $vtkw "::vtk::cb_vtkw_motion_binding $vtkw $renwin %x %y" # Mouse buttons and key events foreach {modifier ctrl shift repeat} { "" 0 0 0 "Control-" 1 0 0 "Shift-" 0 1 0 "Control-Shift-" 1 1 0 "Double-" 0 0 1 "Double-Control-" 1 0 1 "Double-Shift-" 0 1 1 "Double-Control-Shift-" 1 1 1 } { foreach event { Press Release } { foreach {pos number} { Left 1 Middle 2 Right 3 } { bind $vtkw <${modifier}Button${event}-${number}> \ "::vtk::cb_vtkw_button_binding $vtkw $renwin %x %y $ctrl $shift $event $pos $repeat" } bind $vtkw <${modifier}Key${event}> \ "::vtk::cb_vtkw_key_binding $vtkw $renwin %x %y $ctrl $shift $event %k %K" } } # Wheel motion # Only x11 does not understand a mousewheel event # [tk windowingsystem] can be x11, win32, classic, aqua # Unfortunately this call only appear recently # so for now remove it # if {[tk windowingsystem] == "x11"} if {$tcl_platform(platform) == "unix"} { bind $vtkw \ "::vtk::cb_vtkw_wheel_motion_binding $vtkw $renwin 1" bind $vtkw \ "::vtk::cb_vtkw_wheel_motion_binding $vtkw $renwin -1" } else { bind $vtkw \ "::vtk::cb_vtkw_wheel_motion_binding $vtkw $renwin %D" } # Expose/Configure bind $vtkw \ "::vtk::cb_vtkw_configure_binding $vtkw $renwin %w %h" bind $vtkw \ "::vtk::cb_vtkw_expose_binding $vtkw $renwin %x %y %w %h" # Enter/Leave bind $vtkw \ "::vtk::cb_vtkw_enter_binding $vtkw $renwin %x %y" bind $vtkw \ "::vtk::cb_vtkw_leave_binding $vtkw $renwin %x %y" } # ------------------------------------------------------------------- # vtkRenderWindow callbacks/observers # renwin: render window object # AbortCheckEvent observer. # Check if some events are pending, and abort render in that case proc cb_renwin_abort_check_event {renwin} { if {[$renwin GetEventPending] != 0} { $renwin SetAbortRender 1 } } # Add the above observers to a vtkRenderWindow proc add_renwin_observers {renwin} { # Check for aborting rendering ::vtk::set_widget_variable_value $renwin AbortCheckEventTag \ [$renwin AddObserver AbortCheckEvent \ [list ::vtk::cb_renwin_abort_check_event $renwin]] } # ------------------------------------------------------------------- # vtk(Generic)RenderWindowInteractor callbacks/observers # iren: interactor object # CreateTimerEvent/DestroyTimerEvent obversers. # Handle the creation of a timer event (10 ms) proc cb_iren_create_timer_event {iren} { set timer [after 10 "$iren TimerEvent"] ::vtk::set_widget_variable_value $iren CreateTimerEventTimer $timer } proc cb_iren_destroy_timer_event {iren} { set timer \ [::vtk::get_widget_variable_value $iren CreateTimerEventTimer] if {$timer != ""} { after cancel $timer } } # UserEvent obverser. # Popup the vtkInteract widget (simple wish-like console) proc cb_iren_user_event {} { wm deiconify .vtkInteract } # ConfigureEvent obverser. # This event is triggered when the widget is re-configured, i.e. its # size is changed. Note that for every ConfigureEvent an ExposeEvent is # triggered too and the corresponding observer will re-render the window. # It might be nice to switch the frame update rate to an interactive # update rate while the window is getting resized, so that the user can # experience a decent feedback. This is achieved by launching a timer # each time the ConfigureEvent is triggered. This timer lasts 300 ms. When # the ExposeEvent observer is called, it checks if this timer still exists. # If it is the case, it implies that the user is configuring/resizing the # window and that an interactive frame rate may be used. If it is not, # it uses the still update rate to render the scene with full details. # The timer itself is a call to the ExposeEvent observer, which will # finaly render the window using a still update rate. proc cb_iren_configure_event {iren} { # Cancel the previous timer if any set timer [::vtk::get_widget_variable_value $iren ConfigureEventTimer] if {$timer != ""} { after cancel $timer } ::vtk::set_widget_variable_value $iren ConfigureEventTimer \ [after 300 [list ::vtk::cb_iren_expose_event $iren]] } # ExposeEvent obverser. # This event is triggered when a part (or all) of the widget is exposed, # i.e. a new area is visible. It usually happens when the widget window # is brought to the front, or when the widget is resized. # See above for explanations about the update rate tricks. proc cb_iren_expose_event {iren} { set renwin [$iren GetRenderWindow] # Check if a ConfigureEvent timer is pending set timer [::vtk::get_widget_variable_value $iren ConfigureEventTimer] if {$timer != ""} { if {[catch {after info $timer}]} { ::vtk::unset_widget_variable $iren ConfigureEventTimer $renwin SetDesiredUpdateRate [$iren GetStillUpdateRate] } else { $renwin SetDesiredUpdateRate [$iren GetDesiredUpdateRate] } } update $renwin Render } # ExitEvent obverser. # Destroy all VTK objects (therefore, try not to call this function # directly from a VTK object), then exit. proc cb_exit {} { vtkCommand DeleteAllObjects exit } proc cb_iren_exit_event {} { ::vtk::cb_exit } # Add the above observers to a vtk(Generic)RenderWindowInteractor proc add_iren_observers {iren} { # Timer events ::vtk::set_widget_variable_value $iren CreateTimerEventTag \ [$iren AddObserver CreateTimerEvent \ [list ::vtk::cb_iren_create_timer_event $iren]] ::vtk::set_widget_variable_value $iren DestroyTimerEventTag \ [$iren AddObserver DestroyTimerEvent \ [list ::vtk::cb_iren_destroy_timer_event $iren]] # User Tk interactor ::vtk::set_widget_variable_value $iren UserEventTag \ [$iren AddObserver UserEvent \ [list ::vtk::cb_iren_user_event]] # Expose and Configure ::vtk::set_widget_variable_value $iren ConfigureEventTag \ [$iren AddObserver ConfigureEvent \ [list ::vtk::cb_iren_configure_event $iren]] ::vtk::set_widget_variable_value $iren ExposeEventTag \ [$iren AddObserver ExposeEvent \ [list ::vtk::cb_iren_expose_event $iren]] # Exit # Since the callback is likely to delete all VTK objects # using vtkCommand::DeleteAllObject, let's try not to call it from # the object itself. Use a timer. ::vtk::set_widget_variable_value $iren ExitEventTag \ [$iren AddObserver ExitEvent \ "after 100 [list ::vtk::cb_iren_exit_event]"] } # ------------------------------------------------------------------- # Create vtkTk(ImageViewer/Render)Widget bindings, setup observers proc bind_tk_widget {vtkw renwin} { create_vtkw_bindings $vtkw $renwin add_renwin_observers $renwin add_iren_observers [$renwin GetInteractor] } }