# # $Id: chordbox.tcl,v 1.4 2002/08/28 15:39:51 t16 Exp $ # # Graphical helper tool for gchords.sty, written by David R. Lovell, # with additions by Kasper Peeters. # upvar #0 ChordBoxInfo cb upvar #0 BlotArray blot upvar #0 DampArray damp wm title . "Chord Box" frame .top frame .middle frame .bottom set strings 6 set frets [lindex $argv 0] if {$frets == ""} { puts "Usage: wish chordbox.tcl \[number of frets\]" exit } set dx 0.5 set dy 1.0 set left $dx set right [expr $left + ($strings - 1) * $dx] set width [expr $right + $left] set bottom [expr 0.3 * $dy] set top [expr $bottom + ($frets - 1) * $dy] set height [expr $top + $bottom] set xgrid [expr $dx] set ygrid [expr $dy] canvas .c -width ${width}c -height ${height}c .c config -cursor dot set cb(rad) [winfo fpixels .c [expr 0.3 * $dx]c] set cb(gridx) [winfo fpixels .c ${dx}c] set cb(gridy) [winfo fpixels .c ${dy}c] set cb(left) [winfo fpixels .c ${left}c] set cb(right) [winfo fpixels .c ${right}c] set cb(top) [winfo fpixels .c [expr ($frets - 1) * $dy]c] set cb(bottom) [winfo fpixels .c ${dy}c] set cb(nut) [winfo fpixels .c ${bottom}c] set cb(damp) [winfo fpixels .c [expr $bottom / 2]c] #label .name -text "Name: " #entry .nameentry -width 15 -relief sunken -bd 2 -textvariable name label .spell -text "Name: " entry .spellentry -width 15 -relief sunken -bd 2 -textvariable spelling scale .zerofret -from -1 -to 24 -length ${height}c -width 0.3c -orient vertical -variable zerofret #set zerofret -1 button .print -text Print -command print button .quit -text Quit -command exit pack .print .quit -in .top -side left -fill x -expand 1 pack .zerofret .c -in .middle -side left -fill y -expand 1 pack .spellentry .spell -in .bottom -side bottom -padx 1m -pady 1m #pack .nameentry .name -in .bottom -side bottom -padx 1m -pady 1m pack .top .middle .bottom -side top -fill x -expand 1 for {set i 0} {$i < $strings} {incr i} { set x [expr $left + $i * $dx] .c create line ${x}c ${bottom}c ${x}c ${top}c } for {set i 0} {$i < [expr $frets - 1]} {incr i} { set y [expr $bottom + $i * $dy] .c create line ${left}c ${y}c ${right}c ${y}c } bind .c <1> "mkBlot .c %x %y" proc mkBlot { c x y } { upvar #0 ChordBoxInfo cb upvar #0 BlotArray blot upvar #0 DampArray damp set cx [$c canvasx $x $cb(gridx)] set cy [$c canvasy $y $cb(gridy)] if {($cx < $cb(left))} { set cx $cb(left) } if {($cx > $cb(right))} { set cx $cb(right) } if {($cy < $cb(nut))} { set s [expr round($cx / $cb(gridx))] if [info exists damp($s)] { $c delete $damp($s) unset damp($s) } else { set damp($s) [$c create line \ [expr $cx - $cb(rad)] [expr $cb(damp) - $cb(rad)]\ [expr $cx + $cb(rad)] [expr $cb(damp) + $cb(rad)]\ $cx $cb(damp) \ [expr $cx - $cb(rad)] [expr $cb(damp) + $cb(rad)]\ [expr $cx + $cb(rad)] [expr $cb(damp) - $cb(rad)]\ ] } return } if {($cy < $cb(bottom))} { set cy $cb(bottom) } if {($cy > $cb(top))} { set cy $cb(top) } set f [expr round($cy / $cb(gridy))] set s [expr round($cx / $cb(gridx))] # puts "$x, $y = ($cx,$cy), $s, $f" if [info exists blot($s,$f)] { $c delete $blot($s,$f) unset blot($s,$f) } else { set blot($s,$f) [$c create oval\ [expr $cx - $cb(rad)] [expr $cy - $cb(rad)] \ [expr $cx + $cb(rad)] [expr $cy + $cb(rad)] -fill black] } } proc print {} { upvar #0 ChordBoxInfo cb upvar #0 frets frets upvar #0 strings strings upvar #0 zerofret zerofret # upvar #0 name name upvar #0 spelling spelling upvar #0 BlotArray blot upvar #0 DampArray damp puts "\\def\\numfrets\{$frets\}" puts -nonewline "\\chord\{" if {$zerofret == 0} { puts -nonewline "t" } if {$zerofret > 0} { puts -nonewline $zerofret } puts -nonewline "\}\{" for {set s 1} {$s <= $strings} {incr s} { set nmarks 0 for {set f 0} {$f < $frets} {incr f} { if [info exists blot($s,$f)] { puts -nonewline "p\{$f\}" incr nmarks } } if {$nmarks == 0} { if [info exists damp($s)] { puts -nonewline "x" } else { puts -nonewline "n" } } if {$s < $strings} { puts -nonewline "," } } puts -nonewline "\}\{" # if { $name != "" } { # puts -nonewline "$name" # } # # puts -nonewline "\}\{" if { $spelling != "" } { regsub -all , $spelling \},\{ texspelling regsub -all b $texspelling \\ensuremath\{\\flat\} texspelling regsub -all \# $texspelling \\ensuremath\{\\sharp\} texspelling puts -nonewline "\{$texspelling\}" } puts "\}" }