--- /dev/null
+# -*-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
+ }
+}
projects / wavesurfer-aubio.git / commitdiff