- Uses spinbox menubutton
package require Tk 8.4
source spin_mb.tcl
catch {toplevel .}
canvas .c -width 500 -height 80
spin_mb .root -cycle -variable ::root -values {C C# D D# E F F# G G# A A# B}
spin_mb .mode -cycle -variable ::mode -values {maj min 7 maj7 aug dim sus4}
grid .c -row 0 -column 0 -columnspan 13
grid .root -row 1 -column 0
grid .mode -row 1 -column 1
grid columnconfigure . 12 -weight 1
proc create7keys {cnv x y xsize ysize oct action} {
set x1 $x ; set y2 [expr $y+$ysize] ; set sz [expr $xsize/7] ; set x2 [expr $x+$sz]
set n [expr $oct*12]
foreach K {C D E F G A B} {
$cnv create rectangle $x1 $y $x2 $y2 -tags [list k wk ${K}-${oct} n$n]
$cnv bind ${K}-${oct} <ButtonPress-1> [list $action $cnv ${K}-${oct}]
set x1 [expr $x1+$sz] ; set x2 [expr $x2+$sz]
if {$K == "E"} {incr n 1} {incr n 2}
}
set y2 [expr $y+$ysize*0.6] ; set sz [expr $xsize/12] ; set x1 [expr $x] ; set x2 [expr $x1+$sz]
set n [expr $oct*12+1]
foreach K {C# D# nul F# G# A#} {
set x1 [expr $x1+$sz] ; set x2 [expr $x2+$sz]
if {$K == "nul"} {incr n 1; continue}
$cnv create rectangle $x1 $y $x2 $y2 -tags [list k bk ${K}-${oct} n$n]
$cnv bind ${K}-${oct} <ButtonPress-1> [list $action $cnv ${K}-${oct}]
set x1 [expr $x1+$sz] ; set x2 [expr $x2+$sz]
incr n 2
}
}
proc togglekey {cnv tag} {
if {[lsearch -exact [$cnv gettags $tag] act] != -1} \
{ $cnv dtag $tag act } \
{ $cnv addtag act withtag $tag }
upd $cnv
}
proc setkey {cnv tag {st 1}} {
if {[lsearch -exact [$cnv gettags $tag] act] != -1} \
{ $cnv dtag $tag act } \
{ $cnv addtag act withtag $tag }
upd $cnv
}
proc setkeyN {cnv n {st 1}} {
set tag n$n
if {[lsearch -exact [$cnv gettags $tag] act] != -1} \
{ $cnv dtag $tag act } \
{ $cnv addtag act withtag $tag }
}
proc setroot {cnv notetag} {
set ::root [lindex [split $notetag -] 0]
set ::nroot [string map {C# 1 D# 3 F# 6 G# 8 A# 10 C 0 D 2 E 4 F 5 G 7 A 9 B 11} $::root]
makechord $::nroot $::mode
}
proc lcheck {l i} {if {[lsearch -exact $l $i] != -1} {return 1} {return 0}}
proc onsetmode {args} {makechord $::nroot $::mode}
proc onsetroot {args} {setroot .c $::root-1}
proc upd {cnv} {foreach {t a v} {k outline black wk fill white bk fill black act fill red} {$cnv itemconfigure $t -$a $v}}
proc makechord {root mode} {
if {[lcheck $mode maj]} { set intervals {0 7 12 16 19} }
if {[lcheck $mode min]} { set intervals {0 7 12 15 19} }
if {[lcheck $mode 7]} { set intervals {0 10 16 19 22} }
if {[lcheck $mode maj7]} { set intervals {0 11 16 19 23} }
if {[lcheck $mode aug]} { set intervals {0 8 12 16 20} }
if {[lcheck $mode dim]} { set intervals {0 6 12 15 18} }
if {[lcheck $mode sus]} { set intervals {0 7 12 17 19} }
if {[lcheck $mode sus4]} { set intervals {0 7 12 17 19} }
.c dtag act act
foreach i $intervals {setkeyN .c [expr $root+$i]}
upd .c
}
set ::keycount 0
set x 0
for {set i 0} {$i < 3} {incr i} {create7keys .c $x 0 168 75 $i setroot ; incr x 168 ; incr ::keycount 12}
upd .c
trace add variable ::root write onsetroot
trace add variable ::mode write onsetmode
set ::root C
set ::mode majAMG: I found a similar chord finder online, written in Flash.Flash program: [1]Description: [2]"Find music chords for piano, and listen to the chords playing to you."
