#!/usr/bin/env tclsh

package require Tk

# Backward compatibility with Tcl 8.4.
if {[catch {lassign {}}]} {
    proc lassign {vals args} {
        lappend vals ""
        uplevel 1 [list foreach $args $vals break]
        lrange $vals [llength $args] end-1
    }
}

proc harmonic-configure {win Sx Sy} {
    set notes {
        {C       #000 #fff} {C\u266f #fff #000} {D       #000 #adf}
        {E\u266d #fff #000} {E       #000 #fff} {F       #000 #fff}
        {F\u266f #fff #000} {G       #000 #fff} {G\u266f #fff #009}
        {A       #000 #fff} {B\u266d #fff #000} {B       #000 #fff}
    }

    set Nx 24
    set Ny 12
    set Dx [expr {int($Sx / ($Nx + 1. / 3))}]; set Dx [expr {$Dx - $Dx % 3}]
    set Dy [expr {int($Sy / ($Ny + 1. / 2))}]; set Dy [expr {$Dy - $Dy % 2}]
    set Rx [expr {$Dx / 3}]
    set Ry [expr {$Dy / 2}]
    set Px [expr {($Sx - ($Nx - 1) * $Dx) / 2}]
    set Py [expr {($Sy - (($Ny - 1) * $Dy + $Ry)) / 2}]

    $win delete all
    for {set Ix 0; set Cx $Px} {$Ix < $Nx} {incr Ix; incr Cx $Dx} {
        set Cy [expr {$Py + $Ix % 2 * $Ry}]
        for {set Iy 0} {$Iy < $Ny} {incr Iy; incr Cy $Dy} {
            set i [expr {((($Ny - $Iy - 1 + $Ix / 2) * 7 + $Ix * 9)) % 12}]
            lassign [lindex $notes $i] label foreground background
            $win create polygon [expr {$Cx + 2 * $Rx}] $Cy\
                                [expr {$Cx + $Rx}] [expr {$Cy + $Ry}]\
                                [expr {$Cx - $Rx}] [expr {$Cy + $Ry}]\
                                [expr {$Cx - 2 * $Rx}] $Cy\
                                [expr {$Cx - $Rx}] [expr {$Cy - $Ry}]\
                                [expr {$Cx + $Rx}] [expr {$Cy - $Ry}]\
                -outline #777 -fill $background
            $win create text $Cx $Cy -text $label -fill $foreground
        }
    }
}

proc harmonic {win} {
    canvas $win -highlightthickness 0
    bind $win <Configure> {harmonic-configure %W %w %h}
    return $win
}

pack [harmonic .h] -fill both -expand true