plugins/wavesurfer/aubio.plug

   1 # -*-Mode:Tcl-*-
   2 #
   3 #  Copyright (C) 2000-2004 Jonas Beskow and Kare Sjolander
   4 #
   5 # This file is part of the WaveSurfer package.
   6 # The latest version can be found at http://www.speech.kth.se/wavesurfer/
   7 #
   8 # -----------------------------------------------------------------------------
   9
  10 wsurf::RegisterPlugin transcription \
  11   -description "This plug-in is used to create transcription panes. Use the\
  12   properties-dialog to specify which transcription file that should be\
  13   displayed in a pane. It is usually practical to create a special\
  14   configuration for a certain combination of sound and transcription\
  15   files, specifying file properties such as filename extension, format,\
  16   file path, and encoding. There are\
  17   many options to control appearance and\
  18   editing functionality. Depending on the transcription file format\
  19   additional options might be available. There is a special pop-up menu\
  20   with functions to edit, play, convert and search labels. Unicode\
  21   characters are supported if using the source version of WaveSurfer,\
  22   in order to keep the binary versions small. The transcription plug-in is\
  23   used in combination with format handler plug-ins which handle\
  24   the conversion between file formats and the internal format\
  25   used by the transcription plug-in." \
  26   -url "http://www.speech.kth.se/wavesurfer/" \
  27   -addmenuentriesproc   trans::addMenuEntries \
  28   -widgetcreatedproc    trans::widgetCreated \
  29   -widgetdeletedproc    trans::widgetDeleted \
  30   -panecreatedproc      trans::paneCreated \
  31   -panedeletedproc      trans::paneDeleted \
  32   -redrawproc           trans::redraw \
  33   -getboundsproc        trans::getBounds \
  34   -cursormovedproc      trans::cursorMoved \
  35   -printproc            trans::print \
  36   -propertiespageproc   trans::propertyPane \
  37   -applypropertiesproc  trans::applyProperties \
  38   -getconfigurationproc trans::getConfiguration \
  39   -openfileproc         trans::openFile \
  40   -savefileproc         trans::saveFile \
  41   -needsaveproc         trans::needSave \
  42   -cutproc              trans::cut \
  43   -copyproc             trans::copy \
  44   -pasteproc            trans::paste \
  45   -stateproc            trans::state \
  46   -playproc             trans::play \
  47   -stopproc             trans::stop \
  48   -registercallbackproc trans::regCallback \
  49   -soundchangedproc     trans::soundChanged
  50
  51 # -----------------------------------------------------------------------------
  52
  53 namespace eval trans {
  54  variable Info
  55
  56  set Info(path) ""
  57 }
  58
  59 # -----------------------------------------------------------------------------
  60
  61 proc trans::addMenuEntries {w pane m hook x y} {
  62  if {[string match query $hook]} {
  63   upvar [namespace current]::${pane}::var v
  64   if {[info exists v(drawTranscription)]} {
  65    if {$v(drawTranscription)} {
  66     return 1
  67    }
  68   }
  69   return 0
  70  }
  71  if {[string match main $hook]} {
  72   upvar [namespace current]::${pane}::var v
  73   if {[info exists v(drawTranscription)]} {
  74    if {$v(drawTranscription)} {
  75
  76     for {set j 0} {$j < $v(menuNcols)} {incr j } {
  77      for {set i 0} {$i < $v(menuNrows)} {incr i } {
  78       if {$i==0} {set cb 1} else {set cb 0}
  79       $m add command -label [subst $v($i$j)] -columnbreak $cb \
  80         -command [namespace code [list InsertLabel $w $pane $x $y \
  81         [subst $v($i$j)]]] \
  82         -font $v(font)
  83      }
  84     }
  85
  86     $m add command -label "Onsets Detection ..." \
  87       -command [namespace code [list getComputeAubioOnset $w $pane]]
  88     $m add command -label "Play Label" -columnbreak 1 \
  89       -command [namespace code [list PlayLabel $w $pane $x $y]]
  90     $m add command -label "Insert Label" \
  91       -command [namespace code [list InsertLabel $w $pane $x $y]]
  92     $m add command -label "Select Label" \
  93       -command [namespace code [list SelectLabel $w $pane $x $y]]
  94     $m add command -label "Align Label" \
  95       -command [namespace code [list AlignLabel $w $pane $x $y]]
  96     $m add command -label "Browse..." \
  97       -command [namespace code [list browse $w $pane]]
  98     $m add command -label "Delete Label" \
  99       -command [namespace code [list DeleteLabel $w $pane $x $y]]
 100     #$m add separator
 101     $m add command -label "Convert..." \
 102       -command [namespace code [list convert $w $pane]]
 103     $m add command -label "Load Transcription..." \
 104       -command [namespace code [list getOpenTranscriptionFile $w $pane]]
 105     $m add command -label "Load Text Labels..." \
 106       -command [namespace code [list getOpenTextLabelFile $w $pane]]
 107     $m add command -label "Save Transcriptions" \
 108       -command [namespace code [list saveTranscriptionFiles $w $pane]]
 109     $m add command -label "Save Transcription As..." \
 110       -command [namespace code [list getSaveTranscriptionFile $w $pane]]
 111     $m add command -label "Split Sound on Labels" \
 112         -command [namespace code [list SplitSoundFile $w $pane]]
 113    }
 114   }
 115  }
 116
 117
 118  if {[string match create $hook]} {
 119   $m.$hook add command -label "AubioTranscription" \
 120     -command [namespace code [list createTranscription $w $pane]]
 121  } elseif {[string length $hook] == 0} {
 122   upvar [namespace current]::${pane}::var v
 123   if {[info exists v(drawTranscription)]} {
 124    if {$v(drawTranscription)} {
 125    }
 126   }
 127  }
 128 }
 129
 130 proc trans::widgetCreated {w} {
 131  variable Info
 132  set Info($w,active) ""
 133 }
 134
 135 proc trans::widgetDeleted {w} {
 136  variable Info
 137  foreach key [array names Info $w*] {unset Info($key)}
 138 }
 139
 140 proc trans::paneCreated {w pane} {
 141  namespace eval [namespace current]::${pane} {
 142   variable var
 143  }
 144  upvar [namespace current]::${pane}::var v
 145  set v(drawTranscription) 0
 146
 147 # foreach otherpane [$w _getPanes] {
 148 #  upvar wsurf::trans::${otherpane}::var ov
 149 #  if {[info exists ov(extBounds)] && $ov(extBounds)} {
 150 #   puts aaa
 151 #   $w _redraw
 152 #  }
 153 # }
 154 }
 155
 156 proc trans::paneDeleted {w pane} {
 157  upvar [namespace current]::${pane}::var v
 158
 159  foreach otherpane [$w _getPanes] {
 160   if {$pane == $otherpane} continue
 161   upvar wsurf::analysis::${otherpane}::var ov
 162   upvar wsurf::dataplot::${otherpane}::var dv
 163   if {$ov(drawWaveform) || $ov(drawSpectrogram) || $dv(drawDataPlot)} {
 164    set othercanvas [$otherpane canvas]
 165    if {[winfo exists $othercanvas]} {
 166     $othercanvas delete tran$pane
 167    }
 168   }
 169  }
 170  namespace delete [namespace current]::${pane}
 171 }
 172
 173 proc trans::createTranscription {w pane} {
 174  set pane [$w addPane -before $pane -height 20 -closeenough 3 \
 175    -minheight 20 -maxheight 20]
 176  addTranscription $w $pane
 177 }
 178
 179 ### Add-ons from Paul Brossier <piem@altern.org>
 180
 181
 182 proc trans::getComputeAubioOnset {w pane} {
 183  set execFileName aubioonset
 184  #exec which $execFileName > /dev/null || echo "$execFileName not found in the path"
 185  # save selection to a file
 186  # (from wavesurfer.tcl : SaveSelection)
 187  set w [::wsurf::GetCurrent]
 188  BreakIfInvalid $w
 189
 190  # select all
 191  set pane [lindex [$w _getPanes] 0]
 192  if {$pane != ""} {
 193   set length [$pane cget -maxtime]
 194  } else {
 195   set length [[$w cget -sound] length -unit seconds]
 196  }
 197  $w configure -selection [list 0.0 $length]
 198
 199  # run on selection
 200  foreach {left right} [$w cget -selection] break
 201  if {$left == $right} return
 202  set s [$w cget -sound]
 203  set start [expr {int($left*[$s cget -rate])}]
 204  set end   [expr {int($right*[$s cget -rate])}]
 205  set path [file dirname [$w getInfo fileName]]
 206
 207  set tmpdir      $::wsurf::Info(Prefs,tmpDir)
 208  set fileName    "$tmpdir/wavesurfer-tmp-aubio.snd"
 209  set fileNameTxt "$tmpdir/wavesurfer-tmp-aubio.txt"
 210  set aubioThreshold 0.2
 211         #[snack::getSaveFile -initialdir $path \
 212      #-format $::surf(fileFormat)]
 213  #if {$fileName == ""} return
 214  $s write $fileName -start $start -end $end -progress progressCallback
 215
 216  # system command : compute onsets
 217  exec aubioonset -i $fileName -t $aubioThreshold > $fileNameTxt 2> /dev/null
 218  # some ed hacks to put the .txt in .lab format
 219  # copy the times 3 times: 0.0000 0.0000 0.0000
 220  exec echo -e "e $fileNameTxt\\n,s/\\(.*\\)/\\\\1 \\\\1 \\\\1/\\nwq" | ed 2> /dev/null
 221
 222  # open the file as a labelfile
 223  openTranscriptionFile $w $pane $fileNameTxt labelfile
 224  # delete both files
 225  exec rm -f $fileName $fileNameTxt
 226  $w _redrawPane $pane
 227 }
 228
 229 proc trans::getOpenTranscriptionFile {w pane} {
 230  variable Info
 231  upvar [namespace current]::${pane}::var v
 232
 233  if {$v(changed)} {
 234   if {[string match no [tk_messageBox -message "You have unsaved changes.\nDo you really want to continue?" -type yesno -icon question]]} {
 235    return
 236   }
 237  }
 238  set file [file tail $v(fileName)]
 239  if {$Info(path) != ""} {
 240   set path $Info(path)
 241  } else {
 242   if {$v(labdir) == ""} {
 243    set path [file dirname $v(fileName)]
 244   } else {
 245    set path [file normalize [file dirname $v(fileName)]]
 246    set pathlist [file split $path]
 247    set path [eval file join [lreplace $pathlist end end $v(labdir)]]
 248   }
 249  }
 250  set fileName [tk_getOpenFile -title "Load Transcription" -initialfile $file \
 251    -initialdir $path -defaultextension $v(labext)]
 252  if {$fileName == ""} return
 253
 254  if {[string compare $path [file dirname $fileName]] != 0} {
 255   set Info(path) [file dirname $fileName]
 256  }
 257
 258  openTranscriptionFile $w $pane $fileName labelfile
 259  $w _redrawPane $pane
 260 }
 261
 262 proc trans::getOpenTextLabelFile {w pane} {
 263  variable Info
 264  upvar [namespace current]::${pane}::var v
 265
 266  if {$v(changed)} {
 267   if {[string match no [tk_messageBox -message "You have unsaved changes.\nDo you really want to continue?" -type yesno -icon question]]} {
 268    return
 269   }
 270  }
 271  set file [file tail $v(fileName)]
 272  if {$Info(path) != ""} {
 273   set path $Info(path)
 274  } else {
 275   if {$v(labdir) == ""} {
 276    set path [file dirname $v(fileName)]
 277   } else {
 278    set path [file normalize [file dirname $v(fileName)]]
 279    set pathlist [file split $path]
 280    set path [eval file join [lreplace $pathlist end end $v(labdir)]]
 281   }
 282  }
 283  set fileName [tk_getOpenFile -title "Load Text Labels" -initialfile $file \
 284    -initialdir $path -defaultextension $v(labext)]
 285  if {$fileName == ""} return
 286
 287  if {[string compare $path [file dirname $fileName]] != 0} {
 288   set Info(path) [file dirname $fileName]
 289  }
 290
 291  set f [open $fileName]
 292  fconfigure $f -encoding utf-8
 293  set labels [split [read -nonewline $f]]
 294  close $f
 295
 296
 297  set start [expr 0.5 * [$pane cget -maxtime]]
 298  set delta [expr 0.5 * [$pane cget -maxtime] / [llength $labels]]
 299  set i 0
 300  set v(t1,start) 0.0
 301  foreach label $labels {
 302   set v(t1,$i,end)   [expr {$start + $i * $delta}]
 303   set v(t1,$i,label) $label
 304   set v(t1,$i,rest)  ""
 305   lappend map $i
 306   incr i
 307  }
 308  set v(t1,end)  [$pane cget -maxtime]
 309  set v(nLabels) $i
 310  set v(map)     $map
 311  set v(header)  ""
 312  set v(headerFmt) WaveSurfer
 313
 314  $w _redrawPane $pane
 315 }
 316
 317 proc trans::saveTranscriptionFiles {w pane} {
 318  foreach pane [$w _getPanes] {
 319   upvar [namespace current]::${pane}::var v
 320   if {$v(drawTranscription) && $v(changed)} {
 321    saveTranscriptionFile $w $pane
 322   }
 323  }
 324 }
 325
 326 proc trans::getSaveTranscriptionFile {w pane} {
 327  upvar [namespace current]::${pane}::var v
 328
 329  set file [file tail $v(fileName)]
 330  if {$v(labdir) == ""} {
 331   set path [file dirname $v(fileName)]
 332  } else {
 333   set path [file normalize [file dirname $v(fileName)]]
 334   set pathlist [file split $path]
 335   set path [eval file join [lreplace $pathlist end end $v(labdir)]]
 336  }
 337
 338  set fileName [tk_getSaveFile -title "Save Transcription" -initialfile $file \
 339    -initialdir $path -defaultextension $v(labext)]
 340  if {$fileName == ""} return
 341
 342  set v(fileName) $fileName
 343  set v(labext) [file extension $fileName]
 344
 345  saveTranscriptionFile $w $pane
 346 }
 347
 348 proc trans::addTranscription {w pane args} {
 349  variable Info
 350  upvar [namespace current]::${pane}::var v
 351
 352  array set a [list \
 353    -alignment e \
 354    -labelcolor black \
 355    -boundarycolor black \
 356    -backgroundcolor white \
 357    -extension ".lab" \
 358    -font {Courier 8} \
 359    -format WaveSurfer \
 360    -labeldirectory "" \
 361    -fileencoding "" \
 362    -adjustleftevent Control-l \
 363    -adjustrightevent Control-r \
 364    -playlabelevent Control-space \
 365    -labelmenu {2 7 lab1 lab2 lab3 lab4 lab5 lab6 lab7 lab8} \
 366    -locked 0 \
 367    -quickenter 1 \
 368    -quickentertolerance 20 \
 369    -extendboundaries 0 \
 370    -linkboundaries 0 \
 371    -playhighlight 0 \
 372    ]
 373  if {[string match macintosh $::tcl_platform(platform)]} {
 374   set a(-labelmenuevent) Shift-ButtonPress-1
 375  } else {
 376   set a(-labelmenuevent) Shift-ButtonPress-3
 377  }
 378  if {[string match Darwin $::tcl_platform(os)]} {
 379   set a(-labelmenuevent) Shift-ButtonPress-1
 380   set a(-labelmenu) {1 6 lab1 lab2 lab3 lab4 lab5 lab6}
 381  }
 382  if {[string match unix $::tcl_platform(platform)] } {
 383   set a(-font) {Courier 10}
 384  }
 385  array set a $args
 386
 387  set v(alignment)         $a(-alignment)
 388  set v(labColor)          $a(-labelcolor)
 389  set v(bdColor)           $a(-boundarycolor)
 390  set v(bgColor)           $a(-backgroundcolor)
 391  set v(labext)            .[string trim $a(-extension) .]
 392  set v(font)              $a(-font)
 393  set v(format)            $a(-format)
 394  set v(labdir)            $a(-labeldirectory)
 395  set v(encoding)          $a(-fileencoding)
 396  set v(menuNcols)         [lindex $a(-labelmenu) 0]
 397  set v(menuNrows)         [lindex $a(-labelmenu) 1]
 398  set v(labelMenuEvent)    $a(-labelmenuevent)
 399  set v(adjustLeftEvent)   $a(-adjustleftevent)
 400  set v(adjustRightEvent)  $a(-adjustrightevent)
 401  set v(playLabelEvent)    $a(-playlabelevent)
 402  set v(locked)            $a(-locked)
 403  set v(quickenter)        $a(-quickenter)
 404  set v(quicktol)          $a(-quickentertolerance)
 405  set v(extBounds)         $a(-extendboundaries)
 406  set v(linkBounds)        $a(-linkboundaries)
 407  set v(highlight)         $a(-playhighlight)
 408  set v(changed)           0
 409  set v(t1,start)          0.0
 410  set v(t1,end)            0.0
 411  set v(nLabels)           0
 412  set v(fileName)          ""
 413  set v(lastPos)           0
 414  set v(map)               {}
 415  set v(lastmoved)         -1
 416  set v(drawTranscription) 1
 417  set v(headerFmt) WaveSurfer
 418  set v(header) ""
 419  list {
 420   set v(lastTag) ""
 421   set v(hidden) ""
 422  }
 423  event add <<LabelMenuEvent>>   <$v(labelMenuEvent)>
 424  event add <<AdjustLeftEvent>>  <$v(adjustLeftEvent)>
 425  event add <<AdjustRightEvent>> <$v(adjustRightEvent)>
 426  event add <<PlayLabelEvent>>   <$v(playLabelEvent)>
 427
 428  for {set i 0} {$i < $v(menuNrows)} {incr i } {
 429   for {set j 0} {$j < $v(menuNcols)} {incr j } {
 430    set v($i$j) [lindex $a(-labelmenu) \
 431      [expr {2 + $v(menuNcols) * $i + $j}]]
 432   }
 433  }
 434
 435  set c [$pane canvas]
 436 list {
 437  foreach tag {text bg bound} {
 438   util::canvasbind $c $tag <<LabelMenuEvent>> \
 439     [namespace code [list labelsMenu $w $pane %X %Y %x %y]]
 440  }
 441 }
 442  util::canvasbind $c bound <B1-Motion> \
 443    [namespace code [list MoveBoundary $w $pane %x]]
 444  util::canvasbind $c bound <ButtonPress-1> ""
 445
 446  bind $c <ButtonPress-2> \
 447      [namespace code [list handleEvents PlayLabel %x %y]]
 448
 449  $c bind bound <Enter> [list $c configure \
 450    -cursor sb_h_double_arrow]
 451  $c bind bound <Leave> [list $c configure -cursor {}]
 452  $c bind text  <Enter> [list $c configure -cursor xterm]
 453  $c bind text  <Leave> [list $c configure -cursor {}]
 454
 455  util::canvasbind $c text <B1-Motion> [namespace code \
 456    [list textB1Move $w $pane %W %x %y]]
 457  util::canvasbind $c text <ButtonRelease-1> ""
 458  util::canvasbind $c text <ButtonPress-1> [namespace code \
 459    [list textClick $w $pane %W %x %y]]
 460
 461  util::canvasbind $c bg <ButtonPress-1> [namespace code \
 462    [list boxClick $w $pane %W %x %y]]
 463  bind $c <Any-Key>   [namespace code [list handleAnyKey $w $pane %W %x %y %A]]
 464  bind $c <BackSpace> [namespace code [list handleBackspace $w $pane %W]]
 465  bind $c <Return> {
 466   %W insert current insert ""
 467   %W focus {}
 468  }
 469
 470  bind $c <Enter> [namespace code [list handleEnterLeave $w $pane 1]]
 471  bind $c <Leave> [namespace code [list handleEnterLeave $w $pane 0]]
 472
 473  bind [winfo toplevel $c] <<AdjustRightEvent>> \
 474    [namespace code [list handleEvents AdjustLabel %x %y right]]
 475  bind [winfo toplevel $c] <<AdjustLeftEvent>> \
 476    [namespace code [list handleEvents AdjustLabel %x %y left]]
 477
 478  util::canvasbind $c text <<AdjustRightEvent>> ""
 479  util::canvasbind $c text <<AdjustLeftEvent>> ""
 480
 481  bind $c <<PlayLabelEvent>> \
 482    [namespace code [list handleEvents PlayLabel %x %y]]
 483  bind [winfo toplevel $c] <<PlayLabelEvent>> \
 484    [namespace code [list handleEvents PlayLabel %x %y]]
 485
 486  bind $c <<Delete>> "[namespace code [list handleDelete $w $pane %W]];break"
 487  bind $c <space> "[namespace code [list handleSpace $w $pane %W]];break"
 488  bind $c <Shift-Control-space> "[namespace code [list FindNextLabel $w $pane]];break"
 489  $c bind text <Key-Right> [namespace code [list handleKeyRight $w $pane %W]]
 490  $c bind text <Key-Left>  [namespace code [list handleKeyLeft $w $pane %W]]
 491
 492  if {[$w getInfo fileName] != ""} {
 493   openTranscriptionFile $w $pane [$w getInfo fileName] soundfile
 494 #  redraw $w $pane
 495  }
 496
 497  if {$::tcl_version > 8.2} {
 498   if $v(locked) {
 499    $c configure -state disabled
 500   } else {
 501    $c configure -state normal
 502   }
 503  }
 504  # If the label file is longer than any current displayed pane, update them all
 505  if {[info exists v(t1,end)]} {
 506   if {$v(t1,end) > [$pane cget -maxtime]} {
 507    $w _redraw
 508   }
 509  }
 510 }
 511
 512 proc trans::handleEvents {proc args} {
 513  if {![info exists ::trpane]} {
 514   return
 515  }
 516  if {[namespace which -variable \
 517           [namespace current]::${::trpane}::var] == ""} return
 518  upvar [namespace current]::${::trpane}::var v
 519
 520  if {[info exists v(cursorInPane)]} {
 521   if {$v(cursorInPane)} {
 522    eval $proc $::trw $::trpane $args
 523   }
 524  }
 525 }
 526
 527 proc trans::handleEnterLeave {w pane arg} {
 528  upvar [namespace current]::${pane}::var v
 529
 530  set v(cursorInPane) $arg
 531 }
 532
 533 proc trans::activateInput {w pane state} {
 534  variable Info
 535  upvar [namespace current]::${pane}::var v
 536
 537  if {[info exists Info($w,active)]} {
 538   if {$state == 1} {
 539    set Info($w,active) $pane
 540    [$pane yaxis] configure -relief solid
 541    [$pane canvas] configure -relief solid
 542    if {$v(extBounds)} {
 543     drawExtendedBoundaries $w $pane
 544    }
 545   }
 546   foreach p [$w _getPanes] {
 547    if {$state == 0 || [string compare $p $pane]} {
 548     if {[info exists v(drawTranscription)]} {
 549      if {$v(drawTranscription)} {
 550       [$p yaxis] configure -relief flat
 551       [$p canvas] configure -relief flat
 552      }
 553     }
 554    }
 555   }
 556  }
 557 }
 558
 559 proc trans::state {w state} {
 560  variable Info
 561
 562  if {[info exists Info($w,active)]} {
 563   if {$Info($w,active) != ""} {
 564    activateInput $w $Info($w,active) $state
 565    set c [$Info($w,active) canvas]
 566    if {$state} {
 567     boxClick $w $Info($w,active) $c 0 0
 568    }
 569   }
 570  }
 571 }
 572
 573 proc trans::labelsMenu {w pane X Y x y} {
 574  upvar [namespace current]::${pane}::var v
 575  set m $w.popup
 576  if {[winfo exists $m]} {destroy $m}
 577  menu $m -tearoff 0
 578  $m add command -label "Play Label" \
 579    -command [namespace code [list PlayLabel $w $pane $x $y]]
 580  $m add command -label "Insert Label" \
 581    -command [namespace code [list InsertLabel $w $pane $x $y]]
 582  $m add command -label "Select Label" \
 583    -command [namespace code [list SelectLabel $w $pane $x $y]]
 584  $m add command -label "Align Label" \
 585    -command [namespace code [list AlignLabel $w $pane $x $y]]
 586  $m add command -label "Browse..." \
 587    -command [namespace code [list browse $w $pane]]
 588  $m add command -label "Convert..." \
 589    -command [namespace code [list convert $w $pane]]
 590  $m add separator
 591  $m add command -label "Delete Label" \
 592    -command [namespace code [list DeleteLabel $w $pane $x $y]]
 593
 594  for {set j 0} {$j < $v(menuNcols)} {incr j } {
 595   for {set i 0} {$i < $v(menuNrows)} {incr i } {
 596    if {$i==0} {set cb 1} else {set cb 0}
 597    $m add command -label [subst $v($i$j)] -columnbreak $cb \
 598     -command [namespace code [list InsertLabel $w $pane $x $y \
 599                                [subst $v($i$j)]]] \
 600      -font $v(font)
 601   }
 602  }
 603
 604  if {[string match macintosh $::tcl_platform(platform)]} {
 605   tk_popup $w.popup $X $Y 0
 606  } else {
 607   tk_popup $w.popup $X $Y
 608  }
 609 }
 610
 611 proc trans::textClick {w pane W x y} {
 612  upvar [namespace current]::${pane}::var v
 613  set ::trpane $pane
 614  set ::trw $w
 615  set c [$pane canvas]
 616  focus $W
 617  $W focus current
 618  $W icursor current @[$W canvasx $x],[$W canvasy $y]
 619  $W select clear
 620  $W select from current @[$W canvasx $x],[$W canvasy $y]
 621  set tagno [lindex [$c gettags current] 0]
 622  activateInput $w $pane 1
 623
 624  set i [lsearch -exact $v(map) $tagno]
 625  if {$i == -1} return
 626  set start [GetStartByIndex $w $pane $i]
 627  set end $v(t1,$tagno,end)
 628  set len [expr $end - $start]
 629  $w messageProc \
 630     "$v(t1,$tagno,label) ($tagno) start: $start end: $end length: $len"
 631 }
 632
 633 proc trans::textB1Move {w pane W x y} {
 634  # clear widget selection before selecting any text
 635  foreach {start end} [$w cget -selection] break
 636  $w configure -selection [list $start $start]
 637
 638  $W select to current @[$W canvasx $x],[$W canvasy $y]
 639 }
 640
 641 proc trans::boxClick {w pane W x y} {
 642  upvar [namespace current]::${pane}::var v
 643  set ::trpane $pane
 644  set ::trw $w
 645  set c [$pane canvas]
 646  focus $W
 647  $W focus hidden
 648  set cx [$c canvasx $x]
 649  set t [$pane getTime $cx]
 650  $w configure -selection [list $t $t]
 651  activateInput $w $pane 1
 652  set v(clicked) 1
 653 }
 654
 655 proc trans::handleAnyKey {w pane W x y A} {
 656  upvar [namespace current]::${pane}::var v
 657  if {[string length $A] == 0} return
 658  if {[string is print $A] == 0} return
 659  set c [$pane canvas]
 660  if {[$W focus] != $v(hidden)} {
 661   set tag [$W focus]
 662   catch {$W dchars $tag sel.first sel.last}
 663   $W insert $tag insert $A
 664   SetLabelText $w $pane [lindex [$c gettags $tag] 0] \
 665     [$c itemcget $tag -text]
 666  } else {
 667   if {$v(quickenter) == 0} return
 668   set dx [expr {abs($v(lastPos) - $x)}]
 669   if {$v(quicktol) > $dx && $v(clicked) == 0} {
 670    set tagno $v(lastTag)
 671    append v(t1,$tagno,label) $A
 672    $c itemconf lab$v(lastTag) -text $v(t1,$tagno,label)
 673   } else {
 674    set v(lastTag) [InsertLabel $w $pane $x $y $A]
 675    if {$v(lastTag) == ""} return
 676    set v(lastPos) $x
 677    set v(clicked) 0
 678   }
 679  }
 680  changed $w $pane
 681 }
 682
 683 proc trans::handleDelete {w pane W} {
 684  set c [$pane canvas]
 685  if {[$W focus] != {}} {
 686   set tag [$W focus]
 687   if {![catch {$W dchars $tag sel.first sel.last}]} {
 688    return
 689   }
 690   $W dchars $tag insert
 691   SetLabelText $w $pane [lindex [$c gettags $tag] 0] \
 692       [$c itemcget $tag -text]
 693   changed $w $pane
 694  }
 695 }
 696
 697 proc trans::handleBackspace {w pane W} {
 698  set c [$pane canvas]
 699  if {[$W focus] != {}} {
 700   set tag [$W focus]
 701   if {![catch {$W dchars $tag sel.first sel.last}]} {
 702    return
 703   }
 704   set ind [expr {[$W index $tag insert]-1}]
 705   if {$ind >= 0} {
 706    $W icursor $tag $ind
 707    $W dchars $tag insert
 708    SetLabelText $w $pane [lindex [$c gettags $tag] 0] \
 709      [$c itemcget $tag -text]
 710    changed $w $pane
 711   }
 712  }
 713 }
 714
 715 proc trans::handleSpace {w pane W} {
 716  set c [$pane canvas]
 717  if {[$W focus] != {}} {
 718   $W select clear
 719   $W insert [$W focus] insert _
 720   SetLabelText $w $pane [lindex [$c gettags [$W focus]] 0] \
 721     [$c itemcget [$W focus] -text]
 722  }
 723 }
 724
 725 proc trans::handleKeyRight {w pane W} {
 726  upvar [namespace current]::${pane}::var v
 727  set c [$pane canvas]
 728  set width [expr {[$pane cget -maxtime] * [$pane cget -pixelspersecond]}]
 729  if {[$W focus] != {}} {
 730   $W select clear
 731   set __index [$W index [$W focus] insert]
 732   $W icursor [$W focus] [expr {$__index + 1}]
 733   if {$__index == [$W index [$W focus] insert]} {
 734    set ti [lindex [$c gettags [$W focus]] 0]
 735    set i [lsearch -exact $v(map) $ti]
 736    set __focus [lindex $v(map) [expr {$i+1}]]
 737    $W focus lab$__focus
 738    $W icursor lab$__focus 0
 739    while {$width * [lindex [$c xview] 1]-10 < \
 740      [lindex [$W coords [$W focus]] 0] && [lindex [$c xview] 1] < 1} {
 741     $w xscroll scroll 1 unit
 742    }
 743   }
 744  }
 745 }
 746
 747 proc trans::handleKeyLeft {w pane W} {
 748  upvar [namespace current]::${pane}::var v
 749  set c [$pane canvas]
 750  set width [expr {[$pane cget -maxtime] * [$pane cget -pixelspersecond]}]
 751  if {[$W focus] != {}} {
 752   $W select clear
 753   set __index [$W index [$W focus] insert]
 754   $W icursor [$W focus] [expr {[$W index [$W focus] insert] - 1}]
 755   if {$__index == [$W index [$W focus] insert]} {
 756    set ti [lindex [$c gettags [$W focus]] 0]
 757    set i [lsearch -exact $v(map) $ti]
 758    set __focus [lindex $v(map) [expr {$i-1}]]
 759    $W focus lab$__focus
 760    $W icursor lab$__focus end
 761    while {$width * [lindex [$c xview] 0] +10 > \
 762      [lindex [$W coords [$W focus]] 0] && [lindex [$c xview] 0] > 0} {
 763     $w xscroll scroll -1 unit
 764    }
 765   }
 766  }
 767 }
 768
 769 proc trans::openFile {w soundFileName} {
 770  variable Info
 771
 772  foreach pane [$w _getPanes] {
 773   upvar [namespace current]::${pane}::var v
 774   if {$v(drawTranscription)} {
 775    openTranscriptionFile $w $pane [$w getInfo fileName] soundfile
 776   }
 777  }
 778  return 0
 779 }
 780
 781 proc trans::saveFile {w soundFileName} {
 782  foreach pane [$w _getPanes] {
 783   upvar [namespace current]::${pane}::var v
 784   if {$v(drawTranscription) && $v(changed)} {
 785    saveTranscriptionFile $w $pane
 786   }
 787  }
 788  return 0
 789 }
 790
 791 proc trans::openTranscriptionFile {w pane fn type} {
 792  variable Info
 793  upvar [namespace current]::${pane}::var v
 794
 795  if {[info exists v(drawTranscription)]} {
 796   if {$v(drawTranscription) == 0} return
 797  }
 798  set fileName ""
 799  if {[string match soundfile $type]} {
 800   set path [file normalize [file dirname $fn]]
 801   set pathlist [file split $path]
 802   set rootname [file tail [file rootname $fn]]
 803   set name $rootname.[string trim $v(labext) .]
 804
 805   # Try to locate the corresponding label file
 806
 807   if {$v(labdir) != ""} {
 808    # Try the following directories in order
 809    # 1. try to locate file in specified label file directory
 810    # 2. try 'sound file path'/../'specified dir'
 811    # 3. look in current directory
 812    # 4. look in same directory as sound file
 813
 814    if {[file readable [file join $v(labdir) $name]]} {
 815     set fileName [file join $v(labdir) $name]
 816    } elseif {[file readable [eval file join [lreplace $pathlist end end $v(labdir)] $name]]} {
 817     set fileName [eval file join [lreplace $pathlist end end $v(labdir)] $name]
 818    }
 819   }
 820   if {$fileName == ""} {
 821    if {[file readable $name]} {
 822     set fileName $name
 823    } elseif {[file readable [file join $path $name]]} {
 824     set fileName [file join $path $name]
 825    } else {
 826     set fileName $name
 827    }
 828   }
 829  } else {
 830   set fileName $fn
 831  }
 832
 833  # This filename should be correct, remember it
 834
 835  set v(fileName) $fileName
 836  set v(nLabels) 0
 837  set v(map)     {}
 838  set v(labext) [file extension $fileName]
 839
 840  foreach {format loadProc saveProc} $Info(formats) {
 841   if {[string compare $format $v(format)] == 0} {
 842    set res [[namespace parent]::$loadProc $w $pane]
 843    if {$res != ""} {
 844     $w messageProc $res
 845     set v(changed) 0
 846     return
 847    }
 848   }
 849  }
 850 }
 851
 852 proc trans::saveTranscriptionFile {w pane} {
 853  variable Info
 854  upvar [namespace current]::${pane}::var v
 855
 856  set fn $v(fileName)
 857  set strip_fn [file tail [file rootname $fn]]
 858  if {$strip_fn == ""} {
 859   set strip_fn [file tail [file rootname [$w getInfo fileName]]]
 860  }
 861  set path [file dirname $fn]
 862  set v(fileName) [file join $path $strip_fn.[string trim $v(labext) .]]
 863  set fn $v(fileName)
 864  catch {file copy $fn $fn~}
 865
 866  foreach {format loadProc saveProc} $Info(formats) {
 867   if {[string compare $format $v(format)] == 0} {
 868    set res [[namespace parent]::$saveProc $w $pane]
 869    if {$res != ""} {
 870     $w messageProc $res
 871     return
 872    }
 873   }
 874  }
 875  set v(changed) 0
 876
 877  return 0
 878 }
 879
 880 proc trans::needSave {w pane} {
 881  upvar [namespace current]::${pane}::var v
 882
 883  if {[info exists v(drawTranscription)]} {
 884   if {$v(drawTranscription)} {
 885    if {$v(changed)} {
 886     return 1
 887    }
 888   }
 889  }
 890  return 0
 891 }
 892
 893 proc trans::redraw {w pane} {
 894  upvar [namespace current]::${pane}::var v
 895
 896  if {!$v(drawTranscription)} return
 897
 898  set c [$pane canvas]
 899  $c delete tran
 900  foreach otherpane [$w _getPanes] {
 901   upvar wsurf::analysis::${otherpane}::var ov
 902   upvar wsurf::dataplot::${otherpane}::var dv
 903   if {$ov(drawWaveform) || $ov(drawSpectrogram) || $dv(drawDataPlot)} {
 904    set othercanvas [$otherpane canvas]
 905    $othercanvas delete tran$pane
 906   }
 907  }
 908  _redraw $w $pane $c 0 0
 909  #  boxClick $w $pane $c 0 0
 910 }
 911
 912 proc trans::_redraw {w pane c x y} {
 913  upvar [namespace current]::${pane}::var v
 914
 915  set progressproc [$w cget -progressproc]
 916  if {$progressproc != "" && $v(nLabels) > 0} {
 917 #  $progressproc "Creating labels" 0.0
 918  }
 919  set height [$pane cget -height]
 920  set v(height) $height
 921  set width [expr {[$pane cget -maxtime] * [$pane cget -pixelspersecond]}]
 922  set ascent [font metrics $v(font) -ascent]
 923  set v(ascent) $ascent
 924  $c configure -bg $v(bgColor)
 925
 926  [$pane yaxis] delete ext
 927  set vc [$pane yaxis]
 928  set yw [winfo width $vc]
 929  if {$::tcl_version > 8.2 && [string match disabled [$c cget -state]]} {
 930   [$pane yaxis] create text [expr {$yw/2}] [expr {$height/2}] \
 931     -text L:$v(labext) \
 932     -font $v(font) -tags ext \
 933     -fill $v(labColor)
 934  } else {
 935   [$pane yaxis] create text [expr {$yw/2}] [expr {$height/2}] \
 936     -text $v(labext) \
 937     -font $v(font) -tags ext \
 938     -fill $v(labColor)
 939  }
 940  if {$v(nLabels) == 0} {
 941   set slen [[$w cget -sound] length -unit seconds]
 942   set endx [$pane getCanvasX $slen]
 943   $c create rectangle [expr {$x+0}] $y \
 944     [expr {$x+$endx}] [expr {$y+$height-4}] -outline "" \
 945     -tags [list gEnd obj bg tran] -fill $v(bgColor)
 946   set v(hidden) [$c create text [expr {$x-100}] [expr {$y+10}] \
 947     -text "" -tags [list hidden tran]]
 948   return 0
 949  } else {
 950   set start 0
 951   set end   0
 952   set label ""
 953
 954   for {set i [expr $v(nLabels)-1]} {$i >= 0} {incr i -1} {
 955    set ind [lindex $v(map) $i]
 956    if {$i == 0} {
 957     set start $v(t1,start)
 958    } else {
 959     set ind2 [lindex $v(map) [expr {$i - 1}]]
 960     set start $v(t1,$ind2,end)
 961    }
 962    set end $v(t1,$ind,end)
 963    set label $v(t1,$ind,label)
 964    set lx [$pane getCanvasX $start]
 965    set rx [$pane getCanvasX $end]
 966
 967    if {$lx >= 0 && $lx <= $width} {
 968     #DrawLabel $w $pane $c $ind $i $x $y $lx $rx $label
 969     set tx [ComputeTextPosition $w $pane $lx $rx]
 970     $c create rectangle [expr {$x+$lx}] $y \
 971       [expr {$x+$rx}] [expr {$y+$height-4}] -outline "" \
 972       -tags [list g$ind obj bg tran] -fill $v(bgColor)
 973     $c create text [expr {$x+$tx}] [expr {$y+$ascent}] -text $label\
 974       -font $v(font) -anchor $v(alignment)\
 975       -tags [list $ind obj text lab$ind tran] \
 976       -fill $v(labColor)
 977     $c create line [expr {$x+$rx}] $y [expr {$x+$rx}] [expr {$y+$height}] \
 978       -tags [list b$ind obj bound tran topmost] -fill $v(bdColor)
 979    }
 980    if {$progressproc != "" && $i % 100 == 99} {
 981 #    $progressproc "Creating labels" [expr double($v(nLabels)-$i)/$v(nLabels)]
 982    }
 983   }
 984   set start $v(t1,start)
 985   set sx [$pane getCanvasX $start]
 986   $c create rectangle [expr {$x+0}] $y \
 987     [expr {$x+$sx}] [expr {$y+$height-4}] -outline "" \
 988     -tags [list gStart obj bg tran] -fill $v(bgColor)
 989   $c create line [expr {$x+$sx}] $y [expr {$x+$sx}] [expr {$y+$height}] \
 990     -tags [list bStart obj bound tran topmost] -fill $v(bdColor)
 991
 992   set slen [[$w cget -sound] length -unit seconds]
 993   set endx [$pane getCanvasX $slen]
 994   $c create rectangle [expr {$x+$rx}] $y \
 995     [expr {$x+$endx}] [expr {$y+$height-4}] -outline "" \
 996     -tags [list gEnd obj bg tran] -fill $v(bgColor)
 997   set prev [lindex $v(map) end]
 998   $c lower gEnd g$prev
 999  }
1000  set v(hidden) [$c create text [expr {$x-100}] [expr {$y+10}] \
1001    -text "" -tags [list hidden tran]]
1002
1003  if {$v(extBounds)} {
1004   drawExtendedBoundaries $w $pane
1005  }
1006
1007  if {$progressproc != ""} {
1008 #  $progressproc "Creating labels" 1.0
1009  }
1010
1011  return $height
1012 }
1013
1014 proc trans::drawExtendedBoundaries {w pane} {
1015  upvar [namespace current]::${pane}::var v
1016
1017  foreach otherpane [$w _getPanes] {
1018   upvar wsurf::analysis::${otherpane}::var ov
1019   upvar wsurf::dataplot::${otherpane}::var dv
1020   if {$ov(drawWaveform) || $ov(drawSpectrogram) || $dv(drawDataPlot)} {
1021    set othercanvas [$otherpane canvas]
1022    $othercanvas delete tran$pane
1023   }
1024  }
1025
1026  set height [$pane cget -height]
1027  set width [expr {[$pane cget -maxtime] * [$pane cget -pixelspersecond]}]
1028
1029  if {$v(nLabels) > 0} {
1030   set start 0
1031   set end   0
1032   set label ""
1033
1034   for {set i [expr $v(nLabels)-1]} {$i >= 0} {incr i -1} {
1035    set ind [lindex $v(map) $i]
1036    if {$i == 0} {
1037     set start $v(t1,start)
1038    } else {
1039     set ind2 [lindex $v(map) [expr {$i - 1}]]
1040     set start $v(t1,$ind2,end)
1041    }
1042    set end $v(t1,$ind,end)
1043    set label $v(t1,$ind,label)
1044    set lx [$pane getCanvasX $start]
1045    set rx [$pane getCanvasX $end]
1046
1047    if {$lx >= 0 && $lx <= $width} {
1048     foreach otherpane [$w _getPanes] {
1049      upvar wsurf::analysis::${otherpane}::var av
1050      upvar wsurf::dataplot::${otherpane}::var dv
1051      if {$av(drawWaveform) || $av(drawSpectrogram) || $dv(drawDataPlot)} {
1052       set othercanvas [$otherpane canvas]
1053       set height [$otherpane cget -height]
1054       $othercanvas create line $rx 0 $rx \
1055         $height -tags [list b$ind$pane obj bound tran$pane] \
1056           -fill $v(bdColor)
1057      }
1058     }
1059    }
1060   }
1061  }
1062 }
1063
1064 proc trans::DrawLabel {w pane c tagno i x y lx rx label} {
1065  upvar [namespace current]::${pane}::var v
1066  #  set ascent [font metrics $v(font) -ascent]
1067  #  set height [$pane cget -height]
1068  set ascent $v(ascent)
1069  set height $v(height)
1070
1071  set tx [ComputeTextPosition $w $pane $lx $rx]
1072  $c create rectangle [expr {$x+$lx}] $y \
1073    [expr {$x+$rx}] [expr {$y+$height-4}] -outline "" \
1074    -tags [list g$tagno obj bg tran] -fill $v(bgColor)
1075  $c create text [expr {$x+$tx}] [expr {$y+$ascent}] -text $label\
1076    -font $v(font) -anchor $v(alignment)\
1077    -tags [list $tagno obj text lab$tagno tran] \
1078    -fill $v(labColor)
1079  $c create line [expr {$x+$rx}] $y [expr {$x+$rx}] [expr {$y+$height}] \
1080    -tags [list b$tagno obj bound tran topmost] -fill $v(bdColor)
1081
1082  if {$i > 0} {
1083   set prev [lindex $v(map) [expr {$i-1}]]
1084   $c lower g$tagno   g$prev
1085   $c lower lab$tagno g$prev
1086   $c lower b$tagno   g$prev
1087  } else {
1088   $c lower g$tagno   gStart
1089   $c lower lab$tagno gStart
1090   $c lower b$tagno   gStart
1091  }
1092
1093  if {$v(extBounds)} {
1094   foreach otherpane [$w _getPanes] {
1095    upvar wsurf::analysis::${otherpane}::var av
1096    upvar wsurf::dataplot::${otherpane}::var dv
1097    if {$av(drawWaveform) || $av(drawSpectrogram) || $dv(drawDataPlot)} {
1098     set othercanvas [$otherpane canvas]
1099     set height [$otherpane cget -height]
1100     $othercanvas create line $rx 0 $rx \
1101      $height -tags [list b$tagno obj bound tran$pane] -fill $v(bdColor)
1102    }
1103   }
1104  }
1105 }
1106
1107 proc trans::isLabel {tags} {
1108  expr [string compare [lindex $tags 2] bg] == 0 || \
1109    [string compare [lindex $tags 2] text] == 0
1110 }
1111
1112 proc trans::GetStartByIndex {w pane i} {
1113  upvar [namespace current]::${pane}::var v
1114  if {$i <= 0 || $i == "Start"} {
1115   return $v(t1,start)
1116  } else {
1117   set ind [lindex $v(map) [expr $i-1]]
1118   return $v(t1,$ind,end)
1119  }
1120 }
1121
1122 proc trans::PlaceLabel {w pane tagno coords start end} {
1123  upvar [namespace current]::${pane}::var v
1124  set c [$pane canvas]
1125  if {$tagno != "Start"} {
1126   # Place background and boundary
1127   $c coords b$tagno $end [lindex $coords 1] $end [lindex $coords 3]
1128   $c coords g$tagno $start [lindex $coords 1] $end [expr [lindex $coords 3]-4]
1129
1130   # Place label text
1131   set tx [ComputeTextPosition $w $pane $start $end]
1132   $c coords lab$tagno $tx [lindex [$c coords lab$tagno] 1]
1133  } else {
1134   $c coords b$tagno $end [lindex $coords 1] $end [lindex $coords 3]
1135   $c coords g$tagno 0 [lindex $coords 1] $end [expr [lindex $coords 3]-4]
1136  }
1137
1138  if {$v(extBounds)} {
1139   foreach otherpane [$w _getPanes] {
1140    upvar wsurf::analysis::${otherpane}::var av
1141    upvar wsurf::dataplot::${otherpane}::var dv
1142    if {$av(drawWaveform) || $av(drawSpectrogram) || $dv(drawDataPlot)} {
1143     set othercanvas [$otherpane canvas]
1144     set height [$otherpane cget -height]
1145     $othercanvas coords b$tagno$pane $end 0 $end $height
1146    }
1147   }
1148  }
1149 }
1150
1151 proc trans::getBounds {w pane} {
1152  upvar [namespace current]::${pane}::var v
1153
1154  if {$v(drawTranscription)} {
1155   list 0 0 $v(t1,end) 0
1156  } else {
1157   list
1158  }
1159 }
1160
1161 proc trans::MoveBoundary {w pane x} {
1162  upvar [namespace current]::${pane}::var v
1163
1164  set c [$pane canvas]
1165  set s [$w cget -sound]
1166  set coords [$c coords current]
1167  set xc [$c canvasx $x]
1168  if {$xc < 0} { set xc 0 }
1169  set tagno [string trim [lindex [$c gettags current] 0] b]
1170  set i [lsearch -exact $v(map) $tagno]
1171
1172  # Logic which prevents a boundary to be moved past its neighbor
1173  set h [lindex $v(map) [expr {$i-1}]]
1174  set j [lindex $v(map) [expr {$i+1}]]
1175  set px 0
1176  set nx [expr {[$pane cget -maxtime] * [$pane cget -pixelspersecond]}]
1177  set pb [$c find withtag b$h]
1178  set nb [$c find withtag b$j]
1179  if {$pb != ""} { set px [lindex [$c coords $pb] 0]}
1180  if {$nb != ""} { set nx [lindex [$c coords $nb] 0]}
1181  if {$xc <= $px} { set xc [expr {$px + 1}] }
1182  if {$nx <= $xc} { set xc [expr {$nx - 1}] }
1183
1184  set start [$pane getCanvasX [GetStartByIndex $w $pane $i]]
1185
1186  # Update time
1187  if {$i == -1} {
1188   set v(t1,start) [$pane getTime $xc]
1189  } else {
1190   set this [lindex $v(map) $i]
1191   set oldTime $v(t1,$this,end)
1192   set v(t1,$this,end) [$pane getTime $xc]
1193  }
1194
1195  # Place this label
1196  PlaceLabel $w $pane $tagno $coords $start $xc
1197
1198  # Place next label
1199  PlaceNextLabel $w $pane $i $xc
1200
1201  if {$v(linkBounds)} {
1202   foreach otherpane [$w _getPanes] {
1203    upvar [namespace current]::${otherpane}::var ov
1204    if {$otherpane != $pane && $ov(drawTranscription) && \
1205            [info exists oldTime]} {
1206     foreach tag $ov(map) {
1207      if {$ov(t1,$tag,end) == $oldTime} {
1208       set ov(t1,$tag,end) [$pane getTime $xc]
1209       PlaceLabel $w $otherpane $tag $coords $start $xc
1210       break
1211      }
1212     }
1213    }
1214   }
1215  }
1216
1217  if {$v(lastmoved) != $i} {
1218   changed $w $pane
1219   if {$tagno == "Start"} {
1220    #   wsurf::PrepareUndo "set [namespace current]::var(t1,start) \[list $v(t1,start)\]" ""
1221   } else {
1222    #   wsurf::PrepareUndo "set [namespace current]::var(t1,$tagno,end) \[list $v(t1,$tagno,end)\]" ""
1223   }
1224   set v(lastmoved) $i
1225  }
1226  vtcanvas::motionEvent $pane $x 0
1227 }
1228
1229 proc trans::SetLabelText {w pane tagno label} {
1230  upvar [namespace current]::${pane}::var v
1231
1232  $w messageProc [format "Transcription - %s" $label]
1233  set v(t1,$tagno,label) $label
1234 }
1235
1236 proc trans::InsertLabel {w pane x y {label ""}} {
1237  upvar [namespace current]::${pane}::var v
1238
1239  set s [$w cget -sound]
1240  set c [$pane canvas]
1241  set cx [$c canvasx $x]
1242  set t [$pane getTime $cx]
1243
1244  set tags [$c gettags [$c find closest [$c canvasx $x] [$c canvasy $y]]]
1245  if {[isLabel $tags]} {
1246   set tagno [string trim [lindex $tags 0] g]
1247   if {$tagno == "End"} {
1248    #      set i $v(nLabels)
1249    set i 0
1250    foreach ind $v(map) {
1251     if {$t < $v(t1,$ind,end)} break
1252     incr i
1253    }
1254   } else {
1255    set i [lsearch -exact $v(map) $tagno]
1256   }
1257  } else {
1258   set i 0
1259   foreach ind $v(map) {
1260    if {$t < $v(t1,$ind,end)} break
1261    incr i
1262   }
1263  }
1264
1265  # Create label with a randomly chosen tag number
1266  set n [clock clicks]
1267  set v(t1,$n,end) $t
1268  set v(t1,$n,label) $label
1269  set v(t1,$n,rest)  ""
1270  set v(map) [linsert $v(map) $i $n]
1271  incr v(nLabels)
1272
1273  # Update start time if new label was inserted first
1274  if {$i < 0} {
1275   set v(t1,start) 0
1276   set co [$c coords bStart]
1277   $c coords bStart 0 [lindex $co 1] 0 [lindex $co 3]
1278   set co [$c coords gStart]
1279   $c coords gStart 0 [lindex $co 1] 0 [lindex $co 3]
1280   set start 0
1281  } else {
1282   set start [$pane getCanvasX [GetStartByIndex $w $pane $i]]
1283  }
1284
1285  # Draw inserted label
1286  DrawLabel $w $pane $c $n $i 0 0 $start $cx $label
1287
1288  # Place next label
1289  if {$i < 0} { incr i }
1290  PlaceNextLabel $w $pane $i $cx
1291
1292  # Display cursor if label is empty
1293  if {$label==""} {
1294   focus [$pane canvas]
1295   [$pane canvas] focus lab$n
1296   [$pane canvas] icursor lab$n @[$c canvasx $x],[$c canvasy $y]
1297  }
1298
1299  changed $w $pane
1300  return $n
1301 }
1302
1303 proc trans::DeleteLabel {w pane x y} {
1304  upvar [namespace current]::${pane}::var v
1305  set c [$pane canvas]
1306  set tags [$c gettags [$c find closest [$c canvasx $x] [$c canvasy $y]]]
1307
1308  if {[isLabel $tags] || [string compare [lindex $tags 2] bound] == 0} {
1309   set tagno [string trim [lindex $tags 0] gb]
1310   set i [lsearch -exact $v(map) $tagno]
1311   if {$i == -1} return
1312
1313   # Delete everything related to this label
1314   unset v(t1,$tagno,label)
1315   unset v(t1,$tagno,end)
1316   unset v(t1,$tagno,rest)
1317   set v(map) [lreplace $v(map) $i $i]
1318   incr v(nLabels) -1
1319   $c delete b$tagno lab$tagno g$tagno
1320   if {$v(extBounds)} {
1321    foreach otherpane [$w _getPanes] {
1322     upvar wsurf::analysis::${otherpane}::var av
1323     upvar wsurf::dataplot::${otherpane}::var dv
1324     if {$av(drawWaveform) || $av(drawSpectrogram) || $dv(drawDataPlot)} {
1325      set othercanvas [$otherpane canvas]
1326      $othercanvas delete b$tagno$pane
1327     }
1328    }
1329   }
1330
1331   # Place previous label box
1332   set prev [lindex $v(map) [expr {$i-1}]]
1333   if {$prev != ""} {
1334    set end [lindex [$c coords g$prev] 2]
1335   } else {
1336    set end [$pane getCanvasX $v(t1,start)]
1337    set prev 0
1338   }
1339   set iprev [lsearch -exact $v(map) $prev]
1340   PlaceNextLabel $w $pane $iprev $end
1341
1342   changed $w $pane
1343  }
1344 }
1345
1346 proc trans::AdjustLabel {w pane x y boundary} {
1347  upvar [namespace current]::${pane}::var v
1348
1349  set c [$pane canvas]
1350  set xc [$c canvasx $x]
1351  set t [$pane getTime $xc]
1352  set tags [$c gettags [$c find closest $xc [$c canvasy $y]]]
1353
1354  if {[isLabel $tags]} {
1355   set tagno [string trim [lindex $tags 0] g]
1356   set i [lsearch -exact $v(map) $tagno]
1357  } else {
1358   set i 0
1359   foreach ind $v(map) {
1360    if {$t < $v(t1,$ind,end)} break
1361    incr i
1362   }
1363   set tagno [lsearch -exact $v(map) $i]
1364  }
1365
1366  if {$i == $v(nLabels)} return
1367
1368  if {$tagno != "End" && [string match left $boundary]} {
1369   incr i -1
1370   set tagno [lindex $v(map) $i]
1371  }
1372  if {$tagno == "End"} return
1373  if {$tagno != ""} {
1374   set v(t1,$tagno,end) $t
1375  }
1376
1377  if {$i < 0} {
1378   set v(t1,start) $t
1379   set co [$c coords bStart]
1380   set sx [$pane getCanvasX $t]
1381   $c coords bStart $sx [lindex $co 1] $sx [lindex $co 3]
1382   $c coords gStart 0 [lindex $co 1] $sx [lindex $co 3]
1383  }
1384  set start [$pane getCanvasX [GetStartByIndex $w $pane $i]]
1385
1386  # Place this label
1387  set co [$c coords b$tagno]
1388  PlaceLabel $w $pane $tagno $co $start $xc
1389
1390  # Place next label
1391  PlaceNextLabel $w $pane $i $xc
1392
1393  changed $w $pane
1394
1395  $w messageProc [format "Transcription - %s" [$w formatTime $t]]
1396 }
1397
1398 proc trans::PlayLabel {w pane x y} {
1399  upvar [namespace current]::${pane}::var v
1400  set c [$pane canvas]
1401  set tags [$c gettags [$c find closest [$c canvasx $x] [$c canvasy $y]]]
1402
1403  if {[isLabel $tags]} {
1404   set tagno [string trim [lindex $tags 0] g]
1405   set i [lsearch -exact $v(map) $tagno]
1406   if {$i == -1} return
1407  } else {
1408   set i 0
1409   set cx [$c canvasx $x]
1410   set t [$pane getTime $cx]
1411   foreach ind $v(map) {
1412    if {$t < $v(t1,$ind,end)} break
1413    incr i
1414   }
1415  }
1416  set start [GetStartByIndex $w $pane $i]
1417  set this [lindex $v(map) $i]
1418  if {$this == ""} return
1419  set end $v(t1,$this,end)
1420
1421  $w play $start $end
1422 }
1423
1424 proc trans::SelectLabel {w pane x y} {
1425  upvar [namespace current]::${pane}::var v
1426  set c [$pane canvas]
1427  set tags [$c gettags [$c find closest [$c canvasx $x] [$c canvasy $y]]]
1428
1429  if {[isLabel $tags]} {
1430   set tagno [string trim [lindex $tags 0] g]
1431   set i [lsearch -exact $v(map) $tagno]
1432   if {$i == -1} return
1433
1434   set start [GetStartByIndex $w $pane $i]
1435   set end $v(t1,$tagno,end)
1436
1437   $w configure -selection [list $start $end]
1438  }
1439 }
1440
1441 proc trans::AlignLabel {w pane x y} {
1442  upvar [namespace current]::${pane}::var v
1443  set c [$pane canvas]
1444  set tags [$c gettags [$c find closest [$c canvasx $x] [$c canvasy $y]]]
1445
1446  if {[isLabel $tags]} {
1447   set tagno [string trim [lindex $tags 0] g]
1448   set i [lsearch -exact $v(map) $tagno]
1449   if {$i == -1} return
1450
1451   # Get current selection
1452   foreach {start end} [$w cget -selection] break
1453   if {$start == $end} return
1454
1455   # Validate that selection and label overlap, otherwise generate warning msg
1456
1457   set ostart [GetStartByIndex $w $pane $i]
1458   set oend $v(t1,$tagno,end)
1459
1460   if {$start >= $oend || $end <= $ostart} {
1461    tk_messageBox -message "Label and selection must overlap!"
1462    return
1463   }
1464
1465   # Update boundaries according to current selection
1466   if {$i == 0} {
1467    set v(t1,start) $start
1468   } else {
1469    set ind [lindex $v(map) [expr $i-1]]
1470    set v(t1,$ind,end) $start
1471   }
1472
1473   set v(t1,$tagno,end) $end
1474
1475   $w _redrawPane $pane
1476  }
1477 }
1478
1479 proc trans::FindNextLabel {w pane} {
1480  upvar [namespace current]::${pane}::var v
1481  foreach {start end} [$w cget -selection] break
1482  set i 0
1483  foreach ind $v(map) {
1484   if {$end < $v(t1,$ind,end)} break
1485   incr i
1486  }
1487  set tagno [lsearch -exact $v(map) $i]
1488  if {$tagno == -1} return
1489  set start [GetStartByIndex $w $pane $i]
1490  set end $v(t1,$tagno,end)
1491
1492  $w configure -selection [list $start $end]
1493  set s [$w cget -sound]
1494  set length [$s length -unit seconds]
1495  $w xscroll moveto [expr {($start-1.0)/$length}]
1496  $w play $start $end
1497  set delay [expr 500 + int(1000 * ($end - $start))]
1498  after $delay [namespace code [list FindNextLabel $w $pane]]
1499 }
1500
1501 proc trans::ComputeTextPosition {w pane start end} {
1502  upvar [namespace current]::${pane}::var v
1503  if {$v(alignment) == "c"} {
1504   return [expr {($start+$end)/2}]
1505  } elseif {$v(alignment) == "w"} {
1506   return [expr {$start + 2}]
1507  } else {
1508   return [expr {$end - 2}]
1509  }
1510 }
1511
1512 proc trans::PlaceNextLabel {w pane index pos} {
1513  upvar [namespace current]::${pane}::var v
1514  set c [$pane canvas]
1515  incr index
1516  set next [lindex $v(map) $index]
1517
1518  if {$next == ""} {
1519   set next End
1520   set co [$c coords g$next]
1521   $c coords g$next $pos [lindex $co 1] [lindex $co 2] [lindex $co 3]
1522  } else {
1523   set co [$c coords b$next]
1524   $c coords g$next $pos [lindex $co 1] [lindex $co 2] [expr [lindex $co 3]-4]
1525   #    $c itemconf g$next -fill yellow
1526   set xc [ComputeTextPosition $w $pane $pos [lindex $co 2]]
1527   $c coords lab$next $xc [lindex [$c coords lab$next] 1]
1528  }
1529 }
1530
1531 proc trans::print {w pane c x y} {
1532  upvar [namespace current]::${pane}::var v
1533
1534  upvar wsurf::analysis::${pane}::var ov
1535  upvar wsurf::dataplot::${pane}::var dv
1536  if {$ov(drawWaveform) || $ov(drawSpectrogram) || $dv(drawDataPlot)} {
1537   foreach otherpane [$w _getPanes] {
1538    upvar wsurf::trans::${otherpane}::var tv
1539    if {[info exists tv(extBounds)] && $tv(extBounds)} {
1540     set drawExtBounds 1
1541     break;
1542    }
1543   }
1544  }
1545
1546  if {[info exists drawExtBounds]} {
1547   set height [$pane cget -height]
1548   set width [expr {[$pane cget -maxtime] * [$pane cget -pixelspersecond]}]
1549   set yAxisCanvas [$pane yaxis]
1550   set yAxisWidth [winfo width $yAxisCanvas]
1551
1552   if {$tv(nLabels) > 0} {
1553    set start 0
1554    set end   0
1555    set label ""
1556
1557    for {set i [expr $tv(nLabels)-1]} {$i >= 0} {incr i -1} {
1558     set ind [lindex $tv(map) $i]
1559     if {$i == 0} {
1560      set start $tv(t1,start)
1561     } else {
1562      set ind2 [lindex $tv(map) [expr {$i - 1}]]
1563      set start $tv(t1,$ind2,end)
1564     }
1565     set end $tv(t1,$ind,end)
1566     set label $tv(t1,$ind,label)
1567     set lx [$pane getCanvasX $start]
1568     set rx [$pane getCanvasX $end]
1569
1570     if {$lx >= 0 && $lx <= $width} {
1571      $c create line [expr {$rx+$yAxisWidth}] $y \
1572          [expr {$rx+$yAxisWidth}] [expr {$y+$height}] \
1573          -tags [list b$ind$pane obj bound tran$pane print tmpPrint] \
1574          -fill $tv(bdColor)
1575     }
1576    }
1577   }
1578  }
1579
1580
1581  if {!$v(drawTranscription)} return
1582
1583  $c raise bound
1584
1585  set yAxisCanvas [$pane yaxis]
1586  set yAxisWidth [winfo width $yAxisCanvas]
1587  set h [$pane cget -height]
1588  set width [expr {[$pane cget -maxtime] * [$pane cget -pixelspersecond]}]
1589
1590  $c create rectangle $yAxisWidth $y \
1591    [expr {$x+$width+$yAxisWidth}] [expr {$y+$h}] \
1592    -tags print -outline black
1593  _redraw $w $pane $c $yAxisWidth $y
1594 }
1595
1596 proc trans::cursorMoved {w pane time value} {
1597  upvar [namespace current]::${pane}::var v
1598
1599  if {$v(drawTranscription)} {
1600   $w messageProc \
1601     [format "%s: %s | $v(labelMenuEvent): Label menu" $v(fileName) [$w formatTime $time]]
1602  }
1603 }
1604
1605 proc trans::soundChanged {w flag} {
1606  set s [$w cget -sound]
1607  foreach pane [$w _getPanes] {
1608   upvar [namespace current]::${pane}::var v
1609   if {$v(drawTranscription)} {
1610     $w _redrawPane $pane
1611   }
1612  }
1613 }
1614
1615 proc trans::propertyPane {w pane} {
1616  if {$pane==""} return
1617  upvar [namespace current]::${pane}::var v
1618
1619  if {$v(drawTranscription)} {
1620   list Trans1 [namespace code drawPage1] \
1621     Trans2 [namespace code drawPage2]
1622  }
1623 }
1624
1625 proc trans::applyProperties {w pane} {
1626  if {[string match *wavebar $pane]} return
1627  variable Info
1628  upvar [namespace current]::${pane}::var v
1629
1630  if {[info exists v(drawTranscription)]} {
1631   if {$v(drawTranscription)} {
1632    foreach var {format alignment labext labdir encoding \
1633      labColor bdColor bgColor \
1634      font menuNrows menuNcols labelMenuEvent adjustLeftEvent \
1635      adjustRightEvent playLabelEvent locked quickenter quicktol \
1636      extBounds linkBounds highlight} {
1637     if {[string compare $v(t,$var) $v($var)] !=0} {
1638      if [string match labelMenuEvent $var] {
1639       event delete <<LabelMenuEvent>> <$v($var)>
1640       event add <<LabelMenuEvent>> <$v(t,$var)>
1641      }
1642      if [string match adjustLeftEvent $var] {
1643       event delete <<AdjustLeftEvent>> <$v($var)>
1644       event add <<AdjustLeftEvent>> <$v(t,$var)>
1645      }
1646      if [string match adjustRightEvent $var] {
1647       event delete <<AdjustRightEvent>> <$v($var)>
1648       event add <<AdjustRightEvent>> <$v(t,$var)>
1649      }
1650      if [string match playLabelEvent $var] {
1651       event delete <<PlayLabelEvent>> <$v($var)>
1652       event add <<PlayLabelEvent>> <$v(t,$var)>
1653      }
1654      if {$::tcl_version > 8.2 && [string match locked $var] == 1} {
1655       set c [$pane canvas]
1656       if $v(t,$var) {
1657        $c configure -state disabled
1658       } else {
1659        $c configure -state normal
1660       }
1661      }
1662      if {[string match format $var] || \
1663        [string match labext $var] || \
1664        [string match encoding $var] || \
1665        [string match labdir $var]} {
1666       if {$v(changed)} {
1667        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]]} {
1668         return
1669        }
1670       }
1671       set v($var) $v(t,$var)
1672       openTranscriptionFile $w $pane [$w getInfo fileName] soundfile
1673       set doRedraw 1
1674      }
1675      set v($var) $v(t,$var)
1676      if {[string match labColor $var] || \
1677          [string match bdColor $var] || \
1678          [string match font $var] || \
1679          [string match extBounds $var] || \
1680          [string match alignment $var] || \
1681          [string match bgColor $var]} {
1682       set doRedraw 1
1683      }
1684      if {[string match format $var]} {
1685       set formatChanged 1
1686      }
1687     }
1688    }
1689    if {[info exists doRedraw]} {
1690     $w _redrawPane $pane
1691    }
1692    if {[info exists formatChanged]} {
1693     wsurf::_remeberPropertyPage $w $pane
1694     wsurf::_drawPropertyPages $w $pane
1695    }
1696    for {set i 0} {$i < $v(menuNrows)} {incr i } {
1697     for {set j 0} {$j < $v(menuNcols)} {incr j } {
1698      set v($i$j) $v(t,$i$j)
1699     }
1700    }
1701   }
1702  }
1703 }
1704
1705 proc trans::drawPage1 {w pane path} {
1706  variable Info
1707  upvar [namespace current]::${pane}::var v
1708
1709  foreach f [winfo children $path] {
1710   destroy $f
1711  }
1712
1713  foreach var {format alignment labext labdir encoding \
1714    labColor bdColor bgColor \
1715    font locked quickenter quicktol extBounds linkBounds} {
1716   set v(t,$var) $v($var)
1717  }
1718
1719  pack [frame $path.f1] -anchor w
1720  label $path.f1.l -text "Label file format:" -width 25 -anchor w
1721  foreach {format loadProc saveProc} $Info(formats) {
1722   lappend tmp $format
1723  }
1724  eval tk_optionMenu $path.f1.om [namespace current]::${pane}::var(t,format) \
1725    $tmp
1726  pack $path.f1.l $path.f1.om -side left -padx 3
1727
1728  pack [frame $path.f2] -anchor w
1729  label $path.f2.l -text "Label alignment:" -width 25 -anchor w
1730  tk_optionMenu $path.f2.om [namespace current]::${pane}::var(t,alignment) \
1731    left center right
1732  $path.f2.om.menu entryconfigure 0 -value w
1733  $path.f2.om.menu entryconfigure 1 -value c
1734  $path.f2.om.menu entryconfigure 2 -value e
1735  pack $path.f2.l $path.f2.om -side left -padx 3
1736
1737  stringPropItem $path.f3 "Label filename extension:" 25 16 "" \
1738    [namespace current]::${pane}::var(t,labext)
1739
1740  pack [frame $path.f4] -anchor w
1741  label $path.f4.l -text "Label file path:" -width 25 -anchor w
1742  entry $path.f4.e -textvar [namespace current]::${pane}::var(t,labdir) -wi 16
1743  pack $path.f4.l $path.f4.e -side left -padx 3
1744  if {[info command tk_chooseDirectory] != ""} {
1745   button $path.f4.b -text Choose... \
1746     -command [namespace code [list chooseDirectory $w $pane]]
1747   pack $path.f4.b -side left -padx 3
1748  }
1749
1750  stringPropItem $path.f5 "Label file encoding:" 25 16 "" \
1751    [namespace current]::${pane}::var(t,encoding)
1752
1753  colorPropItem $path.f6 "Label color:" 25 \
1754    [namespace current]::${pane}::var(t,labColor)
1755
1756  colorPropItem $path.f7 "Boundary color:" 25 \
1757    [namespace current]::${pane}::var(t,bdColor)
1758
1759  colorPropItem $path.f8 "Background color:" 25 \
1760    [namespace current]::${pane}::var(t,bgColor)
1761
1762  stringPropItem $path.f9 "Font:" 25 16 "" \
1763    [namespace current]::${pane}::var(t,font)
1764
1765  if {$::tcl_version > 8.2} {
1766   booleanPropItem $path.f10 "Lock transcription" "" \
1767     [namespace current]::${pane}::var(t,locked)
1768  }
1769
1770  booleanPropItem $path.f11 "Quick transcribe" "" \
1771    [namespace current]::${pane}::var(t,quickenter)
1772
1773  stringPropItem $path.f12 "Max cursor movement for current label:" 34 4 \
1774    pixels [namespace current]::${pane}::var(t,quicktol)
1775
1776  booleanPropItem $path.f13 "Extend boundaries into waveform and spectrogram panes" "" \
1777    [namespace current]::${pane}::var(t,extBounds)
1778
1779  booleanPropItem $path.f14 "Move coinciding boundaries in other transcription panes" "" \
1780    [namespace current]::${pane}::var(t,linkBounds)
1781 }
1782
1783 proc trans::confPage {w pane path} {
1784  upvar [namespace current]::${pane}::var v
1785
1786  for {set i 0} {$i < $v(t,menuNrows)} {incr i } {
1787   if {![winfo exists $path.fl$i]} {
1788    pack [frame $path.fl$i] -anchor w
1789   }
1790   for {set j 0} {$j < $v(t,menuNcols)} {incr j } {
1791    if {![winfo exists $path.fl$i.e$j]} {
1792     pack [entry $path.fl$i.e$j -width 6 \
1793       -textvar [namespace current]::${pane}::var(t,$i$j)] -side left
1794    }
1795    $path.fl$i.e$j configure -font $v(t,font)
1796   }
1797   while {[winfo exists $path.fl$i.e$j] == 1} {
1798    destroy $path.fl$i.e$j
1799    incr j
1800   }
1801  }
1802  while {[winfo exists $path.fl$i] == 1} {
1803   destroy $path.fl$i
1804   incr i
1805  }
1806 }
1807
1808 proc trans::chooseDirectory {w pane} {
1809  upvar [namespace current]::${pane}::var v
1810  set dir $v(t,labdir)
1811  if {$dir == ""} {
1812   set dir .
1813  }
1814  set res [tk_chooseDirectory -initialdir $dir -mustexist yes]
1815  if {$res != ""} {
1816   set v(t,labdir) $res
1817  }
1818 }
1819
1820 proc trans::drawPage2 {w pane path} {
1821  upvar [namespace current]::${pane}::var v
1822
1823  foreach f [winfo children $path] {
1824   destroy $f
1825  }
1826
1827  foreach var {adjustLeftEvent adjustRightEvent playLabelEvent labelMenuEvent \
1828    menuNrows menuNcols highlight} {
1829   set v(t,$var) $v($var)
1830  }
1831  for {set i 0} {$i < $v(menuNrows)} {incr i } {
1832   for {set j 0} {$j < $v(menuNcols)} {incr j } {
1833    set v(t,$i$j) $v($i$j)
1834   }
1835  }
1836
1837  booleanPropItem $path.f0 "Highlight labels during playback" "" \
1838    [namespace current]::${pane}::var(t,highlight)
1839
1840  stringPropItem $path.f1 "Adjust left boundary event:" 28 25 "" \
1841    [namespace current]::${pane}::var(t,adjustLeftEvent)
1842
1843  stringPropItem $path.f2 "Adjust right boundary event:" 28 25 "" \
1844    [namespace current]::${pane}::var(t,adjustRightEvent)
1845
1846  stringPropItem $path.f3 "Play label event:" 28 25 "" \
1847    [namespace current]::${pane}::var(t,playLabelEvent)
1848
1849  stringPropItem $path.f4 "Label menu event:" 28 25 "" \
1850    [namespace current]::${pane}::var(t,labelMenuEvent)
1851
1852  pack [frame $path.f5] -anchor w
1853  pack [label $path.f5.l -text "Label menu pane:" -width 25 -anchor w] -padx 3
1854  pack [frame $path.f6] -anchor w
1855  pack [label $path.f6.lc -text "Columns:" -anchor w] -side left -padx 3
1856  pack [entry $path.f6.ec -width 2 -textvar \
1857    [namespace current]::${pane}::var(t,menuNcols)] -side left
1858  pack [label $path.f6.lr -text "Rows:" -anchor w] -side left
1859  pack [entry $path.f6.er -width 2 -textvar \
1860    [namespace current]::${pane}::var(t,menuNrows)] -side left
1861  pack [button $path.f6.b -text Update \
1862    -command [namespace code [list confPage $w $pane $path]]] -side left \
1863    -padx 3
1864  bind $path.f6.ec <Key-Return> [namespace code [list confPage $w $pane $path]]
1865  bind $path.f6.er <Key-Return> [namespace code [list confPage $w $pane $path]]
1866
1867  for {set i 0} {$i < $v(t,menuNrows)} {incr i } {
1868   pack [frame $path.fl$i] -anchor w
1869   for {set j 0} {$j < $v(t,menuNcols)} {incr j } {
1870    pack [entry $path.fl$i.e$j -font $v(t,font) \
1871      -textvar [namespace current]::${pane}::var(t,$i$j) -wi 6] \
1872      -side left
1873   }
1874  }
1875 }
1876
1877 proc trans::getConfiguration {w pane} {
1878  upvar [namespace current]::${pane}::var v
1879
1880  set result {}
1881  if {$pane==""} {return {}}
1882  if {$v(drawTranscription)} {
1883
1884   lappend labmenu $v(menuNcols) $v(menuNrows)
1885   for {set i 0} {$i < $v(menuNrows)} {incr i } {
1886    for {set j 0} {$j < $v(menuNcols)} {incr j } {
1887     if {[info exists v($i$j)]} {
1888      lappend labmenu $v($i$j)
1889     } else {
1890      lappend labmenu \"\"
1891     }
1892    }
1893   }
1894
1895   append result "\$widget trans::addTranscription \$pane\
1896     -alignment $v(alignment)\
1897     -format \"$v(format)\"\
1898     -extension \"$v(labext)\"\
1899     -labelcolor $v(labColor)\
1900     -boundarycolor $v(bdColor)\
1901     -backgroundcolor $v(bgColor)\
1902     -labeldirectory \"$v(labdir)\"\
1903     -fileencoding \"$v(encoding)\"\
1904     -labelmenuevent $v(labelMenuEvent)\
1905     -adjustleftevent $v(adjustLeftEvent)\
1906     -adjustrightevent $v(adjustRightEvent)\
1907     -playlabelevent $v(playLabelEvent)\
1908     -locked $v(locked)\
1909     -quickenter $v(quickenter)\
1910     -quickentertolerance $v(quicktol)\
1911     -extendboundaries $v(extBounds)\
1912     -linkboundaries $v(linkBounds)\
1913     -playhighlight $v(highlight)\
1914     -font \{$v(font)\}"
1915   append result " -labelmenu \{\n"
1916   append result "[lrange $labmenu 0 1]\n"
1917   for {set i 0} {$i < $v(menuNrows)} {incr i } {
1918    append result "[lrange $labmenu [expr 2+$i*$v(menuNcols)] [expr 1+($i+1)*$v(menuNcols)]]\n"
1919   }
1920   append result "\}"
1921   append result "\n"
1922  }
1923  return $result
1924 }
1925
1926 proc trans::cut {w t0 t1} {
1927  set dt [expr {$t1-$t0}]
1928  foreach pane [$w _getPanes] {
1929   upvar [namespace current]::${pane}::var v
1930   if $v(drawTranscription) {
1931    if {[llength $v(map)] == 0} continue
1932    set c [$pane canvas]
1933
1934    set i 0
1935    foreach ind $v(map) {
1936     if {$t0 < $v(t1,$ind,end)} break
1937     incr i
1938    }
1939
1940    # Adjust start time
1941    if {$t0 < $v(t1,start)} {
1942     if {$t1 < $v(t1,start)} {
1943      # Current selection is to the left of start time
1944      set v(t1,start) [expr {$v(t1,start)-$dt}]
1945     } else {
1946      # Left boundary of current selection is to the left of start time
1947      set v(t1,start) $t0
1948     }
1949    }
1950
1951    # Left boundary is new end time for first label
1952    if {$t0 < $v(t1,$ind,end) && \
1953      $t1 > $v(t1,$ind,end)} {
1954     set v(t1,$ind,end) $t0
1955     incr i
1956     set ind [lindex $v(map) $i]
1957    }
1958    set j $i
1959
1960    # Delete labels within the selection
1961    while {$ind != "" && $t1 > $v(t1,$ind,end)} {
1962     #       unset v(t1,$ind,label)
1963     #       unset v(t1,$ind,end)
1964     #       unset v(t1,$ind,rest)
1965     incr i
1966     set ind [lindex $v(map) $i]
1967    }
1968    if {$j <= [expr $i - 1] && $j < [llength $v(map)]} {
1969     set v(map) [lreplace $v(map) $j [expr $i - 1]]
1970     set v(nLabels) [llength $v(map)]
1971    }
1972
1973    # Move all remaining labels $dt to the left
1974    set ind [lindex $v(map) $j]
1975    while {$ind != "" && $t1 < $v(t1,$ind,end)} {
1976     set v(t1,$ind,end) [expr {$v(t1,$ind,end)-$dt}]
1977     incr j
1978     set ind [lindex $v(map) $j]
1979    }
1980    changed $w $pane
1981    $w _redrawPane $pane
1982   }
1983  }
1984 }
1985
1986 proc trans::copy {w t0 t1} {
1987  foreach pane [$w _getPanes] {
1988   upvar [namespace current]::${pane}::var v
1989   if $v(drawTranscription) {
1990    set c [$pane canvas]
1991    if {[$c focus] != {}} {
1992     set tag [$c focus]
1993     if {[catch {set s [$c index $tag sel.first]}]} return
1994     set e [$c index $tag sel.last]
1995     clipboard append [string range [$c itemcget $tag -text] $s $e]
1996    }
1997   }
1998  }
1999 }
2000
2001 proc trans::paste {w t length} {
2002  foreach pane [$w _getPanes] {
2003   upvar [namespace current]::${pane}::var v
2004   if $v(drawTranscription) {
2005    set c [$pane canvas]
2006    if {[focus] == $c && [$c focus] != $v(hidden)} {
2007     catch {set cbText [selection get -selection CLIPBOARD]}
2008     if {[info exists cbText] == 0} { return 0 }
2009     $c insert [$c focus] insert [selection get -selection CLIPBOARD]
2010     SetLabelText $w $pane [lindex [$c gettags [$c focus]] 0] \
2011         [$c itemcget [$c focus] -text]
2012     return 1
2013    }
2014   }
2015  }
2016  return 0
2017  list {
2018  foreach pane [$w _getPanes] {
2019   upvar [namespace current]::${pane}::var v
2020   if $v(drawTranscription) {
2021    if {[llength $v(map)] == 0} return
2022    set i 0
2023    foreach ind $v(map) {
2024     if {$t < $v(t1,$ind,end)} break
2025     incr i
2026    }
2027
2028    # Adjust start time
2029    if {$t < $v(t1,start)} {
2030     set v(t1,start) [expr {$v(t1,start)+$length}]
2031    }
2032
2033    # Move all remaining labels $length to the left
2034    while {$ind != ""} {
2035     set v(t1,$ind,end) [expr {$v(t1,$ind,end)+$length}]
2036     incr i
2037     set ind [lindex $v(map) $i]
2038    }
2039
2040    $w _redrawPane $pane
2041   }
2042  }}
2043 }
2044
2045 proc trans::find {w pane} {
2046  upvar [namespace current]::${pane}::var v
2047
2048  set p $v(browseTL)
2049  set v(nMatch) 0
2050  $p.f2.list delete 0 end
2051  set i 0
2052  if {$v(matchCase)} {
2053   set nocase ""
2054  } else {
2055   set nocase -nocase
2056  }
2057  foreach ind $v(map) {
2058   if {[eval regexp $nocase $v(pattern) \{$v(t1,$ind,label)\}]} {
2059    if {$i == 0} {
2060     set start $v(t1,start)
2061    } else {
2062     set prev [lindex $v(map) [expr $i-1]]
2063     set start $v(t1,$prev,end)
2064    }
2065    if {[string match *\"* \{$v(t1,$ind,label)\}]} {
2066     set tmp "\{$v(t1,$ind,label):\} $start $v(t1,$ind,end)"
2067    } else {
2068     set tmp "$v(t1,$ind,label): $start $v(t1,$ind,end)"
2069    }
2070    $p.f2.list insert end $tmp
2071    incr v(nMatch)
2072   }
2073   incr i
2074  }
2075 }
2076
2077 proc trans::select {w pane} {
2078  upvar [namespace current]::${pane}::var v
2079
2080  set p $v(browseTL)
2081
2082  set cursel [$p.f2.list curselection]
2083  if {$cursel == ""} return
2084  set start [lindex [$p.f2.list get [lindex $cursel 0]] end-1]
2085  set end   [lindex [$p.f2.list get [lindex $cursel end]] end]
2086  $w configure -selection [list $start $end]
2087  set s [$w cget -sound]
2088  set length [$s length -unit seconds]
2089  $w xscroll moveto [expr {$start/$length}]
2090 }
2091
2092 proc trans::findPlay {w pane} {
2093  upvar [namespace current]::${pane}::var v
2094
2095  set p $v(browseTL)
2096  set cursel [$p.f2.list curselection]
2097  if {$cursel != ""} {
2098   set start [lindex [$p.f2.list get [lindex $cursel 0]] end-1]
2099   set end   [lindex [$p.f2.list get [lindex $cursel end]] end]
2100   $w play $start $end
2101  }
2102 }
2103
2104 proc trans::browse {w pane} {
2105  upvar [namespace current]::${pane}::var v
2106
2107  regsub -all {\.} $pane _ tmp
2108  set v(browseTL) .browse$tmp
2109  catch {destroy .browse$tmp}
2110  set p [toplevel .browse$tmp]
2111  wm title $p "Browse Labels"
2112
2113  pack [frame $p.f]
2114  pack [entry $p.f.e -textvar [namespace current]::${pane}::var(pattern)]\
2115    -side left
2116  pack [button $p.f.l -text Find \
2117    -command [namespace code [list find $w $pane]]] -side left
2118
2119  pack [ label $p.l -text "Results:"]
2120  pack [ frame $p.f2] -fill both -expand true
2121  pack [ scrollbar $p.f2.scroll -command "$p.f2.list yview"] -side right \
2122    -fill y
2123  listbox $p.f2.list -yscroll "$p.f2.scroll set" -setgrid 1 \
2124    -selectmode extended -height 6 -width 40
2125  pack $p.f2.list -side left -expand true -fill both
2126
2127  pack [checkbutton $p.cb -text "Match case" -anchor w \
2128    -variable [namespace current]::${pane}::var(matchCase)]
2129
2130  pack [ frame $p.f3] -pady 10 -fill x -expand true
2131  pack [ button $p.f3.b1 -bitmap snackPlay \
2132    -command [namespace code [list findPlay $w $pane]]] \
2133    -side left
2134  pack [ button $p.f3.b2 -bitmap snackStop -command "$w stop"] -side left
2135  pack [ button $p.f3.b3 -text Close -command "destroy $p"] -side right
2136
2137  bind $p.f.e <Return> [namespace code [list find $w $pane]]
2138  bind $p.f2.list <ButtonRelease-1> [namespace code [list select $w $pane]]
2139  if {$v(pattern) != ""} {
2140   find $w $pane
2141  }
2142  bind $p.f2.list <Double-Button-1> [namespace code [list findPlay $w $pane]]
2143  focus $p.f.e
2144 }
2145
2146 proc trans::convert {w pane} {
2147  upvar [namespace current]::${pane}::var v
2148  variable Info
2149  regsub -all {\.} $pane _ tmp
2150  set v(convertTL) .convert$tmp
2151  catch {destroy .convert$tmp}
2152  set p [toplevel .convert$tmp]
2153  wm title $p "Convert Transcription File format"
2154
2155  pack [ label $p.l1 -text "Current transcription file format: $v(format)"]
2156
2157  set v(t,format) $v(format)
2158  pack [frame $p.f1] -anchor w
2159  label $p.f1.l -text "New transcription file format:" -anchor w
2160  foreach {format loadProc saveProc} $Info(formats) {
2161   lappend fmtlist $format
2162  }
2163  eval tk_optionMenu $p.f1.om [namespace current]::${pane}::var(t,format) \
2164    $fmtlist
2165  pack $p.f1.l $p.f1.om -side left -padx 3
2166
2167  pack [frame $p.f]
2168  pack [ button $p.f.b1 -text OK -command [namespace code [list doConvert $w $pane]]\n[list destroy $p]] -side left -padx 3
2169  pack [ button $p.f.b2 -text Close -command "destroy $p"] -side left -padx 3
2170 }
2171
2172 proc trans::doConvert {w pane} {
2173  upvar [namespace current]::${pane}::var v
2174  set v(format) $v(t,format)
2175 }
2176
2177 proc trans::play {w} {
2178  foreach pane [$w _getPanes] {
2179   upvar [namespace current]::${pane}::var v
2180   if {$v(drawTranscription) && $v(highlight)} {
2181    set v(playIndex) 0
2182   }
2183  }
2184  after 200 [namespace code [list _updatePlay $w]]
2185 }
2186
2187 proc trans::stop {w} {
2188  foreach pane [$w _getPanes] {
2189   upvar [namespace current]::${pane}::var v
2190   set c [$pane canvas]
2191   if {$v(drawTranscription)} {
2192    after cancel [namespace code [list FindNextLabel $w $pane]]
2193   }
2194  }
2195 }
2196
2197 proc trans::_updatePlay {w} {
2198  if {[winfo exists $w] == 0} {
2199   return
2200  }
2201  if {[$w getInfo isPlaying] == 0} {
2202   foreach pane [$w _getPanes] {
2203    upvar [namespace current]::${pane}::var v
2204    set c [$pane canvas]
2205    if {$v(drawTranscription)} {
2206     if {$v(highlight) && [info exists v(playIndex)]} {
2207      set ind [lindex $v(map) $v(playIndex)]
2208      if {$ind != ""} {
2209       $c itemconf g$ind -fill $v(bgColor)
2210      }
2211     }
2212    }
2213   }
2214   return
2215  }
2216  set s [$w cget -sound]
2217  foreach pane [$w _getPanes] {
2218   upvar [namespace current]::${pane}::var v
2219   if {$v(drawTranscription) && $v(highlight)} {
2220    set cursorpos [$pane cget -cursorpos]
2221    set c [$pane canvas]
2222    set ind [lindex $v(map) $v(playIndex)]
2223    if {$ind != ""} {
2224     $c itemconf g$ind -fill $v(bgColor)
2225     while (1) {
2226      set ind [lindex $v(map) $v(playIndex)]
2227      if {$ind == ""} return
2228      if {$cursorpos < $v(t1,$ind,end)} break
2229      incr v(playIndex)
2230     }
2231     $c itemconf g$ind -fill [$w cget -cursorcolor]
2232    }
2233   }
2234  }
2235  if {[$w getInfo isPlaying]} {
2236   after 50 [namespace code [list _updatePlay $w]]
2237  }
2238 }
2239
2240 # -----------------------------------------------------------------------------
2241 # !!! experimental
2242
2243 proc trans::regCallback {name callback script} {
2244  variable Info
2245 # puts [info level 0]
2246  if {$callback != "-transcription::transcriptionchangedproc"} {
2247   error "unknown callback \"$callback\""
2248  } else {
2249   set Info(Callback,$name,transChangedProc) $script
2250  }
2251 }
2252
2253 proc trans::changed {w pane} {
2254 # puts [info level 0]([info level -1])
2255  variable Info
2256  upvar [namespace current]::${pane}::var v
2257  set v(changed) 1
2258  foreach key [array names Info Callback,*,transChangedProc] {
2259   puts "invoking callback $key"
2260   $Info($key) $w $pane
2261  }
2262 }
2263
2264
2265
2266
2267
2268
2269 proc trans::SplitSoundFile {w pane} {
2270  upvar [namespace current]::${pane}::var v
2271  set s [$w cget -sound]
2272
2273  foreach ind $v(map) {
2274   set start [expr {int([GetStartByIndex $w $pane $ind] * [$s cget -rate])}]
2275   set end   [expr {int($v(t1,$ind,end) * [$s cget -rate])}]
2276   $s write $v(t1,$ind,label).wav -start $start -end $end
2277  }
2278 }