+++ /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 / aubio.git / commitdiff