pianoroll

# see http://wiki.tcl.tk/11198
console show
namespace eval ::xt {
    variable grid_oh
	variable grid_ow
	variable notes
	variable k
	set k 0
	array set notes {}
	array set grid_oh {}
	array set grid_ow {}
	
    proc proll_draw {w target x y type div size {cmd ""}} {
	variable grid_oh
	variable grid_ow
	variable notes
	variable k
    set x [$w canvasx $x]
    set y [$w canvasy $y]
    switch -- $type {
	left {
	for {set i 0} {$i <= [expr $div - 1]} {incr i} {
	    set j [expr $i + 1]
	    if {$grid_oh($i) <=$x && $x <=$grid_oh($j)} {
		set x1 $grid_oh($i)
		set x2 $grid_oh($j)
		}
	    if {$grid_ow($i) <=$y && $y <=$grid_ow($j)} {
		set y1 $grid_ow($i)
		set y2 $grid_ow($j)
		}
		}
	$w create rectangle $x1 $y1 $x2 $y2 -fill red -tags $x1$y1
	set k [expr $k + 1]
	set notes($k) $x$y
	pd "$target.rp _cb [array size notes] $notes($k);"
        }
	right {
	for {set i 0} {$i <= [expr $div - 1]} {incr i} {
	    set j [expr $i + 1]
	    if {$grid_oh($i) <=$x && $x <=$grid_oh($j)} {
		set x1 $grid_oh($i)
		set x2 $grid_oh($j)
		}
	    if {$grid_ow($i) <=$y && $y <=$grid_ow($j)} {
		set y1 $grid_ow($i)
		set y2 $grid_ow($j)
		}
		}
	    $w delete $x1$y1
		unset notes($k)
	}
	motion {
	    set item [$w find withtag rect]
	    foreach {x0 y0 x1 y1} [$w coords $item] break
	    $w coords $item $x0 $y0 $x $y
	}
	release {
	    uplevel \#0 [lappend cmd [$w coords [$w find withtag rect]]]
	}
    }
#	set rs [expr $size / 2]
#	$w coords ${target}sqr [expr $x - $rs] [expr $y - $rs] [expr $x + $rs] [expr $y + $rs]
	
 }

    proc proll_new {path target w h bg fg ln div shape size} {
	variable grid_oh
	variable grid_ow

	if {[winfo exists $path.proll] != 1} {
	    canvas $path.proll -bg $bg
	    $path configure -width $w -height $h
	    place $path.proll -anchor nw -relwidth 1 -relheight 1
#	    $path.proll create $shape 0 0 0 0 -fill $fg -tags ${target}sqr
#	    proll_click $path.proll $target 1 0.5 0.5 $h $w $size
	    proll_lines $path.proll $target $div $w $h $ln
	    bind $path.proll <Double-1> "::xt::proll_draw %W $target %x %y left  $div $size"
	    bind $path.proll <3> "::xt::proll_draw %W $target %x %y right $div $size"
#	    bind $path.proll <B1-Motion> "::xt::proll_draw %W $target %x %y motion $div $size"
#		bind $path.proll <ButtonRelease-1> "::xt::proll_draw %W $target %x %y release $size $ln {xt::proll_diag %W $target} "
	}
    }
    proc proll_lines {w target lines ww hw color} {
	variable grid_oh
	variable grid_ow
	set grid_oh(0) 0
	set grid_ow(0) 0
	$w delete prolllines
	for {set x 1} {$x <= $lines} {incr x} {
	    if {$lines < 64} {
		set oh [expr $hw.0 * $x.0 / $lines.0]
		set ow [expr $ww.0 * $x.0 / $lines.0]
		set grid_oh($x) $oh
		set grid_ow($x) $ow

	      	$w create line $ow 0 $ow $hw -fill $color -tags prolllines
	      	$w create line 0 $oh $ww $oh -fill $color -tags prolllines
	    }
	}
	$w raise ${target}sqr
    }
}

#> proll frame
#. -bd 3
#. #w 128 #h 128 #x 0.5 #y 0.5
#. #fg red #bg blue #ln yellow
#. #shape rectangle #size 12 #div 12
#. @list ::xt::proll_draw .-.proll .| .#x .#y .#h .#w .#size

::xt::proll_new .- .| .#w .#h .#bg .#fg .#ln .#div .#shape .#size