1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
#
# $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 "\}"
}
|
