ref: 9610f0a0f4ab689d8474963862ea8d7849b52de8
dir: /plugins/wavesurfer/aubio.plug/
# -*-Mode:Tcl-*- # # Copyright (C) 2000-2004 Jonas Beskow and Kare Sjolander # # This file is part of the WaveSurfer package. # The latest version can be found at http://www.speech.kth.se/wavesurfer/ # # ----------------------------------------------------------------------------- wsurf::RegisterPlugin transcription \ -description "This plug-in is used to create transcription panes. Use the\ properties-dialog to specify which transcription file that should be\ displayed in a pane. It is usually practical to create a special\ configuration for a certain combination of sound and transcription\ files, specifying file properties such as filename extension, format,\ file path, and encoding. There are\ many options to control appearance and\ editing functionality. Depending on the transcription file format\ additional options might be available. There is a special pop-up menu\ with functions to edit, play, convert and search labels. Unicode\ characters are supported if using the source version of WaveSurfer,\ in order to keep the binary versions small. The transcription plug-in is\ used in combination with format handler plug-ins which handle\ the conversion between file formats and the internal format\ used by the transcription plug-in." \ -url "http://www.speech.kth.se/wavesurfer/" \ -addmenuentriesproc trans::addMenuEntries \ -widgetcreatedproc trans::widgetCreated \ -widgetdeletedproc trans::widgetDeleted \ -panecreatedproc trans::paneCreated \ -panedeletedproc trans::paneDeleted \ -redrawproc trans::redraw \ -getboundsproc trans::getBounds \ -cursormovedproc trans::cursorMoved \ -printproc trans::print \ -propertiespageproc trans::propertyPane \ -applypropertiesproc trans::applyProperties \ -getconfigurationproc trans::getConfiguration \ -openfileproc trans::openFile \ -savefileproc trans::saveFile \ -needsaveproc trans::needSave \ -cutproc trans::cut \ -copyproc trans::copy \ -pasteproc trans::paste \ -stateproc trans::state \ -playproc trans::play \ -stopproc trans::stop \ -registercallbackproc trans::regCallback \ -soundchangedproc trans::soundChanged # ----------------------------------------------------------------------------- namespace eval trans { variable Info set Info(path) "" } # ----------------------------------------------------------------------------- proc trans::addMenuEntries {w pane m hook x y} { if {[string match query $hook]} { upvar [namespace current]::${pane}::var v if {[info exists v(drawTranscription)]} { if {$v(drawTranscription)} { return 1 } } return 0 } if {[string match main $hook]} { upvar [namespace current]::${pane}::var v if {[info exists v(drawTranscription)]} { if {$v(drawTranscription)} { for {set j 0} {$j < $v(menuNcols)} {incr j } { for {set i 0} {$i < $v(menuNrows)} {incr i } { if {$i==0} {set cb 1} else {set cb 0} $m add command -label [subst $v($i$j)] -columnbreak $cb \ -command [namespace code [list InsertLabel $w $pane $x $y \ [subst $v($i$j)]]] \ -font $v(font) } } $m add command -label "Onsets Detection ..." \ -command [namespace code [list getComputeAubioOnset $w $pane]] $m add command -label "Play Label" -columnbreak 1 \ -command [namespace code [list PlayLabel $w $pane $x $y]] $m add command -label "Insert Label" \ -command [namespace code [list InsertLabel $w $pane $x $y]] $m add command -label "Select Label" \ -command [namespace code [list SelectLabel $w $pane $x $y]] $m add command -label "Align Label" \ -command [namespace code [list AlignLabel $w $pane $x $y]] $m add command -label "Browse..." \ -command [namespace code [list browse $w $pane]] $m add command -label "Delete Label" \ -command [namespace code [list DeleteLabel $w $pane $x $y]] #$m add separator $m add command -label "Convert..." \ -command [namespace code [list convert $w $pane]] $m add command -label "Load Transcription..." \ -command [namespace code [list getOpenTranscriptionFile $w $pane]] $m add command -label "Load Text Labels..." \ -command [namespace code [list getOpenTextLabelFile $w $pane]] $m add command -label "Save Transcriptions" \ -command [namespace code [list saveTranscriptionFiles $w $pane]] $m add command -label "Save Transcription As..." \ -command [namespace code [list getSaveTranscriptionFile $w $pane]] $m add command -label "Split Sound on Labels" \ -command [namespace code [list SplitSoundFile $w $pane]] } } } if {[string match create $hook]} { $m.$hook add command -label "AubioTranscription" \ -command [namespace code [list createTranscription $w $pane]] } elseif {[string length $hook] == 0} { upvar [namespace current]::${pane}::var v if {[info exists v(drawTranscription)]} { if {$v(drawTranscription)} { } } } } proc trans::widgetCreated {w} { variable Info set Info($w,active) "" } proc trans::widgetDeleted {w} { variable Info foreach key [array names Info $w*] {unset Info($key)} } proc trans::paneCreated {w pane} { namespace eval [namespace current]::${pane} { variable var } upvar [namespace current]::${pane}::var v set v(drawTranscription) 0 # foreach otherpane [$w _getPanes] { # upvar wsurf::trans::${otherpane}::var ov # if {[info exists ov(extBounds)] && $ov(extBounds)} { # puts aaa # $w _redraw # } # } } proc trans::paneDeleted {w pane} { upvar [namespace current]::${pane}::var v foreach otherpane [$w _getPanes] { if {$pane == $otherpane} continue upvar wsurf::analysis::${otherpane}::var ov upvar wsurf::dataplot::${otherpane}::var dv if {$ov(drawWaveform) || $ov(drawSpectrogram) || $dv(drawDataPlot)} { set othercanvas [$otherpane canvas] if {[winfo exists $othercanvas]} { $othercanvas delete tran$pane } } } namespace delete [namespace current]::${pane} } proc trans::createTranscription {w pane} { set pane [$w addPane -before $pane -height 20 -closeenough 3 \ -minheight 20 -maxheight 20] addTranscription $w $pane } ### Add-ons from Paul Brossier <piem@altern.org> proc trans::getComputeAubioOnset {w pane} { set execFileName aubioonset #exec which $execFileName > /dev/null || echo "$execFileName not found in the path" # save selection to a file # (from wavesurfer.tcl : SaveSelection) set w [::wsurf::GetCurrent] BreakIfInvalid $w # select all set pane [lindex [$w _getPanes] 0] if {$pane != ""} { set length [$pane cget -maxtime] } else { set length [[$w cget -sound] length -unit seconds] } $w configure -selection [list 0.0 $length] # run on selection foreach {left right} [$w cget -selection] break if {$left == $right} return set s [$w cget -sound] set start [expr {int($left*[$s cget -rate])}] set end [expr {int($right*[$s cget -rate])}] set path [file dirname [$w getInfo fileName]] set tmpdir $::wsurf::Info(Prefs,tmpDir) set fileName "$tmpdir/wavesurfer-tmp-aubio.snd" set fileNameTxt "$tmpdir/wavesurfer-tmp-aubio.txt" set aubioThreshold 0.2 #[snack::getSaveFile -initialdir $path \ #-format $::surf(fileFormat)] #if {$fileName == ""} return $s write $fileName -start $start -end $end -progress progressCallback # system command : compute onsets exec aubioonset -i $fileName -t $aubioThreshold > $fileNameTxt 2> /dev/null # some ed hacks to put the .txt in .lab format # copy the times 3 times: 0.0000 0.0000 0.0000 exec echo -e "e $fileNameTxt\\n,s/\\(.*\\)/\\\\1 \\\\1 \\\\1/\\nwq" | ed 2> /dev/null # open the file as a labelfile openTranscriptionFile $w $pane $fileNameTxt labelfile # delete both files exec rm -f $fileName $fileNameTxt $w _redrawPane $pane } proc trans::getOpenTranscriptionFile {w pane} { variable Info upvar [namespace current]::${pane}::var v if {$v(changed)} { if {[string match no [tk_messageBox -message "You have unsaved changes.\nDo you really want to continue?" -type yesno -icon question]]} { return } } set file [file tail $v(fileName)] if {$Info(path) != ""} { set path $Info(path) } else { if {$v(labdir) == ""} { set path [file dirname $v(fileName)] } else { set path [file normalize [file dirname $v(fileName)]] set pathlist [file split $path] set path [eval file join [lreplace $pathlist end end $v(labdir)]] } } set fileName [tk_getOpenFile -title "Load Transcription" -initialfile $file \ -initialdir $path -defaultextension $v(labext)] if {$fileName == ""} return if {[string compare $path [file dirname $fileName]] != 0} { set Info(path) [file dirname $fileName] } openTranscriptionFile $w $pane $fileName labelfile $w _redrawPane $pane } proc trans::getOpenTextLabelFile {w pane} { variable Info upvar [namespace current]::${pane}::var v if {$v(changed)} { if {[string match no [tk_messageBox -message "You have unsaved changes.\nDo you really want to continue?" -type yesno -icon question]]} { return } } set file [file tail $v(fileName)] if {$Info(path) != ""} { set path $Info(path) } else { if {$v(labdir) == ""} { set path [file dirname $v(fileName)] } else { set path [file normalize [file dirname $v(fileName)]] set pathlist [file split $path] set path [eval file join [lreplace $pathlist end end $v(labdir)]] } } set fileName [tk_getOpenFile -title "Load Text Labels" -initialfile $file \ -initialdir $path -defaultextension $v(labext)] if {$fileName == ""} return if {[string compare $path [file dirname $fileName]] != 0} { set Info(path) [file dirname $fileName] } set f [open $fileName] fconfigure $f -encoding utf-8 set labels [split [read -nonewline $f]] close $f set start [expr 0.5 * [$pane cget -maxtime]] set delta [expr 0.5 * [$pane cget -maxtime] / [llength $labels]] set i 0 set v(t1,start) 0.0 foreach label $labels { set v(t1,$i,end) [expr {$start + $i * $delta}] set v(t1,$i,label) $label set v(t1,$i,rest) "" lappend map $i incr i } set v(t1,end) [$pane cget -maxtime] set v(nLabels) $i set v(map) $map set v(header) "" set v(headerFmt) WaveSurfer $w _redrawPane $pane } proc trans::saveTranscriptionFiles {w pane} { foreach pane [$w _getPanes] { upvar [namespace current]::${pane}::var v if {$v(drawTranscription) && $v(changed)} { saveTranscriptionFile $w $pane } } } proc trans::getSaveTranscriptionFile {w pane} { upvar [namespace current]::${pane}::var v set file [file tail $v(fileName)] if {$v(labdir) == ""} { set path [file dirname $v(fileName)] } else { set path [file normalize [file dirname $v(fileName)]] set pathlist [file split $path] set path [eval file join [lreplace $pathlist end end $v(labdir)]] } set fileName [tk_getSaveFile -title "Save Transcription" -initialfile $file \ -initialdir $path -defaultextension $v(labext)] if {$fileName == ""} return set v(fileName) $fileName set v(labext) [file extension $fileName] saveTranscriptionFile $w $pane } proc trans::addTranscription {w pane args} { variable Info upvar [namespace current]::${pane}::var v array set a [list \ -alignment e \ -labelcolor black \ -boundarycolor black \ -backgroundcolor white \ -extension ".lab" \ -font {Courier 8} \ -format WaveSurfer \ -labeldirectory "" \ -fileencoding "" \ -adjustleftevent Control-l \ -adjustrightevent Control-r \ -playlabelevent Control-space \ -labelmenu {2 7 lab1 lab2 lab3 lab4 lab5 lab6 lab7 lab8} \ -locked 0 \ -quickenter 1 \ -quickentertolerance 20 \ -extendboundaries 0 \ -linkboundaries 0 \ -playhighlight 0 \ ] if {[string match macintosh $::tcl_platform(platform)]} { set a(-labelmenuevent) Shift-ButtonPress-1 } else { set a(-labelmenuevent) Shift-ButtonPress-3 } if {[string match Darwin $::tcl_platform(os)]} { set a(-labelmenuevent) Shift-ButtonPress-1 set a(-labelmenu) {1 6 lab1 lab2 lab3 lab4 lab5 lab6} } if {[string match unix $::tcl_platform(platform)] } { set a(-font) {Courier 10} } array set a $args set v(alignment) $a(-alignment) set v(labColor) $a(-labelcolor) set v(bdColor) $a(-boundarycolor) set v(bgColor) $a(-backgroundcolor) set v(labext) .[string trim $a(-extension) .] set v(font) $a(-font) set v(format) $a(-format) set v(labdir) $a(-labeldirectory) set v(encoding) $a(-fileencoding) set v(menuNcols) [lindex $a(-labelmenu) 0] set v(menuNrows) [lindex $a(-labelmenu) 1] set v(labelMenuEvent) $a(-labelmenuevent) set v(adjustLeftEvent) $a(-adjustleftevent) set v(adjustRightEvent) $a(-adjustrightevent) set v(playLabelEvent) $a(-playlabelevent) set v(locked) $a(-locked) set v(quickenter) $a(-quickenter) set v(quicktol) $a(-quickentertolerance) set v(extBounds) $a(-extendboundaries) set v(linkBounds) $a(-linkboundaries) set v(highlight) $a(-playhighlight) set v(changed) 0 set v(t1,start) 0.0 set v(t1,end) 0.0 set v(nLabels) 0 set v(fileName) "" set v(lastPos) 0 set v(map) {} set v(lastmoved) -1 set v(drawTranscription) 1 set v(headerFmt) WaveSurfer set v(header) "" list { set v(lastTag) "" set v(hidden) "" } event add <<LabelMenuEvent>> <$v(labelMenuEvent)> event add <<AdjustLeftEvent>> <$v(adjustLeftEvent)> event add <<AdjustRightEvent>> <$v(adjustRightEvent)> event add <<PlayLabelEvent>> <$v(playLabelEvent)> for {set i 0} {$i < $v(menuNrows)} {incr i } { for {set j 0} {$j < $v(menuNcols)} {incr j } { set v($i$j) [lindex $a(-labelmenu) \ [expr {2 + $v(menuNcols) * $i + $j}]] } } set c [$pane canvas] list { foreach tag {text bg bound} { util::canvasbind $c $tag <<LabelMenuEvent>> \ [namespace code [list labelsMenu $w $pane %X %Y %x %y]] } } util::canvasbind $c bound <B1-Motion> \ [namespace code [list MoveBoundary $w $pane %x]] util::canvasbind $c bound <ButtonPress-1> "" bind $c <ButtonPress-2> \ [namespace code [list handleEvents PlayLabel %x %y]] $c bind bound <Enter> [list $c configure \ -cursor sb_h_double_arrow] $c bind bound <Leave> [list $c configure -cursor {}] $c bind text <Enter> [list $c configure -cursor xterm] $c bind text <Leave> [list $c configure -cursor {}] util::canvasbind $c text <B1-Motion> [namespace code \ [list textB1Move $w $pane %W %x %y]] util::canvasbind $c text <ButtonRelease-1> "" util::canvasbind $c text <ButtonPress-1> [namespace code \ [list textClick $w $pane %W %x %y]] util::canvasbind $c bg <ButtonPress-1> [namespace code \ [list boxClick $w $pane %W %x %y]] bind $c <Any-Key> [namespace code [list handleAnyKey $w $pane %W %x %y %A]] bind $c <BackSpace> [namespace code [list handleBackspace $w $pane %W]] bind $c <Return> { %W insert current insert "" %W focus {} } bind $c <Enter> [namespace code [list handleEnterLeave $w $pane 1]] bind $c <Leave> [namespace code [list handleEnterLeave $w $pane 0]] bind [winfo toplevel $c] <<AdjustRightEvent>> \ [namespace code [list handleEvents AdjustLabel %x %y right]] bind [winfo toplevel $c] <<AdjustLeftEvent>> \ [namespace code [list handleEvents AdjustLabel %x %y left]] util::canvasbind $c text <<AdjustRightEvent>> "" util::canvasbind $c text <<AdjustLeftEvent>> "" bind $c <<PlayLabelEvent>> \ [namespace code [list handleEvents PlayLabel %x %y]] bind [winfo toplevel $c] <<PlayLabelEvent>> \ [namespace code [list handleEvents PlayLabel %x %y]] bind $c <<Delete>> "[namespace code [list handleDelete $w $pane %W]];break" bind $c <space> "[namespace code [list handleSpace $w $pane %W]];break" bind $c <Shift-Control-space> "[namespace code [list FindNextLabel $w $pane]];break" $c bind text <Key-Right> [namespace code [list handleKeyRight $w $pane %W]] $c bind text <Key-Left> [namespace code [list handleKeyLeft $w $pane %W]] if {[$w getInfo fileName] != ""} { openTranscriptionFile $w $pane [$w getInfo fileName] soundfile # redraw $w $pane } if {$::tcl_version > 8.2} { if $v(locked) { $c configure -state disabled } else { $c configure -state normal } } # If the label file is longer than any current displayed pane, update them all if {[info exists v(t1,end)]} { if {$v(t1,end) > [$pane cget -maxtime]} { $w _redraw } } } proc trans::handleEvents {proc args} { if {![info exists ::trpane]} { return } if {[namespace which -variable \ [namespace current]::${::trpane}::var] == ""} return upvar [namespace current]::${::trpane}::var v if {[info exists v(cursorInPane)]} { if {$v(cursorInPane)} { eval $proc $::trw $::trpane $args } } } proc trans::handleEnterLeave {w pane arg} { upvar [namespace current]::${pane}::var v set v(cursorInPane) $arg } proc trans::activateInput {w pane state} { variable Info upvar [namespace current]::${pane}::var v if {[info exists Info($w,active)]} { if {$state == 1} { set Info($w,active) $pane [$pane yaxis] configure -relief solid [$pane canvas] configure -relief solid if {$v(extBounds)} { drawExtendedBoundaries $w $pane } } foreach p [$w _getPanes] { if {$state == 0 || [string compare $p $pane]} { if {[info exists v(drawTranscription)]} { if {$v(drawTranscription)} { [$p yaxis] configure -relief flat [$p canvas] configure -relief flat } } } } } } proc trans::state {w state} { variable Info if {[info exists Info($w,active)]} { if {$Info($w,active) != ""} { activateInput $w $Info($w,active) $state set c [$Info($w,active) canvas] if {$state} { boxClick $w $Info($w,active) $c 0 0 } } } } proc trans::labelsMenu {w pane X Y x y} { upvar [namespace current]::${pane}::var v set m $w.popup if {[winfo exists $m]} {destroy $m} menu $m -tearoff 0 $m add command -label "Play Label" \ -command [namespace code [list PlayLabel $w $pane $x $y]] $m add command -label "Insert Label" \ -command [namespace code [list InsertLabel $w $pane $x $y]] $m add command -label "Select Label" \ -command [namespace code [list SelectLabel $w $pane $x $y]] $m add command -label "Align Label" \ -command [namespace code [list AlignLabel $w $pane $x $y]] $m add command -label "Browse..." \ -command [namespace code [list browse $w $pane]] $m add command -label "Convert..." \ -command [namespace code [list convert $w $pane]] $m add separator $m add command -label "Delete Label" \ -command [namespace code [list DeleteLabel $w $pane $x $y]] for {set j 0} {$j < $v(menuNcols)} {incr j } { for {set i 0} {$i < $v(menuNrows)} {incr i } { if {$i==0} {set cb 1} else {set cb 0} $m add command -label [subst $v($i$j)] -columnbreak $cb \ -command [namespace code [list InsertLabel $w $pane $x $y \ [subst $v($i$j)]]] \ -font $v(font) } } if {[string match macintosh $::tcl_platform(platform)]} { tk_popup $w.popup $X $Y 0 } else { tk_popup $w.popup $X $Y } } proc trans::textClick {w pane W x y} { upvar [namespace current]::${pane}::var v set ::trpane $pane set ::trw $w set c [$pane canvas] focus $W $W focus current $W icursor current @[$W canvasx $x],[$W canvasy $y] $W select clear $W select from current @[$W canvasx $x],[$W canvasy $y] set tagno [lindex [$c gettags current] 0] activateInput $w $pane 1 set i [lsearch -exact $v(map) $tagno] if {$i == -1} return set start [GetStartByIndex $w $pane $i] set end $v(t1,$tagno,end) set len [expr $end - $start] $w messageProc \ "$v(t1,$tagno,label) ($tagno) start: $start end: $end length: $len" } proc trans::textB1Move {w pane W x y} { # clear widget selection before selecting any text foreach {start end} [$w cget -selection] break $w configure -selection [list $start $start] $W select to current @[$W canvasx $x],[$W canvasy $y] } proc trans::boxClick {w pane W x y} { upvar [namespace current]::${pane}::var v set ::trpane $pane set ::trw $w set c [$pane canvas] focus $W $W focus hidden set cx [$c canvasx $x] set t [$pane getTime $cx] $w configure -selection [list $t $t] activateInput $w $pane 1 set v(clicked) 1 } proc trans::handleAnyKey {w pane W x y A} { upvar [namespace current]::${pane}::var v if {[string length $A] == 0} return if {[string is print $A] == 0} return set c [$pane canvas] if {[$W focus] != $v(hidden)} { set tag [$W focus] catch {$W dchars $tag sel.first sel.last} $W insert $tag insert $A SetLabelText $w $pane [lindex [$c gettags $tag] 0] \ [$c itemcget $tag -text] } else { if {$v(quickenter) == 0} return set dx [expr {abs($v(lastPos) - $x)}] if {$v(quicktol) > $dx && $v(clicked) == 0} { set tagno $v(lastTag) append v(t1,$tagno,label) $A $c itemconf lab$v(lastTag) -text $v(t1,$tagno,label) } else { set v(lastTag) [InsertLabel $w $pane $x $y $A] if {$v(lastTag) == ""} return set v(lastPos) $x set v(clicked) 0 } } changed $w $pane } proc trans::handleDelete {w pane W} { set c [$pane canvas] if {[$W focus] != {}} { set tag [$W focus] if {![catch {$W dchars $tag sel.first sel.last}]} { return } $W dchars $tag insert SetLabelText $w $pane [lindex [$c gettags $tag] 0] \ [$c itemcget $tag -text] changed $w $pane } } proc trans::handleBackspace {w pane W} { set c [$pane canvas] if {[$W focus] != {}} { set tag [$W focus] if {![catch {$W dchars $tag sel.first sel.last}]} { return } set ind [expr {[$W index $tag insert]-1}] if {$ind >= 0} { $W icursor $tag $ind $W dchars $tag insert SetLabelText $w $pane [lindex [$c gettags $tag] 0] \ [$c itemcget $tag -text] changed $w $pane } } } proc trans::handleSpace {w pane W} { set c [$pane canvas] if {[$W focus] != {}} { $W select clear $W insert [$W focus] insert _ SetLabelText $w $pane [lindex [$c gettags [$W focus]] 0] \ [$c itemcget [$W focus] -text] } } proc trans::handleKeyRight {w pane W} { upvar [namespace current]::${pane}::var v set c [$pane canvas] set width [expr {[$pane cget -maxtime] * [$pane cget -pixelspersecond]}] if {[$W focus] != {}} { $W select clear set __index [$W index [$W focus] insert] $W icursor [$W focus] [expr {$__index + 1}] if {$__index == [$W index [$W focus] insert]} { set ti [lindex [$c gettags [$W focus]] 0] set i [lsearch -exact $v(map) $ti] set __focus [lindex $v(map) [expr {$i+1}]] $W focus lab$__focus $W icursor lab$__focus 0 while {$width * [lindex [$c xview] 1]-10 < \ [lindex [$W coords [$W focus]] 0] && [lindex [$c xview] 1] < 1} { $w xscroll scroll 1 unit } } } } proc trans::handleKeyLeft {w pane W} { upvar [namespace current]::${pane}::var v set c [$pane canvas] set width [expr {[$pane cget -maxtime] * [$pane cget -pixelspersecond]}] if {[$W focus] != {}} { $W select clear set __index [$W index [$W focus] insert] $W icursor [$W focus] [expr {[$W index [$W focus] insert] - 1}] if {$__index == [$W index [$W focus] insert]} { set ti [lindex [$c gettags [$W focus]] 0] set i [lsearch -exact $v(map) $ti] set __focus [lindex $v(map) [expr {$i-1}]] $W focus lab$__focus $W icursor lab$__focus end while {$width * [lindex [$c xview] 0] +10 > \ [lindex [$W coords [$W focus]] 0] && [lindex [$c xview] 0] > 0} { $w xscroll scroll -1 unit } } } } proc trans::openFile {w soundFileName} { variable Info foreach pane [$w _getPanes] { upvar [namespace current]::${pane}::var v if {$v(drawTranscription)} { openTranscriptionFile $w $pane [$w getInfo fileName] soundfile } } return 0 } proc trans::saveFile {w soundFileName} { foreach pane [$w _getPanes] { upvar [namespace current]::${pane}::var v if {$v(drawTranscription) && $v(changed)} { saveTranscriptionFile $w $pane } } return 0 } proc trans::openTranscriptionFile {w pane fn type} { variable Info upvar [namespace current]::${pane}::var v if {[info exists v(drawTranscription)]} { if {$v(drawTranscription) == 0} return } set fileName "" if {[string match soundfile $type]} { set path [file normalize [file dirname $fn]] set pathlist [file split $path] set rootname [file tail [file rootname $fn]] set name $rootname.[string trim $v(labext) .] # Try to locate the corresponding label file if {$v(labdir) != ""} { # Try the following directories in order # 1. try to locate file in specified label file directory # 2. try 'sound file path'/../'specified dir' # 3. look in current directory # 4. look in same directory as sound file if {[file readable [file join $v(labdir) $name]]} { set fileName [file join $v(labdir) $name] } elseif {[file readable [eval file join [lreplace $pathlist end end $v(labdir)] $name]]} { set fileName [eval file join [lreplace $pathlist end end $v(labdir)] $name] } } if {$fileName == ""} { if {[file readable $name]} { set fileName $name } elseif {[file readable [file join $path $name]]} { set fileName [file join $path $name] } else { set fileName $name } } } else { set fileName $fn } # This filename should be correct, remember it set v(fileName) $fileName set v(nLabels) 0 set v(map) {} set v(labext) [file extension $fileName] foreach {format loadProc saveProc} $Info(formats) { if {[string compare $format $v(format)] == 0} { set res [[namespace parent]::$loadProc $w $pane] if {$res != ""} { $w messageProc $res set v(changed) 0 return } } } } proc trans::saveTranscriptionFile {w pane} { variable Info upvar [namespace current]::${pane}::var v set fn $v(fileName) set strip_fn [file tail [file rootname $fn]] if {$strip_fn == ""} { set strip_fn [file tail [file rootname [$w getInfo fileName]]] } set path [file dirname $fn] set v(fileName) [file join $path $strip_fn.[string trim $v(labext) .]] set fn $v(fileName) catch {file copy $fn $fn~} foreach {format loadProc saveProc} $Info(formats) { if {[string compare $format $v(format)] == 0} { set res [[namespace parent]::$saveProc $w $pane] if {$res != ""} { $w messageProc $res return } } } set v(changed) 0 return 0 } proc trans::needSave {w pane} { upvar [namespace current]::${pane}::var v if {[info exists v(drawTranscription)]} { if {$v(drawTranscription)} { if {$v(changed)} { return 1 } } } return 0 } proc trans::redraw {w pane} { upvar [namespace current]::${pane}::var v if {!$v(drawTranscription)} return set c [$pane canvas] $c delete tran foreach otherpane [$w _getPanes] { upvar wsurf::analysis::${otherpane}::var ov upvar wsurf::dataplot::${otherpane}::var dv if {$ov(drawWaveform) || $ov(drawSpectrogram) || $dv(drawDataPlot)} { set othercanvas [$otherpane canvas] $othercanvas delete tran$pane } } _redraw $w $pane $c 0 0 # boxClick $w $pane $c 0 0 } proc trans::_redraw {w pane c x y} { upvar [namespace current]::${pane}::var v set progressproc [$w cget -progressproc] if {$progressproc != "" && $v(nLabels) > 0} { # $progressproc "Creating labels" 0.0 } set height [$pane cget -height] set v(height) $height set width [expr {[$pane cget -maxtime] * [$pane cget -pixelspersecond]}] set ascent [font metrics $v(font) -ascent] set v(ascent) $ascent $c configure -bg $v(bgColor) [$pane yaxis] delete ext set vc [$pane yaxis] set yw [winfo width $vc] if {$::tcl_version > 8.2 && [string match disabled [$c cget -state]]} { [$pane yaxis] create text [expr {$yw/2}] [expr {$height/2}] \ -text L:$v(labext) \ -font $v(font) -tags ext \ -fill $v(labColor) } else { [$pane yaxis] create text [expr {$yw/2}] [expr {$height/2}] \ -text $v(labext) \ -font $v(font) -tags ext \ -fill $v(labColor) } if {$v(nLabels) == 0} { set slen [[$w cget -sound] length -unit seconds] set endx [$pane getCanvasX $slen] $c create rectangle [expr {$x+0}] $y \ [expr {$x+$endx}] [expr {$y+$height-4}] -outline "" \ -tags [list gEnd obj bg tran] -fill $v(bgColor) set v(hidden) [$c create text [expr {$x-100}] [expr {$y+10}] \ -text "" -tags [list hidden tran]] return 0 } else { set start 0 set end 0 set label "" for {set i [expr $v(nLabels)-1]} {$i >= 0} {incr i -1} { set ind [lindex $v(map) $i] if {$i == 0} { set start $v(t1,start) } else { set ind2 [lindex $v(map) [expr {$i - 1}]] set start $v(t1,$ind2,end) } set end $v(t1,$ind,end) set label $v(t1,$ind,label) set lx [$pane getCanvasX $start] set rx [$pane getCanvasX $end] if {$lx >= 0 && $lx <= $width} { #DrawLabel $w $pane $c $ind $i $x $y $lx $rx $label set tx [ComputeTextPosition $w $pane $lx $rx] $c create rectangle [expr {$x+$lx}] $y \ [expr {$x+$rx}] [expr {$y+$height-4}] -outline "" \ -tags [list g$ind obj bg tran] -fill $v(bgColor) $c create text [expr {$x+$tx}] [expr {$y+$ascent}] -text $label\ -font $v(font) -anchor $v(alignment)\ -tags [list $ind obj text lab$ind tran] \ -fill $v(labColor) $c create line [expr {$x+$rx}] $y [expr {$x+$rx}] [expr {$y+$height}] \ -tags [list b$ind obj bound tran topmost] -fill $v(bdColor) } if {$progressproc != "" && $i % 100 == 99} { # $progressproc "Creating labels" [expr double($v(nLabels)-$i)/$v(nLabels)] } } set start $v(t1,start) set sx [$pane getCanvasX $start] $c create rectangle [expr {$x+0}] $y \ [expr {$x+$sx}] [expr {$y+$height-4}] -outline "" \ -tags [list gStart obj bg tran] -fill $v(bgColor) $c create line [expr {$x+$sx}] $y [expr {$x+$sx}] [expr {$y+$height}] \ -tags [list bStart obj bound tran topmost] -fill $v(bdColor) set slen [[$w cget -sound] length -unit seconds] set endx [$pane getCanvasX $slen] $c create rectangle [expr {$x+$rx}] $y \ [expr {$x+$endx}] [expr {$y+$height-4}] -outline "" \ -tags [list gEnd obj bg tran] -fill $v(bgColor) set prev [lindex $v(map) end] $c lower gEnd g$prev } set v(hidden) [$c create text [expr {$x-100}] [expr {$y+10}] \ -text "" -tags [list hidden tran]] if {$v(extBounds)} { drawExtendedBoundaries $w $pane } if {$progressproc != ""} { # $progressproc "Creating labels" 1.0 } return $height } proc trans::drawExtendedBoundaries {w pane} { upvar [namespace current]::${pane}::var v foreach otherpane [$w _getPanes] { upvar wsurf::analysis::${otherpane}::var ov upvar wsurf::dataplot::${otherpane}::var dv if {$ov(drawWaveform) || $ov(drawSpectrogram) || $dv(drawDataPlot)} { set othercanvas [$otherpane canvas] $othercanvas delete tran$pane } } set height [$pane cget -height] set width [expr {[$pane cget -maxtime] * [$pane cget -pixelspersecond]}] if {$v(nLabels) > 0} { set start 0 set end 0 set label "" for {set i [expr $v(nLabels)-1]} {$i >= 0} {incr i -1} { set ind [lindex $v(map) $i] if {$i == 0} { set start $v(t1,start) } else { set ind2 [lindex $v(map) [expr {$i - 1}]] set start $v(t1,$ind2,end) } set end $v(t1,$ind,end) set label $v(t1,$ind,label) set lx [$pane getCanvasX $start] set rx [$pane getCanvasX $end] if {$lx >= 0 && $lx <= $width} { foreach otherpane [$w _getPanes] { upvar wsurf::analysis::${otherpane}::var av upvar wsurf::dataplot::${otherpane}::var dv if {$av(drawWaveform) || $av(drawSpectrogram) || $dv(drawDataPlot)} { set othercanvas [$otherpane canvas] set height [$otherpane cget -height] $othercanvas create line $rx 0 $rx \ $height -tags [list b$ind$pane obj bound tran$pane] \ -fill $v(bdColor) } } } } } } proc trans::DrawLabel {w pane c tagno i x y lx rx label} { upvar [namespace current]::${pane}::var v # set ascent [font metrics $v(font) -ascent] # set height [$pane cget -height] set ascent $v(ascent) set height $v(height) set tx [ComputeTextPosition $w $pane $lx $rx] $c create rectangle [expr {$x+$lx}] $y \ [expr {$x+$rx}] [expr {$y+$height-4}] -outline "" \ -tags [list g$tagno obj bg tran] -fill $v(bgColor) $c create text [expr {$x+$tx}] [expr {$y+$ascent}] -text $label\ -font $v(font) -anchor $v(alignment)\ -tags [list $tagno obj text lab$tagno tran] \ -fill $v(labColor) $c create line [expr {$x+$rx}] $y [expr {$x+$rx}] [expr {$y+$height}] \ -tags [list b$tagno obj bound tran topmost] -fill $v(bdColor) if {$i > 0} { set prev [lindex $v(map) [expr {$i-1}]] $c lower g$tagno g$prev $c lower lab$tagno g$prev $c lower b$tagno g$prev } else { $c lower g$tagno gStart $c lower lab$tagno gStart $c lower b$tagno gStart } if {$v(extBounds)} { foreach otherpane [$w _getPanes] { upvar wsurf::analysis::${otherpane}::var av upvar wsurf::dataplot::${otherpane}::var dv if {$av(drawWaveform) || $av(drawSpectrogram) || $dv(drawDataPlot)} { set othercanvas [$otherpane canvas] set height [$otherpane cget -height] $othercanvas create line $rx 0 $rx \ $height -tags [list b$tagno obj bound tran$pane] -fill $v(bdColor) } } } } proc trans::isLabel {tags} { expr [string compare [lindex $tags 2] bg] == 0 || \ [string compare [lindex $tags 2] text] == 0 } proc trans::GetStartByIndex {w pane i} { upvar [namespace current]::${pane}::var v if {$i <= 0 || $i == "Start"} { return $v(t1,start) } else { set ind [lindex $v(map) [expr $i-1]] return $v(t1,$ind,end) } } proc trans::PlaceLabel {w pane tagno coords start end} { upvar [namespace current]::${pane}::var v set c [$pane canvas] if {$tagno != "Start"} { # Place background and boundary $c coords b$tagno $end [lindex $coords 1] $end [lindex $coords 3] $c coords g$tagno $start [lindex $coords 1] $end [expr [lindex $coords 3]-4] # Place label text set tx [ComputeTextPosition $w $pane $start $end] $c coords lab$tagno $tx [lindex [$c coords lab$tagno] 1] } else { $c coords b$tagno $end [lindex $coords 1] $end [lindex $coords 3] $c coords g$tagno 0 [lindex $coords 1] $end [expr [lindex $coords 3]-4] } if {$v(extBounds)} { foreach otherpane [$w _getPanes] { upvar wsurf::analysis::${otherpane}::var av upvar wsurf::dataplot::${otherpane}::var dv if {$av(drawWaveform) || $av(drawSpectrogram) || $dv(drawDataPlot)} { set othercanvas [$otherpane canvas] set height [$otherpane cget -height] $othercanvas coords b$tagno$pane $end 0 $end $height } } } } proc trans::getBounds {w pane} { upvar [namespace current]::${pane}::var v if {$v(drawTranscription)} { list 0 0 $v(t1,end) 0 } else { list } } proc trans::MoveBoundary {w pane x} { upvar [namespace current]::${pane}::var v set c [$pane canvas] set s [$w cget -sound] set coords [$c coords current] set xc [$c canvasx $x] if {$xc < 0} { set xc 0 } set tagno [string trim [lindex [$c gettags current] 0] b] set i [lsearch -exact $v(map) $tagno] # Logic which prevents a boundary to be moved past its neighbor set h [lindex $v(map) [expr {$i-1}]] set j [lindex $v(map) [expr {$i+1}]] set px 0 set nx [expr {[$pane cget -maxtime] * [$pane cget -pixelspersecond]}] set pb [$c find withtag b$h] set nb [$c find withtag b$j] if {$pb != ""} { set px [lindex [$c coords $pb] 0]} if {$nb != ""} { set nx [lindex [$c coords $nb] 0]} if {$xc <= $px} { set xc [expr {$px + 1}] } if {$nx <= $xc} { set xc [expr {$nx - 1}] } set start [$pane getCanvasX [GetStartByIndex $w $pane $i]] # Update time if {$i == -1} { set v(t1,start) [$pane getTime $xc] } else { set this [lindex $v(map) $i] set oldTime $v(t1,$this,end) set v(t1,$this,end) [$pane getTime $xc] } # Place this label PlaceLabel $w $pane $tagno $coords $start $xc # Place next label PlaceNextLabel $w $pane $i $xc if {$v(linkBounds)} { foreach otherpane [$w _getPanes] { upvar [namespace current]::${otherpane}::var ov if {$otherpane != $pane && $ov(drawTranscription) && \ [info exists oldTime]} { foreach tag $ov(map) { if {$ov(t1,$tag,end) == $oldTime} { set ov(t1,$tag,end) [$pane getTime $xc] PlaceLabel $w $otherpane $tag $coords $start $xc break } } } } } if {$v(lastmoved) != $i} { changed $w $pane if {$tagno == "Start"} { # wsurf::PrepareUndo "set [namespace current]::var(t1,start) \[list $v(t1,start)\]" "" } else { # wsurf::PrepareUndo "set [namespace current]::var(t1,$tagno,end) \[list $v(t1,$tagno,end)\]" "" } set v(lastmoved) $i } vtcanvas::motionEvent $pane $x 0 } proc trans::SetLabelText {w pane tagno label} { upvar [namespace current]::${pane}::var v $w messageProc [format "Transcription - %s" $label] set v(t1,$tagno,label) $label } proc trans::InsertLabel {w pane x y {label ""}} { upvar [namespace current]::${pane}::var v set s [$w cget -sound] set c [$pane canvas] set cx [$c canvasx $x] set t [$pane getTime $cx] set tags [$c gettags [$c find closest [$c canvasx $x] [$c canvasy $y]]] if {[isLabel $tags]} { set tagno [string trim [lindex $tags 0] g] if {$tagno == "End"} { # set i $v(nLabels) set i 0 foreach ind $v(map) { if {$t < $v(t1,$ind,end)} break incr i } } else { set i [lsearch -exact $v(map) $tagno] } } else { set i 0 foreach ind $v(map) { if {$t < $v(t1,$ind,end)} break incr i } } # Create label with a randomly chosen tag number set n [clock clicks] set v(t1,$n,end) $t set v(t1,$n,label) $label set v(t1,$n,rest) "" set v(map) [linsert $v(map) $i $n] incr v(nLabels) # Update start time if new label was inserted first if {$i < 0} { set v(t1,start) 0 set co [$c coords bStart] $c coords bStart 0 [lindex $co 1] 0 [lindex $co 3] set co [$c coords gStart] $c coords gStart 0 [lindex $co 1] 0 [lindex $co 3] set start 0 } else { set start [$pane getCanvasX [GetStartByIndex $w $pane $i]] } # Draw inserted label DrawLabel $w $pane $c $n $i 0 0 $start $cx $label # Place next label if {$i < 0} { incr i } PlaceNextLabel $w $pane $i $cx # Display cursor if label is empty if {$label==""} { focus [$pane canvas] [$pane canvas] focus lab$n [$pane canvas] icursor lab$n @[$c canvasx $x],[$c canvasy $y] } changed $w $pane return $n } proc trans::DeleteLabel {w pane x y} { upvar [namespace current]::${pane}::var v set c [$pane canvas] set tags [$c gettags [$c find closest [$c canvasx $x] [$c canvasy $y]]] if {[isLabel $tags] || [string compare [lindex $tags 2] bound] == 0} { set tagno [string trim [lindex $tags 0] gb] set i [lsearch -exact $v(map) $tagno] if {$i == -1} return # Delete everything related to this label unset v(t1,$tagno,label) unset v(t1,$tagno,end) unset v(t1,$tagno,rest) set v(map) [lreplace $v(map) $i $i] incr v(nLabels) -1 $c delete b$tagno lab$tagno g$tagno if {$v(extBounds)} { foreach otherpane [$w _getPanes] { upvar wsurf::analysis::${otherpane}::var av upvar wsurf::dataplot::${otherpane}::var dv if {$av(drawWaveform) || $av(drawSpectrogram) || $dv(drawDataPlot)} { set othercanvas [$otherpane canvas] $othercanvas delete b$tagno$pane } } } # Place previous label box set prev [lindex $v(map) [expr {$i-1}]] if {$prev != ""} { set end [lindex [$c coords g$prev] 2] } else { set end [$pane getCanvasX $v(t1,start)] set prev 0 } set iprev [lsearch -exact $v(map) $prev] PlaceNextLabel $w $pane $iprev $end changed $w $pane } } proc trans::AdjustLabel {w pane x y boundary} { upvar [namespace current]::${pane}::var v set c [$pane canvas] set xc [$c canvasx $x] set t [$pane getTime $xc] set tags [$c gettags [$c find closest $xc [$c canvasy $y]]] if {[isLabel $tags]} { set tagno [string trim [lindex $tags 0] g] set i [lsearch -exact $v(map) $tagno] } else { set i 0 foreach ind $v(map) { if {$t < $v(t1,$ind,end)} break incr i } set tagno [lsearch -exact $v(map) $i] } if {$i == $v(nLabels)} return if {$tagno != "End" && [string match left $boundary]} { incr i -1 set tagno [lindex $v(map) $i] } if {$tagno == "End"} return if {$tagno != ""} { set v(t1,$tagno,end) $t } if {$i < 0} { set v(t1,start) $t set co [$c coords bStart] set sx [$pane getCanvasX $t] $c coords bStart $sx [lindex $co 1] $sx [lindex $co 3] $c coords gStart 0 [lindex $co 1] $sx [lindex $co 3] } set start [$pane getCanvasX [GetStartByIndex $w $pane $i]] # Place this label set co [$c coords b$tagno] PlaceLabel $w $pane $tagno $co $start $xc # Place next label PlaceNextLabel $w $pane $i $xc changed $w $pane $w messageProc [format "Transcription - %s" [$w formatTime $t]] } proc trans::PlayLabel {w pane x y} { upvar [namespace current]::${pane}::var v set c [$pane canvas] set tags [$c gettags [$c find closest [$c canvasx $x] [$c canvasy $y]]] if {[isLabel $tags]} { set tagno [string trim [lindex $tags 0] g] set i [lsearch -exact $v(map) $tagno] if {$i == -1} return } else { set i 0 set cx [$c canvasx $x] set t [$pane getTime $cx] foreach ind $v(map) { if {$t < $v(t1,$ind,end)} break incr i } } set start [GetStartByIndex $w $pane $i] set this [lindex $v(map) $i] if {$this == ""} return set end $v(t1,$this,end) $w play $start $end } proc trans::SelectLabel {w pane x y} { upvar [namespace current]::${pane}::var v set c [$pane canvas] set tags [$c gettags [$c find closest [$c canvasx $x] [$c canvasy $y]]] if {[isLabel $tags]} { set tagno [string trim [lindex $tags 0] g] set i [lsearch -exact $v(map) $tagno] if {$i == -1} return set start [GetStartByIndex $w $pane $i] set end $v(t1,$tagno,end) $w configure -selection [list $start $end] } } proc trans::AlignLabel {w pane x y} { upvar [namespace current]::${pane}::var v set c [$pane canvas] set tags [$c gettags [$c find closest [$c canvasx $x] [$c canvasy $y]]] if {[isLabel $tags]} { set tagno [string trim [lindex $tags 0] g] set i [lsearch -exact $v(map) $tagno] if {$i == -1} return # Get current selection foreach {start end} [$w cget -selection] break if {$start == $end} return # Validate that selection and label overlap, otherwise generate warning msg set ostart [GetStartByIndex $w $pane $i] set oend $v(t1,$tagno,end) if {$start >= $oend || $end <= $ostart} { tk_messageBox -message "Label and selection must overlap!" return } # Update boundaries according to current selection if {$i == 0} { set v(t1,start) $start } else { set ind [lindex $v(map) [expr $i-1]] set v(t1,$ind,end) $start } set v(t1,$tagno,end) $end $w _redrawPane $pane } } proc trans::FindNextLabel {w pane} { upvar [namespace current]::${pane}::var v foreach {start end} [$w cget -selection] break set i 0 foreach ind $v(map) { if {$end < $v(t1,$ind,end)} break incr i } set tagno [lsearch -exact $v(map) $i] if {$tagno == -1} return set start [GetStartByIndex $w $pane $i] set end $v(t1,$tagno,end) $w configure -selection [list $start $end] set s [$w cget -sound] set length [$s length -unit seconds] $w xscroll moveto [expr {($start-1.0)/$length}] $w play $start $end set delay [expr 500 + int(1000 * ($end - $start))] after $delay [namespace code [list FindNextLabel $w $pane]] } proc trans::ComputeTextPosition {w pane start end} { upvar [namespace current]::${pane}::var v if {$v(alignment) == "c"} { return [expr {($start+$end)/2}] } elseif {$v(alignment) == "w"} { return [expr {$start + 2}] } else { return [expr {$end - 2}] } } proc trans::PlaceNextLabel {w pane index pos} { upvar [namespace current]::${pane}::var v set c [$pane canvas] incr index set next [lindex $v(map) $index] if {$next == ""} { set next End set co [$c coords g$next] $c coords g$next $pos [lindex $co 1] [lindex $co 2] [lindex $co 3] } else { set co [$c coords b$next] $c coords g$next $pos [lindex $co 1] [lindex $co 2] [expr [lindex $co 3]-4] # $c itemconf g$next -fill yellow set xc [ComputeTextPosition $w $pane $pos [lindex $co 2]] $c coords lab$next $xc [lindex [$c coords lab$next] 1] } } proc trans::print {w pane c x y} { upvar [namespace current]::${pane}::var v upvar wsurf::analysis::${pane}::var ov upvar wsurf::dataplot::${pane}::var dv if {$ov(drawWaveform) || $ov(drawSpectrogram) || $dv(drawDataPlot)} { foreach otherpane [$w _getPanes] { upvar wsurf::trans::${otherpane}::var tv if {[info exists tv(extBounds)] && $tv(extBounds)} { set drawExtBounds 1 break; } } } if {[info exists drawExtBounds]} { set height [$pane cget -height] set width [expr {[$pane cget -maxtime] * [$pane cget -pixelspersecond]}] set yAxisCanvas [$pane yaxis] set yAxisWidth [winfo width $yAxisCanvas] if {$tv(nLabels) > 0} { set start 0 set end 0 set label "" for {set i [expr $tv(nLabels)-1]} {$i >= 0} {incr i -1} { set ind [lindex $tv(map) $i] if {$i == 0} { set start $tv(t1,start) } else { set ind2 [lindex $tv(map) [expr {$i - 1}]] set start $tv(t1,$ind2,end) } set end $tv(t1,$ind,end) set label $tv(t1,$ind,label) set lx [$pane getCanvasX $start] set rx [$pane getCanvasX $end] if {$lx >= 0 && $lx <= $width} { $c create line [expr {$rx+$yAxisWidth}] $y \ [expr {$rx+$yAxisWidth}] [expr {$y+$height}] \ -tags [list b$ind$pane obj bound tran$pane print tmpPrint] \ -fill $tv(bdColor) } } } } if {!$v(drawTranscription)} return $c raise bound set yAxisCanvas [$pane yaxis] set yAxisWidth [winfo width $yAxisCanvas] set h [$pane cget -height] set width [expr {[$pane cget -maxtime] * [$pane cget -pixelspersecond]}] $c create rectangle $yAxisWidth $y \ [expr {$x+$width+$yAxisWidth}] [expr {$y+$h}] \ -tags print -outline black _redraw $w $pane $c $yAxisWidth $y } proc trans::cursorMoved {w pane time value} { upvar [namespace current]::${pane}::var v if {$v(drawTranscription)} { $w messageProc \ [format "%s: %s | $v(labelMenuEvent): Label menu" $v(fileName) [$w formatTime $time]] } } proc trans::soundChanged {w flag} { set s [$w cget -sound] foreach pane [$w _getPanes] { upvar [namespace current]::${pane}::var v if {$v(drawTranscription)} { $w _redrawPane $pane } } } proc trans::propertyPane {w pane} { if {$pane==""} return upvar [namespace current]::${pane}::var v if {$v(drawTranscription)} { list Trans1 [namespace code drawPage1] \ Trans2 [namespace code drawPage2] } } proc trans::applyProperties {w pane} { if {[string match *wavebar $pane]} return variable Info upvar [namespace current]::${pane}::var v if {[info exists v(drawTranscription)]} { if {$v(drawTranscription)} { foreach var {format alignment labext labdir encoding \ labColor bdColor bgColor \ font menuNrows menuNcols labelMenuEvent adjustLeftEvent \ adjustRightEvent playLabelEvent locked quickenter quicktol \ extBounds linkBounds highlight} { if {[string compare $v(t,$var) $v($var)] !=0} { if [string match labelMenuEvent $var] { event delete <<LabelMenuEvent>> <$v($var)> event add <<LabelMenuEvent>> <$v(t,$var)> } if [string match adjustLeftEvent $var] { event delete <<AdjustLeftEvent>> <$v($var)> event add <<AdjustLeftEvent>> <$v(t,$var)> } if [string match adjustRightEvent $var] { event delete <<AdjustRightEvent>> <$v($var)> event add <<AdjustRightEvent>> <$v(t,$var)> } if [string match playLabelEvent $var] { event delete <<PlayLabelEvent>> <$v($var)> event add <<PlayLabelEvent>> <$v(t,$var)> } if {$::tcl_version > 8.2 && [string match locked $var] == 1} { set c [$pane canvas] if $v(t,$var) { $c configure -state disabled } else { $c configure -state normal } } if {[string match format $var] || \ [string match labext $var] || \ [string match encoding $var] || \ [string match labdir $var]} { if {$v(changed)} { if {[string match no [tk_messageBox -message "This operation will cause the transcription to be re-read from disk and you have unsaved changes.\nDo you want to continue?" -type yesno -icon question]]} { return } } set v($var) $v(t,$var) openTranscriptionFile $w $pane [$w getInfo fileName] soundfile set doRedraw 1 } set v($var) $v(t,$var) if {[string match labColor $var] || \ [string match bdColor $var] || \ [string match font $var] || \ [string match extBounds $var] || \ [string match alignment $var] || \ [string match bgColor $var]} { set doRedraw 1 } if {[string match format $var]} { set formatChanged 1 } } } if {[info exists doRedraw]} { $w _redrawPane $pane } if {[info exists formatChanged]} { wsurf::_remeberPropertyPage $w $pane wsurf::_drawPropertyPages $w $pane } for {set i 0} {$i < $v(menuNrows)} {incr i } { for {set j 0} {$j < $v(menuNcols)} {incr j } { set v($i$j) $v(t,$i$j) } } } } } proc trans::drawPage1 {w pane path} { variable Info upvar [namespace current]::${pane}::var v foreach f [winfo children $path] { destroy $f } foreach var {format alignment labext labdir encoding \ labColor bdColor bgColor \ font locked quickenter quicktol extBounds linkBounds} { set v(t,$var) $v($var) } pack [frame $path.f1] -anchor w label $path.f1.l -text "Label file format:" -width 25 -anchor w foreach {format loadProc saveProc} $Info(formats) { lappend tmp $format } eval tk_optionMenu $path.f1.om [namespace current]::${pane}::var(t,format) \ $tmp pack $path.f1.l $path.f1.om -side left -padx 3 pack [frame $path.f2] -anchor w label $path.f2.l -text "Label alignment:" -width 25 -anchor w tk_optionMenu $path.f2.om [namespace current]::${pane}::var(t,alignment) \ left center right $path.f2.om.menu entryconfigure 0 -value w $path.f2.om.menu entryconfigure 1 -value c $path.f2.om.menu entryconfigure 2 -value e pack $path.f2.l $path.f2.om -side left -padx 3 stringPropItem $path.f3 "Label filename extension:" 25 16 "" \ [namespace current]::${pane}::var(t,labext) pack [frame $path.f4] -anchor w label $path.f4.l -text "Label file path:" -width 25 -anchor w entry $path.f4.e -textvar [namespace current]::${pane}::var(t,labdir) -wi 16 pack $path.f4.l $path.f4.e -side left -padx 3 if {[info command tk_chooseDirectory] != ""} { button $path.f4.b -text Choose... \ -command [namespace code [list chooseDirectory $w $pane]] pack $path.f4.b -side left -padx 3 } stringPropItem $path.f5 "Label file encoding:" 25 16 "" \ [namespace current]::${pane}::var(t,encoding) colorPropItem $path.f6 "Label color:" 25 \ [namespace current]::${pane}::var(t,labColor) colorPropItem $path.f7 "Boundary color:" 25 \ [namespace current]::${pane}::var(t,bdColor) colorPropItem $path.f8 "Background color:" 25 \ [namespace current]::${pane}::var(t,bgColor) stringPropItem $path.f9 "Font:" 25 16 "" \ [namespace current]::${pane}::var(t,font) if {$::tcl_version > 8.2} { booleanPropItem $path.f10 "Lock transcription" "" \ [namespace current]::${pane}::var(t,locked) } booleanPropItem $path.f11 "Quick transcribe" "" \ [namespace current]::${pane}::var(t,quickenter) stringPropItem $path.f12 "Max cursor movement for current label:" 34 4 \ pixels [namespace current]::${pane}::var(t,quicktol) booleanPropItem $path.f13 "Extend boundaries into waveform and spectrogram panes" "" \ [namespace current]::${pane}::var(t,extBounds) booleanPropItem $path.f14 "Move coinciding boundaries in other transcription panes" "" \ [namespace current]::${pane}::var(t,linkBounds) } proc trans::confPage {w pane path} { upvar [namespace current]::${pane}::var v for {set i 0} {$i < $v(t,menuNrows)} {incr i } { if {![winfo exists $path.fl$i]} { pack [frame $path.fl$i] -anchor w } for {set j 0} {$j < $v(t,menuNcols)} {incr j } { if {![winfo exists $path.fl$i.e$j]} { pack [entry $path.fl$i.e$j -width 6 \ -textvar [namespace current]::${pane}::var(t,$i$j)] -side left } $path.fl$i.e$j configure -font $v(t,font) } while {[winfo exists $path.fl$i.e$j] == 1} { destroy $path.fl$i.e$j incr j } } while {[winfo exists $path.fl$i] == 1} { destroy $path.fl$i incr i } } proc trans::chooseDirectory {w pane} { upvar [namespace current]::${pane}::var v set dir $v(t,labdir) if {$dir == ""} { set dir . } set res [tk_chooseDirectory -initialdir $dir -mustexist yes] if {$res != ""} { set v(t,labdir) $res } } proc trans::drawPage2 {w pane path} { upvar [namespace current]::${pane}::var v foreach f [winfo children $path] { destroy $f } foreach var {adjustLeftEvent adjustRightEvent playLabelEvent labelMenuEvent \ menuNrows menuNcols highlight} { set v(t,$var) $v($var) } for {set i 0} {$i < $v(menuNrows)} {incr i } { for {set j 0} {$j < $v(menuNcols)} {incr j } { set v(t,$i$j) $v($i$j) } } booleanPropItem $path.f0 "Highlight labels during playback" "" \ [namespace current]::${pane}::var(t,highlight) stringPropItem $path.f1 "Adjust left boundary event:" 28 25 "" \ [namespace current]::${pane}::var(t,adjustLeftEvent) stringPropItem $path.f2 "Adjust right boundary event:" 28 25 "" \ [namespace current]::${pane}::var(t,adjustRightEvent) stringPropItem $path.f3 "Play label event:" 28 25 "" \ [namespace current]::${pane}::var(t,playLabelEvent) stringPropItem $path.f4 "Label menu event:" 28 25 "" \ [namespace current]::${pane}::var(t,labelMenuEvent) pack [frame $path.f5] -anchor w pack [label $path.f5.l -text "Label menu pane:" -width 25 -anchor w] -padx 3 pack [frame $path.f6] -anchor w pack [label $path.f6.lc -text "Columns:" -anchor w] -side left -padx 3 pack [entry $path.f6.ec -width 2 -textvar \ [namespace current]::${pane}::var(t,menuNcols)] -side left pack [label $path.f6.lr -text "Rows:" -anchor w] -side left pack [entry $path.f6.er -width 2 -textvar \ [namespace current]::${pane}::var(t,menuNrows)] -side left pack [button $path.f6.b -text Update \ -command [namespace code [list confPage $w $pane $path]]] -side left \ -padx 3 bind $path.f6.ec <Key-Return> [namespace code [list confPage $w $pane $path]] bind $path.f6.er <Key-Return> [namespace code [list confPage $w $pane $path]] for {set i 0} {$i < $v(t,menuNrows)} {incr i } { pack [frame $path.fl$i] -anchor w for {set j 0} {$j < $v(t,menuNcols)} {incr j } { pack [entry $path.fl$i.e$j -font $v(t,font) \ -textvar [namespace current]::${pane}::var(t,$i$j) -wi 6] \ -side left } } } proc trans::getConfiguration {w pane} { upvar [namespace current]::${pane}::var v set result {} if {$pane==""} {return {}} if {$v(drawTranscription)} { lappend labmenu $v(menuNcols) $v(menuNrows) for {set i 0} {$i < $v(menuNrows)} {incr i } { for {set j 0} {$j < $v(menuNcols)} {incr j } { if {[info exists v($i$j)]} { lappend labmenu $v($i$j) } else { lappend labmenu \"\" } } } append result "\$widget trans::addTranscription \$pane\ -alignment $v(alignment)\ -format \"$v(format)\"\ -extension \"$v(labext)\"\ -labelcolor $v(labColor)\ -boundarycolor $v(bdColor)\ -backgroundcolor $v(bgColor)\ -labeldirectory \"$v(labdir)\"\ -fileencoding \"$v(encoding)\"\ -labelmenuevent $v(labelMenuEvent)\ -adjustleftevent $v(adjustLeftEvent)\ -adjustrightevent $v(adjustRightEvent)\ -playlabelevent $v(playLabelEvent)\ -locked $v(locked)\ -quickenter $v(quickenter)\ -quickentertolerance $v(quicktol)\ -extendboundaries $v(extBounds)\ -linkboundaries $v(linkBounds)\ -playhighlight $v(highlight)\ -font \{$v(font)\}" append result " -labelmenu \{\n" append result "[lrange $labmenu 0 1]\n" for {set i 0} {$i < $v(menuNrows)} {incr i } { append result "[lrange $labmenu [expr 2+$i*$v(menuNcols)] [expr 1+($i+1)*$v(menuNcols)]]\n" } append result "\}" append result "\n" } return $result } proc trans::cut {w t0 t1} { set dt [expr {$t1-$t0}] foreach pane [$w _getPanes] { upvar [namespace current]::${pane}::var v if $v(drawTranscription) { if {[llength $v(map)] == 0} continue set c [$pane canvas] set i 0 foreach ind $v(map) { if {$t0 < $v(t1,$ind,end)} break incr i } # Adjust start time if {$t0 < $v(t1,start)} { if {$t1 < $v(t1,start)} { # Current selection is to the left of start time set v(t1,start) [expr {$v(t1,start)-$dt}] } else { # Left boundary of current selection is to the left of start time set v(t1,start) $t0 } } # Left boundary is new end time for first label if {$t0 < $v(t1,$ind,end) && \ $t1 > $v(t1,$ind,end)} { set v(t1,$ind,end) $t0 incr i set ind [lindex $v(map) $i] } set j $i # Delete labels within the selection while {$ind != "" && $t1 > $v(t1,$ind,end)} { # unset v(t1,$ind,label) # unset v(t1,$ind,end) # unset v(t1,$ind,rest) incr i set ind [lindex $v(map) $i] } if {$j <= [expr $i - 1] && $j < [llength $v(map)]} { set v(map) [lreplace $v(map) $j [expr $i - 1]] set v(nLabels) [llength $v(map)] } # Move all remaining labels $dt to the left set ind [lindex $v(map) $j] while {$ind != "" && $t1 < $v(t1,$ind,end)} { set v(t1,$ind,end) [expr {$v(t1,$ind,end)-$dt}] incr j set ind [lindex $v(map) $j] } changed $w $pane $w _redrawPane $pane } } } proc trans::copy {w t0 t1} { foreach pane [$w _getPanes] { upvar [namespace current]::${pane}::var v if $v(drawTranscription) { set c [$pane canvas] if {[$c focus] != {}} { set tag [$c focus] if {[catch {set s [$c index $tag sel.first]}]} return set e [$c index $tag sel.last] clipboard append [string range [$c itemcget $tag -text] $s $e] } } } } proc trans::paste {w t length} { foreach pane [$w _getPanes] { upvar [namespace current]::${pane}::var v if $v(drawTranscription) { set c [$pane canvas] if {[focus] == $c && [$c focus] != $v(hidden)} { catch {set cbText [selection get -selection CLIPBOARD]} if {[info exists cbText] == 0} { return 0 } $c insert [$c focus] insert [selection get -selection CLIPBOARD] SetLabelText $w $pane [lindex [$c gettags [$c focus]] 0] \ [$c itemcget [$c focus] -text] return 1 } } } return 0 list { foreach pane [$w _getPanes] { upvar [namespace current]::${pane}::var v if $v(drawTranscription) { if {[llength $v(map)] == 0} return set i 0 foreach ind $v(map) { if {$t < $v(t1,$ind,end)} break incr i } # Adjust start time if {$t < $v(t1,start)} { set v(t1,start) [expr {$v(t1,start)+$length}] } # Move all remaining labels $length to the left while {$ind != ""} { set v(t1,$ind,end) [expr {$v(t1,$ind,end)+$length}] incr i set ind [lindex $v(map) $i] } $w _redrawPane $pane } }} } proc trans::find {w pane} { upvar [namespace current]::${pane}::var v set p $v(browseTL) set v(nMatch) 0 $p.f2.list delete 0 end set i 0 if {$v(matchCase)} { set nocase "" } else { set nocase -nocase } foreach ind $v(map) { if {[eval regexp $nocase $v(pattern) \{$v(t1,$ind,label)\}]} { if {$i == 0} { set start $v(t1,start) } else { set prev [lindex $v(map) [expr $i-1]] set start $v(t1,$prev,end) } if {[string match *\"* \{$v(t1,$ind,label)\}]} { set tmp "\{$v(t1,$ind,label):\} $start $v(t1,$ind,end)" } else { set tmp "$v(t1,$ind,label): $start $v(t1,$ind,end)" } $p.f2.list insert end $tmp incr v(nMatch) } incr i } } proc trans::select {w pane} { upvar [namespace current]::${pane}::var v set p $v(browseTL) set cursel [$p.f2.list curselection] if {$cursel == ""} return set start [lindex [$p.f2.list get [lindex $cursel 0]] end-1] set end [lindex [$p.f2.list get [lindex $cursel end]] end] $w configure -selection [list $start $end] set s [$w cget -sound] set length [$s length -unit seconds] $w xscroll moveto [expr {$start/$length}] } proc trans::findPlay {w pane} { upvar [namespace current]::${pane}::var v set p $v(browseTL) set cursel [$p.f2.list curselection] if {$cursel != ""} { set start [lindex [$p.f2.list get [lindex $cursel 0]] end-1] set end [lindex [$p.f2.list get [lindex $cursel end]] end] $w play $start $end } } proc trans::browse {w pane} { upvar [namespace current]::${pane}::var v regsub -all {\.} $pane _ tmp set v(browseTL) .browse$tmp catch {destroy .browse$tmp} set p [toplevel .browse$tmp] wm title $p "Browse Labels" pack [frame $p.f] pack [entry $p.f.e -textvar [namespace current]::${pane}::var(pattern)]\ -side left pack [button $p.f.l -text Find \ -command [namespace code [list find $w $pane]]] -side left pack [ label $p.l -text "Results:"] pack [ frame $p.f2] -fill both -expand true pack [ scrollbar $p.f2.scroll -command "$p.f2.list yview"] -side right \ -fill y listbox $p.f2.list -yscroll "$p.f2.scroll set" -setgrid 1 \ -selectmode extended -height 6 -width 40 pack $p.f2.list -side left -expand true -fill both pack [checkbutton $p.cb -text "Match case" -anchor w \ -variable [namespace current]::${pane}::var(matchCase)] pack [ frame $p.f3] -pady 10 -fill x -expand true pack [ button $p.f3.b1 -bitmap snackPlay \ -command [namespace code [list findPlay $w $pane]]] \ -side left pack [ button $p.f3.b2 -bitmap snackStop -command "$w stop"] -side left pack [ button $p.f3.b3 -text Close -command "destroy $p"] -side right bind $p.f.e <Return> [namespace code [list find $w $pane]] bind $p.f2.list <ButtonRelease-1> [namespace code [list select $w $pane]] if {$v(pattern) != ""} { find $w $pane } bind $p.f2.list <Double-Button-1> [namespace code [list findPlay $w $pane]] focus $p.f.e } proc trans::convert {w pane} { upvar [namespace current]::${pane}::var v variable Info regsub -all {\.} $pane _ tmp set v(convertTL) .convert$tmp catch {destroy .convert$tmp} set p [toplevel .convert$tmp] wm title $p "Convert Transcription File format" pack [ label $p.l1 -text "Current transcription file format: $v(format)"] set v(t,format) $v(format) pack [frame $p.f1] -anchor w label $p.f1.l -text "New transcription file format:" -anchor w foreach {format loadProc saveProc} $Info(formats) { lappend fmtlist $format } eval tk_optionMenu $p.f1.om [namespace current]::${pane}::var(t,format) \ $fmtlist pack $p.f1.l $p.f1.om -side left -padx 3 pack [frame $p.f] pack [ button $p.f.b1 -text OK -command [namespace code [list doConvert $w $pane]]\n[list destroy $p]] -side left -padx 3 pack [ button $p.f.b2 -text Close -command "destroy $p"] -side left -padx 3 } proc trans::doConvert {w pane} { upvar [namespace current]::${pane}::var v set v(format) $v(t,format) } proc trans::play {w} { foreach pane [$w _getPanes] { upvar [namespace current]::${pane}::var v if {$v(drawTranscription) && $v(highlight)} { set v(playIndex) 0 } } after 200 [namespace code [list _updatePlay $w]] } proc trans::stop {w} { foreach pane [$w _getPanes] { upvar [namespace current]::${pane}::var v set c [$pane canvas] if {$v(drawTranscription)} { after cancel [namespace code [list FindNextLabel $w $pane]] } } } proc trans::_updatePlay {w} { if {[winfo exists $w] == 0} { return } if {[$w getInfo isPlaying] == 0} { foreach pane [$w _getPanes] { upvar [namespace current]::${pane}::var v set c [$pane canvas] if {$v(drawTranscription)} { if {$v(highlight) && [info exists v(playIndex)]} { set ind [lindex $v(map) $v(playIndex)] if {$ind != ""} { $c itemconf g$ind -fill $v(bgColor) } } } } return } set s [$w cget -sound] foreach pane [$w _getPanes] { upvar [namespace current]::${pane}::var v if {$v(drawTranscription) && $v(highlight)} { set cursorpos [$pane cget -cursorpos] set c [$pane canvas] set ind [lindex $v(map) $v(playIndex)] if {$ind != ""} { $c itemconf g$ind -fill $v(bgColor) while (1) { set ind [lindex $v(map) $v(playIndex)] if {$ind == ""} return if {$cursorpos < $v(t1,$ind,end)} break incr v(playIndex) } $c itemconf g$ind -fill [$w cget -cursorcolor] } } } if {[$w getInfo isPlaying]} { after 50 [namespace code [list _updatePlay $w]] } } # ----------------------------------------------------------------------------- # !!! experimental proc trans::regCallback {name callback script} { variable Info # puts [info level 0] if {$callback != "-transcription::transcriptionchangedproc"} { error "unknown callback \"$callback\"" } else { set Info(Callback,$name,transChangedProc) $script } } proc trans::changed {w pane} { # puts [info level 0]([info level -1]) variable Info upvar [namespace current]::${pane}::var v set v(changed) 1 foreach key [array names Info Callback,*,transChangedProc] { puts "invoking callback $key" $Info($key) $w $pane } } proc trans::SplitSoundFile {w pane} { upvar [namespace current]::${pane}::var v set s [$w cget -sound] foreach ind $v(map) { set start [expr {int([GetStartByIndex $w $pane $ind] * [$s cget -rate])}] set end [expr {int($v(t1,$ind,end) * [$s cget -rate])}] $s write $v(t1,$ind,label).wav -start $start -end $end } }