ref: 04d50b073a752a4d6a4e854d35c8a08a77b21c8c
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
}
}