Tcl Tk入門/Canvas/ピアノロールGUI
をテンプレートにして作成
[
トップ
] [
新規
|
一覧
|
単語検索
|
最終更新
|
ヘルプ
|
ログイン
]
開始行:
''[[FrontPage]]''
* ピアノロールなGUIを作る [#v60487ec]
市販DAW並のGUIを目指す。~
サンプルコード上のコメントをもって解説に替える。~
~
&color(#FF0000){一旦クローズ};
** 制約事項 [#p6b64a19]
ってかよく分かんない。~
OSはWindows、Active_Tcl 8.5.5.0で、デモを真似しながらぼち...
~
~
ファイル名:styleSeq.tcl
# HEAD *************************************************...
source "*:/*****/tcl/lib/mylib/PR_drawing.tcl" ...
package require Tk ...
package require pr_drawing ...
#/HEAD *************************************************...
# Namespace PIANO_ROLL_MAIN ****************************...
namespace eval PIANO_ROLL_MAIN { ...
namespace export * ...
# Style Seq ********************************************...
wm title . "StyleSeq" ...
wm geometry . 541x280+250+200 ...
...
set tk_demoDirectory "*:\\*****\\tcl\\demos\\Tk8.5\\imag...
set font {Times 10} ...
...
# Set Bar Definition ***********************************...
set barDefinition(barLen) 20 ...
set barDefinition(grid_h) 5 ...
set barDefinition(grid_v) 5 ...
set barDefinition(left) 15 ...
set barDefinition(right) 5435 ...
set barDefinition(top) 13 ...
set barDefinition(bottom) 438 ...
set barDefinition(size) 2 ...
set barDefinition(normalStyle) "-fill green -stipple {}"...
...
#if {[winfo depth .c] > 0} { ...
# set barDefinition(activeStyle) "-fill red -stipple ...
# set barDefinition(moveStyle) [list -fill yellow \
# -stipple @[file join $tk_demoDirectory gray25.x...
#} else { ...
# set barDefinition(activeStyle) "-fill black -stippl...
# set barDefinition(moveStyle) [list -fill black \
# -stipple @[file join $tk_demoDirectory gray25.x...
#} ...
set barDefinition(activeStyle) "-fill red -stipple {}" ...
set barDefinition(moveStyle) [list -fill yellow \
-stipple @[file join $tk_demoDirectory gray25.xbm]] ...
#/Set Bar Definition ***********************************...
# Tool Bar 01 ******************************************...
frame .tBar01 ...
grid .tBar01 -row 0 -columnspan 2 -sticky ew ...
#grid columnconfigure . 1 -weight 1 ...
...
button .tBar01.exit -font {Times 8} -text "Exit" -comman...
pack .tBar01.exit -side left -padx 2 -pady 2 ...
#pack .tBar01.exit -side left ...
...
label .tBar01.l_msg -font $font -wraplength 200 -justify...
-text "This is only a test." -relief sunken ...
pack .tBar01.l_msg -side left -after .tBar01.exit -padx ...
#pack .tBar01.l_msg -side left -after .tBar01.exit ...
...
label .tBar01.r_msg -font $font -wraplength 200 -justify...
-text "This is only a test." -relief sunken ...
pack .tBar01.r_msg -side right -fill x -padx 2 -pady 2 ...
#pack .tBar01.r_msg -side right -fill x ...
#/Tool Bar 01 ******************************************...
# Canvas for Piano Roll ********************************...
canvas .scaleC -background white -width 486 -height 32 \
-scrollregion {5 2 5475 32} -xscrollcommand {.xsbar ...
...
canvas .c -background white -width 486 -height 121 \
-scrollregion {5 2 5475 444} \
-xscrollcommand {.xsbar set} -yscrollcommand {.ysbar...
# .c configure -xscrollincrement 0.5i -yscrollincreme...
...
canvas .keyC -background white -width 50 -height 121 \
-scrollregion {5 2 55 444} -yscrollcommand {.ysbar s...
# .keyC configure -xscrollincrement 0.5i -yscrollincr...
...
#.c configure -scrollregion [.c bbox all] \ ...
...
scrollbar .xsbar -orient horizontal \
-command {::PIANO_ROLL_MAIN::scrollMultiple .c .scal...
scrollbar .ysbar -orient vertical \
-command {::PIANO_ROLL_MAIN::scrollMultiple .c .keyC...
...
::PR_DRAWING::pianoRoll 25 13 -25 ...
...
grid .scaleC -row 1 -column 1 -sticky ew -padx 0 ...
grid .keyC -row 2 -column 0 -sticky nsew -padx 0 ...
grid .c -row 2 -column 1 -sticky nsew -padx 0 ...
grid .ysbar -row 2 -column 2 -sticky ns -padx 0 ...
#grid .keyC .c .ysbar -sticky news ...
grid .xsbar -row 3 -columnspan 2 -sticky ew ...
#/Canvas for Piano Roll ********************************...
# Sub Canvas *******************************************...
canvas .subC -background white -width 510 -height 30 ...
grid .subC -row 4 -columnspan 2 -padx 2 -pady 2 -sticky ...
...
.subC addtag tower withtag [.subC create rect 10 10 40 2...
-outline black -fill [lindex [.c config -bg] 4]] ...
.subC addtag cBar withtag [::PR_DRAWING::cBarGeneration ...
#/Sub Canvas *******************************************...
# Status Bar *******************************************...
frame .sBar -borderwidth 1 -relief sunken ...
grid .sBar -row 5 -columnspan 3 -padx 2 -pady 2 -sticky ...
...
label .sBar.coordinate -font $font -wraplength 5i -justi...
pack .sBar.coordinate -side right ...
...
label .sBar.delta -font $font -wraplength 5i -justify le...
pack .sBar.delta -side left ...
#/Status Bar *******************************************...
# Grid Configuration ***********************************...
grid rowconfigure . 2 -weight 1 ...
grid columnconfigure . 1 -weight 1 ...
#/Grid Configuration ***********************************...
# BIND *************************************************...
bind .c <Motion> { PIANO_ROLL_MAIN::senseMotion %x %y } ...
bind .c <Double-1> { PIANO_ROLL_MAIN::barGeneration .c %...
.c bind dBar <1> { PIANO_ROLL_MAIN::selectBar .c %x %y }...
.c bind dBar <Double-3> { PIANO_ROLL_MAIN::deleteBar .c ...
bind .c <B1-Motion> { PIANO_ROLL_MAIN::moveBar .c %x %y ...
#bind .c <B3-Motion> { PIANO_ROLL_MAIN::moveBar .c %x %y...
bind .c <Any-ButtonRelease-1> { PIANO_ROLL_MAIN::release...
#bind .c <Any-ButtonRelease-3> { PIANO_ROLL_MAIN::releas...
bind . <F1> { PIANO_ROLL_MAIN::modBarLen .subC 5 } ...
bind . <F2> { PIANO_ROLL_MAIN::modBarLen .subC 10 } ...
bind . <F3> { PIANO_ROLL_MAIN::modBarLen .subC 15 } ...
bind . <F4> { PIANO_ROLL_MAIN::modBarLen .subC 20 } ...
bind .c <1> { focus .c } ...
bind .c <MouseWheel> { PIANO_ROLL_MAIN::senseWheels .c %...
bind .c <Shift-MouseWheel> { PIANO_ROLL_MAIN::senseWheel...
#/BIND *************************************************...
.c yview moveto 0.35 ...
.keyC yview moveto 0.35 ...
#/Style Seq ********************************************...
# Bar Generation ***************************************...
proc barGeneration {c x y} { ...
variable ::PIANO_ROLL_MAIN::barDefinition ...
if {[$c find withtag active] != {}} { ...
return ...
} ...
$c addtag active withtag [::PR_DRAWING::cBarGenerati...
$c addtag dBar withtag active ...
set barDefinition(x) $x ...
set barDefinition(y) $y ...
moveBar $c $barDefinition(x) $barDefinition(y) ...
} ...
#/Bar Generation ***************************************...
# Move Bar *********************************************...
proc moveBar {c x y} { ...
variable ::PIANO_ROLL_MAIN::barDefinition ...
if {[$c find withtag active] == ""} { ...
return ...
} ...
set cx [$c canvasx $x $barDefinition(grid_h)] ...
set cy [$c canvasy $y $barDefinition(grid_v)] ...
...
set coords [$c coords active] ...
set actBarWidth [expr {[lindex $coords 2] - [lindex ...
set rLimit [expr { $barDefinition(right) + 20 - $act...
...
if {$cx < $barDefinition(left)} { ...
set cx $barDefinition(left) ...
} ...
if {$cx > $rLimit} { ...
set cx $rLimit ...
} ...
if {$cy < $barDefinition(top)} { ...
set cy $barDefinition(top) ...
} ...
if {$cy > $barDefinition(bottom)} { ...
set cy $barDefinition(bottom) ...
} ...
...
set cy [expr {$cy - $barDefinition(size)}] ...
eval "$c itemconf active $barDefinition(moveStyle)" ...
...
$c move active [expr {$cx - $barDefinition(x)}] [exp...
set barDefinition(x) $cx ...
set barDefinition(y) $cy ...
} ...
#/Move Bar *********************************************...
# Release Bar ******************************************...
proc releaseBar c { ...
variable ::PIANO_ROLL_MAIN::barDefinition ...
if {[$c find withtag active] == {}} { ...
return ...
} ...
eval "$c itemconf active $barDefinition(normalStyle)...
$c dtag active ...
} ...
#/Release Bar ******************************************...
# Select Bar *******************************************...
proc selectBar {c x y} { ...
variable ::PIANO_ROLL_MAIN::barDefinition ...
if {[$c find withtag active] != {}} { ...
return ...
} ...
$c addtag active withtag current ...
set coords [$c coords active] ...
set barDefinition(x) [lindex $coords 0] ...
set barDefinition(y) [lindex $coords 1] ...
eval "$c itemconf active $barDefinition(activeStyle)...
$c raise active ...
# moveBar $c $barDefinition(x) $barDefinition(y) ...
} ...
#/Select Bar *******************************************...
# Delete Bar *******************************************...
proc deleteBar c { ...
$c delete current ...
} ...
#/Delete Bar *******************************************...
# Modify Bar Length ************************************...
proc modBarLen {t len} { ...
variable ::PIANO_ROLL_MAIN::barDefinition ...
.subC delete cBar ...
set barDefinition(barLen) $len ...
.subC addtag cBar withtag [::PR_DRAWING::cBarGenerat...
} ...
#/Modify Bar Length ************************************...
# Sense Motion *****************************************...
proc senseMotion { x y } { ...
variable ::PIANO_ROLL_MAIN::.sBar.coordinate ...
.sBar.coordinate configure \
-text [format "x: %4i y: %4i" $x $y ] ...
} ...
#/Sense Motion *****************************************...
# Sense Wheels *****************************************...
proc senseWheels { c d horiz } { ...
variable ::PIANO_ROLL_MAIN::.sBar.delta ...
.sBar.delta configure \
-text [format "delta: %4i" $d ] ...
...
if { 0 == $horiz } { ...
if { $d <= 0 } { ...
$c yview scroll 1 units ...
.keyC yview scroll 1 units ...
} else { ...
$c yview scroll -1 units ...
.keyC yview scroll -1 units ...
} ...
} else { ...
if { $d < 0 } { ...
$c xview scroll 2 units ...
.scaleC xview scroll 2 units ...
} else { ...
$c xview scroll -2 units ...
.scaleC xview scroll -2 units ...
} ...
} ...
} ...
#/Sense Wheels *****************************************...
# Scroll Multiple **************************************...
proc scrollMultiple { c1 c2 horiz args } { ...
set cnt 0 ...
foreach elem $args { ...
set elemA($cnt) $elem ...
incr cnt ...
} ...
...
if { 0 == $horiz } { ...
if { 3 == $cnt } { ...
$c1 yview $elemA(0) $elemA(1) $elemA(2) ...
$c2 yview $elemA(0) $elemA(1) $elemA(2) ...
} elseif { 2 == $cnt } { ...
$c1 yview $elemA(0) $elemA(1) ...
$c2 yview $elemA(0) $elemA(1) ...
} else { ...
return -1 ...
} ...
} else { ...
if { 3 == $cnt } { ...
$c1 xview $elemA(0) $elemA(1) $elemA(2) ...
$c2 xview $elemA(0) $elemA(1) $elemA(2) ...
} elseif { 2 == $cnt } { ...
$c1 xview $elemA(0) $elemA(1) ...
$c2 xview $elemA(0) $elemA(1) ...
} else { ...
return -1 ...
} ...
} ...
# $c1 yview $args ...
} ...
#/Scroll Multiple **************************************...
} ...
#/Namespace PIANO_ROLL_MAIN ****************************...
package provide pr_main 1.00 ...
ファイル名:pkgIndex.tcl
package ifneeded pr_drawing 0.01 [list source [file join...
ファイル名:PR_drawing.tcl
# HEAD *************************************************...
package require Tk ...
#/HEAD *************************************************...
# Namespace PR_DRAWING *********************************...
namespace eval PR_DRAWING { ...
namespace export * ...
# Piano Roll *******************************************...
proc pianoRoll { x y z } { ...
.keyC create rectangle 5 10 25 441 -fill gray -width 0 ...
.c create rectangle 5456 11 5475 441 -fill gray -width 0...
...
.keyC create line 25 10 25 441 -fill black -width 1 ...
.keyC create line 54 10 54 441 -fill black -width 1 ...
.c create line 5 10 5475 10 -fill black -width 1 ...
.keyC create line 5 10 55 10 -fill black -width 1 ...
.c create line 5 441 5475 441 -fill black -width 1 ...
.keyC create line 5 441 55 441 -fill black -width 1 ...
.c create line 5 10 5 441 -fill black -width 1 ...
.c create line 5455 2 5455 441 -fill black -width 1 ...
.scaleC create line 5455 8 5455 34 -fill black -width 1 ...
...
.keyC create line $x $y [expr { $x + 29 }] $y -fill blac...
.c create line [expr { $z + 30 }] $y 5455 $y -fill #6666...
...
set pitch 6 ...
for {set cnt 0} {$cnt < 7} {incr cnt} { ...
.keyC create rectangle $x [expr { $y + 60 * $cnt + 6...
[expr { $x + 17 }] [expr { $y...
.c create rectangle [expr { $z + 30 }] [expr { $y + ...
5455 [expr { $y + 60 * $cnt + 11...
...
.keyC create line [expr { $x + 17 }] [expr { $y + 60...
[expr { $x + 29 }] [expr { $y + 60...
...
.keyC create rectangle $x [expr { $y + 60 * $cnt + 1...
[expr { $x + 17 }] [expr { $y...
.c create rectangle [expr { $z + 30 }] [expr { $y + ...
5455 [expr { $y + 60 * $cnt + 21...
...
.keyC create line [expr { $x + 17 }] [expr { $y + 60...
[expr { $x + 29 }] [expr { $y + 60...
...
.keyC create rectangle $x [expr { $y + 60 * $cnt + 2...
[expr { $x + 17 }] [expr { $y...
.c create rectangle [expr { $z + 30 }] [expr { $y + ...
5455 [expr { $y + 60 * $cnt + 31...
...
.keyC create line [expr { $x + 17 }] [expr { $y + 60...
[expr { $x + 29 }] [expr { $y + 60...
...
.keyC create line $x [expr { $y + 60 * $cnt + 35 }] \
[expr { $x + 29 }] [expr { $y + 60...
.c create line [expr { $z + 30 }] [expr { $y + 60 * ...
5455 [expr { $y + 60 * $cnt + 35 }] -...
...
.keyC create rectangle $x [expr { $y + 60 * $cnt + 4...
[expr { $x + 17 }] [expr { $y...
.c create rectangle [expr { $z + 30 }] [expr { $y + ...
5455 [expr { $y + 60 * $cnt + 46...
...
.keyC create line [expr { $x + 17 }] [expr { $y + 60...
[expr { $x + 29 }] [expr { $y + 60...
...
.keyC create rectangle $x [expr { $y + 60 * $cnt + 5...
[expr { $x + 17 }] [expr { $y...
.c create rectangle [expr { $z + 30 }] [expr { $y + ...
5455 [expr { $y + 60 * $cnt + 56...
...
.keyC create line [expr { $x + 17 }] [expr { $y + 60...
[expr { $x + 29 }] [expr { $y + 60...
...
.keyC create text 12 [expr { $y + 60 * $cnt + 55 }] \
-font {Times 7} -text "C[expr {$pitch - $cnt}]" ...
...
.keyC create line $x [expr { $y + 60 * $cnt + 60 }] \
[expr { $x + 29 }] [expr { $y + 60...
.c create line [expr { $z + 30 }] [expr { $y + 60 * ...
5455 [expr { $y + 60 * $cnt + 60 }] -...
...
.keyC create line [expr { $x + 17 }] [expr { $y + 60...
[expr { $x + 29 }] [expr { $y + 60...
...
expr {$pitch - 1} ...
} ...
...
.keyC create rectangle $x [expr { $y + 60 * $cnt + 6 }] \
[expr { $x + 17 }] [expr { $y + 60 *...
.c create rectangle [expr { $z + 30 }] [expr { $y + 60 *...
5455 [expr { $y + 60 * $cnt + 8 }] -...
...
for {set cnt 0} {$cnt < 68} {incr cnt} { ...
set z [expr {($cnt * 80) + 15}] ...
.c create line $z 2 $z 441 -width 1 ...
.c create line [expr { $z + 20}] 2 [expr { $z + 20}]...
.c create line [expr { $z + 40}] 2 [expr { $z + 40}]...
.c create line [expr { $z + 60}] 2 [expr { $z + 60}]...
...
.scaleC create line $z 14 $z 34 -width 1 ...
.scaleC create text $z 8 -font {Times 7} -text "$cnt...
.scaleC create line [expr { $z + 20}] 24 [expr { $z ...
.scaleC create line [expr { $z + 40}] 21 [expr { $z ...
.scaleC create line [expr { $z + 60}] 24 [expr { $z ...
} ...
# .c create line 480 8 480 81 -fill #AAAAAA -width 1 ...
# .c create line 500 8 500 81 -fill #AAAAAA -width 1 ...
.c create line 5 10 5 441 -fill black -width 1 ...
} ...
#/Piano Roll *******************************************...
# Common Bar Generation ********************************...
proc cBarGeneration {c x y l} { ...
$c create rectangle $x $y \
[expr {$x + $l}] [expr {$y + 5}]...
} ...
#/Common Bar Generation ********************************...
} ...
# Namespace PR_DRAWING *********************************...
package provide pr_drawing 1.00 ...
#attach( [nolist] ,[noform])
*** 修正履歴 [#icd3210a]
+パッケージ化してメインファイルをスッキリさす。~
+名前空間を活用する。~
*** 課題 [#g49309ba]
表面的にはまとまってきたけどまだまだ先は長い。
+個別バーを複数生成した場合の再移動がバグってるから直す。~
→
# Select Bar *******************************************...
set coords [$c coords current] ...
set bd(x) [lindex $coords 0] ...
set bd(y) [lindex $coords 1] ...
#/Select Bar *******************************************...
+スクローラブルキャンバスにする。 → 打開~
+バーを右クリックしたら削除できるようにする。 → 打開~
+MIDI形式でファイルの入出力ができるようにする。~
→ 内部データの持ち方をどうするのか、一般的なシーケン...
+線画をファイルの読込みで行うようにする。 → 今のところ必...
~
-備考~
~
*** 参考ページ [#h30a751b]
[Active_State: http://www.activestate.com/Products/active...
[もっとTcl/Tk: http://www.interq.or.jp/japan/s-imai/tcltk...
[なもなも 屋根裏分室: http://www.geocities.co.jp/SiliconV...
終了行:
''[[FrontPage]]''
* ピアノロールなGUIを作る [#v60487ec]
市販DAW並のGUIを目指す。~
サンプルコード上のコメントをもって解説に替える。~
~
&color(#FF0000){一旦クローズ};
** 制約事項 [#p6b64a19]
ってかよく分かんない。~
OSはWindows、Active_Tcl 8.5.5.0で、デモを真似しながらぼち...
~
~
ファイル名:styleSeq.tcl
# HEAD *************************************************...
source "*:/*****/tcl/lib/mylib/PR_drawing.tcl" ...
package require Tk ...
package require pr_drawing ...
#/HEAD *************************************************...
# Namespace PIANO_ROLL_MAIN ****************************...
namespace eval PIANO_ROLL_MAIN { ...
namespace export * ...
# Style Seq ********************************************...
wm title . "StyleSeq" ...
wm geometry . 541x280+250+200 ...
...
set tk_demoDirectory "*:\\*****\\tcl\\demos\\Tk8.5\\imag...
set font {Times 10} ...
...
# Set Bar Definition ***********************************...
set barDefinition(barLen) 20 ...
set barDefinition(grid_h) 5 ...
set barDefinition(grid_v) 5 ...
set barDefinition(left) 15 ...
set barDefinition(right) 5435 ...
set barDefinition(top) 13 ...
set barDefinition(bottom) 438 ...
set barDefinition(size) 2 ...
set barDefinition(normalStyle) "-fill green -stipple {}"...
...
#if {[winfo depth .c] > 0} { ...
# set barDefinition(activeStyle) "-fill red -stipple ...
# set barDefinition(moveStyle) [list -fill yellow \
# -stipple @[file join $tk_demoDirectory gray25.x...
#} else { ...
# set barDefinition(activeStyle) "-fill black -stippl...
# set barDefinition(moveStyle) [list -fill black \
# -stipple @[file join $tk_demoDirectory gray25.x...
#} ...
set barDefinition(activeStyle) "-fill red -stipple {}" ...
set barDefinition(moveStyle) [list -fill yellow \
-stipple @[file join $tk_demoDirectory gray25.xbm]] ...
#/Set Bar Definition ***********************************...
# Tool Bar 01 ******************************************...
frame .tBar01 ...
grid .tBar01 -row 0 -columnspan 2 -sticky ew ...
#grid columnconfigure . 1 -weight 1 ...
...
button .tBar01.exit -font {Times 8} -text "Exit" -comman...
pack .tBar01.exit -side left -padx 2 -pady 2 ...
#pack .tBar01.exit -side left ...
...
label .tBar01.l_msg -font $font -wraplength 200 -justify...
-text "This is only a test." -relief sunken ...
pack .tBar01.l_msg -side left -after .tBar01.exit -padx ...
#pack .tBar01.l_msg -side left -after .tBar01.exit ...
...
label .tBar01.r_msg -font $font -wraplength 200 -justify...
-text "This is only a test." -relief sunken ...
pack .tBar01.r_msg -side right -fill x -padx 2 -pady 2 ...
#pack .tBar01.r_msg -side right -fill x ...
#/Tool Bar 01 ******************************************...
# Canvas for Piano Roll ********************************...
canvas .scaleC -background white -width 486 -height 32 \
-scrollregion {5 2 5475 32} -xscrollcommand {.xsbar ...
...
canvas .c -background white -width 486 -height 121 \
-scrollregion {5 2 5475 444} \
-xscrollcommand {.xsbar set} -yscrollcommand {.ysbar...
# .c configure -xscrollincrement 0.5i -yscrollincreme...
...
canvas .keyC -background white -width 50 -height 121 \
-scrollregion {5 2 55 444} -yscrollcommand {.ysbar s...
# .keyC configure -xscrollincrement 0.5i -yscrollincr...
...
#.c configure -scrollregion [.c bbox all] \ ...
...
scrollbar .xsbar -orient horizontal \
-command {::PIANO_ROLL_MAIN::scrollMultiple .c .scal...
scrollbar .ysbar -orient vertical \
-command {::PIANO_ROLL_MAIN::scrollMultiple .c .keyC...
...
::PR_DRAWING::pianoRoll 25 13 -25 ...
...
grid .scaleC -row 1 -column 1 -sticky ew -padx 0 ...
grid .keyC -row 2 -column 0 -sticky nsew -padx 0 ...
grid .c -row 2 -column 1 -sticky nsew -padx 0 ...
grid .ysbar -row 2 -column 2 -sticky ns -padx 0 ...
#grid .keyC .c .ysbar -sticky news ...
grid .xsbar -row 3 -columnspan 2 -sticky ew ...
#/Canvas for Piano Roll ********************************...
# Sub Canvas *******************************************...
canvas .subC -background white -width 510 -height 30 ...
grid .subC -row 4 -columnspan 2 -padx 2 -pady 2 -sticky ...
...
.subC addtag tower withtag [.subC create rect 10 10 40 2...
-outline black -fill [lindex [.c config -bg] 4]] ...
.subC addtag cBar withtag [::PR_DRAWING::cBarGeneration ...
#/Sub Canvas *******************************************...
# Status Bar *******************************************...
frame .sBar -borderwidth 1 -relief sunken ...
grid .sBar -row 5 -columnspan 3 -padx 2 -pady 2 -sticky ...
...
label .sBar.coordinate -font $font -wraplength 5i -justi...
pack .sBar.coordinate -side right ...
...
label .sBar.delta -font $font -wraplength 5i -justify le...
pack .sBar.delta -side left ...
#/Status Bar *******************************************...
# Grid Configuration ***********************************...
grid rowconfigure . 2 -weight 1 ...
grid columnconfigure . 1 -weight 1 ...
#/Grid Configuration ***********************************...
# BIND *************************************************...
bind .c <Motion> { PIANO_ROLL_MAIN::senseMotion %x %y } ...
bind .c <Double-1> { PIANO_ROLL_MAIN::barGeneration .c %...
.c bind dBar <1> { PIANO_ROLL_MAIN::selectBar .c %x %y }...
.c bind dBar <Double-3> { PIANO_ROLL_MAIN::deleteBar .c ...
bind .c <B1-Motion> { PIANO_ROLL_MAIN::moveBar .c %x %y ...
#bind .c <B3-Motion> { PIANO_ROLL_MAIN::moveBar .c %x %y...
bind .c <Any-ButtonRelease-1> { PIANO_ROLL_MAIN::release...
#bind .c <Any-ButtonRelease-3> { PIANO_ROLL_MAIN::releas...
bind . <F1> { PIANO_ROLL_MAIN::modBarLen .subC 5 } ...
bind . <F2> { PIANO_ROLL_MAIN::modBarLen .subC 10 } ...
bind . <F3> { PIANO_ROLL_MAIN::modBarLen .subC 15 } ...
bind . <F4> { PIANO_ROLL_MAIN::modBarLen .subC 20 } ...
bind .c <1> { focus .c } ...
bind .c <MouseWheel> { PIANO_ROLL_MAIN::senseWheels .c %...
bind .c <Shift-MouseWheel> { PIANO_ROLL_MAIN::senseWheel...
#/BIND *************************************************...
.c yview moveto 0.35 ...
.keyC yview moveto 0.35 ...
#/Style Seq ********************************************...
# Bar Generation ***************************************...
proc barGeneration {c x y} { ...
variable ::PIANO_ROLL_MAIN::barDefinition ...
if {[$c find withtag active] != {}} { ...
return ...
} ...
$c addtag active withtag [::PR_DRAWING::cBarGenerati...
$c addtag dBar withtag active ...
set barDefinition(x) $x ...
set barDefinition(y) $y ...
moveBar $c $barDefinition(x) $barDefinition(y) ...
} ...
#/Bar Generation ***************************************...
# Move Bar *********************************************...
proc moveBar {c x y} { ...
variable ::PIANO_ROLL_MAIN::barDefinition ...
if {[$c find withtag active] == ""} { ...
return ...
} ...
set cx [$c canvasx $x $barDefinition(grid_h)] ...
set cy [$c canvasy $y $barDefinition(grid_v)] ...
...
set coords [$c coords active] ...
set actBarWidth [expr {[lindex $coords 2] - [lindex ...
set rLimit [expr { $barDefinition(right) + 20 - $act...
...
if {$cx < $barDefinition(left)} { ...
set cx $barDefinition(left) ...
} ...
if {$cx > $rLimit} { ...
set cx $rLimit ...
} ...
if {$cy < $barDefinition(top)} { ...
set cy $barDefinition(top) ...
} ...
if {$cy > $barDefinition(bottom)} { ...
set cy $barDefinition(bottom) ...
} ...
...
set cy [expr {$cy - $barDefinition(size)}] ...
eval "$c itemconf active $barDefinition(moveStyle)" ...
...
$c move active [expr {$cx - $barDefinition(x)}] [exp...
set barDefinition(x) $cx ...
set barDefinition(y) $cy ...
} ...
#/Move Bar *********************************************...
# Release Bar ******************************************...
proc releaseBar c { ...
variable ::PIANO_ROLL_MAIN::barDefinition ...
if {[$c find withtag active] == {}} { ...
return ...
} ...
eval "$c itemconf active $barDefinition(normalStyle)...
$c dtag active ...
} ...
#/Release Bar ******************************************...
# Select Bar *******************************************...
proc selectBar {c x y} { ...
variable ::PIANO_ROLL_MAIN::barDefinition ...
if {[$c find withtag active] != {}} { ...
return ...
} ...
$c addtag active withtag current ...
set coords [$c coords active] ...
set barDefinition(x) [lindex $coords 0] ...
set barDefinition(y) [lindex $coords 1] ...
eval "$c itemconf active $barDefinition(activeStyle)...
$c raise active ...
# moveBar $c $barDefinition(x) $barDefinition(y) ...
} ...
#/Select Bar *******************************************...
# Delete Bar *******************************************...
proc deleteBar c { ...
$c delete current ...
} ...
#/Delete Bar *******************************************...
# Modify Bar Length ************************************...
proc modBarLen {t len} { ...
variable ::PIANO_ROLL_MAIN::barDefinition ...
.subC delete cBar ...
set barDefinition(barLen) $len ...
.subC addtag cBar withtag [::PR_DRAWING::cBarGenerat...
} ...
#/Modify Bar Length ************************************...
# Sense Motion *****************************************...
proc senseMotion { x y } { ...
variable ::PIANO_ROLL_MAIN::.sBar.coordinate ...
.sBar.coordinate configure \
-text [format "x: %4i y: %4i" $x $y ] ...
} ...
#/Sense Motion *****************************************...
# Sense Wheels *****************************************...
proc senseWheels { c d horiz } { ...
variable ::PIANO_ROLL_MAIN::.sBar.delta ...
.sBar.delta configure \
-text [format "delta: %4i" $d ] ...
...
if { 0 == $horiz } { ...
if { $d <= 0 } { ...
$c yview scroll 1 units ...
.keyC yview scroll 1 units ...
} else { ...
$c yview scroll -1 units ...
.keyC yview scroll -1 units ...
} ...
} else { ...
if { $d < 0 } { ...
$c xview scroll 2 units ...
.scaleC xview scroll 2 units ...
} else { ...
$c xview scroll -2 units ...
.scaleC xview scroll -2 units ...
} ...
} ...
} ...
#/Sense Wheels *****************************************...
# Scroll Multiple **************************************...
proc scrollMultiple { c1 c2 horiz args } { ...
set cnt 0 ...
foreach elem $args { ...
set elemA($cnt) $elem ...
incr cnt ...
} ...
...
if { 0 == $horiz } { ...
if { 3 == $cnt } { ...
$c1 yview $elemA(0) $elemA(1) $elemA(2) ...
$c2 yview $elemA(0) $elemA(1) $elemA(2) ...
} elseif { 2 == $cnt } { ...
$c1 yview $elemA(0) $elemA(1) ...
$c2 yview $elemA(0) $elemA(1) ...
} else { ...
return -1 ...
} ...
} else { ...
if { 3 == $cnt } { ...
$c1 xview $elemA(0) $elemA(1) $elemA(2) ...
$c2 xview $elemA(0) $elemA(1) $elemA(2) ...
} elseif { 2 == $cnt } { ...
$c1 xview $elemA(0) $elemA(1) ...
$c2 xview $elemA(0) $elemA(1) ...
} else { ...
return -1 ...
} ...
} ...
# $c1 yview $args ...
} ...
#/Scroll Multiple **************************************...
} ...
#/Namespace PIANO_ROLL_MAIN ****************************...
package provide pr_main 1.00 ...
ファイル名:pkgIndex.tcl
package ifneeded pr_drawing 0.01 [list source [file join...
ファイル名:PR_drawing.tcl
# HEAD *************************************************...
package require Tk ...
#/HEAD *************************************************...
# Namespace PR_DRAWING *********************************...
namespace eval PR_DRAWING { ...
namespace export * ...
# Piano Roll *******************************************...
proc pianoRoll { x y z } { ...
.keyC create rectangle 5 10 25 441 -fill gray -width 0 ...
.c create rectangle 5456 11 5475 441 -fill gray -width 0...
...
.keyC create line 25 10 25 441 -fill black -width 1 ...
.keyC create line 54 10 54 441 -fill black -width 1 ...
.c create line 5 10 5475 10 -fill black -width 1 ...
.keyC create line 5 10 55 10 -fill black -width 1 ...
.c create line 5 441 5475 441 -fill black -width 1 ...
.keyC create line 5 441 55 441 -fill black -width 1 ...
.c create line 5 10 5 441 -fill black -width 1 ...
.c create line 5455 2 5455 441 -fill black -width 1 ...
.scaleC create line 5455 8 5455 34 -fill black -width 1 ...
...
.keyC create line $x $y [expr { $x + 29 }] $y -fill blac...
.c create line [expr { $z + 30 }] $y 5455 $y -fill #6666...
...
set pitch 6 ...
for {set cnt 0} {$cnt < 7} {incr cnt} { ...
.keyC create rectangle $x [expr { $y + 60 * $cnt + 6...
[expr { $x + 17 }] [expr { $y...
.c create rectangle [expr { $z + 30 }] [expr { $y + ...
5455 [expr { $y + 60 * $cnt + 11...
...
.keyC create line [expr { $x + 17 }] [expr { $y + 60...
[expr { $x + 29 }] [expr { $y + 60...
...
.keyC create rectangle $x [expr { $y + 60 * $cnt + 1...
[expr { $x + 17 }] [expr { $y...
.c create rectangle [expr { $z + 30 }] [expr { $y + ...
5455 [expr { $y + 60 * $cnt + 21...
...
.keyC create line [expr { $x + 17 }] [expr { $y + 60...
[expr { $x + 29 }] [expr { $y + 60...
...
.keyC create rectangle $x [expr { $y + 60 * $cnt + 2...
[expr { $x + 17 }] [expr { $y...
.c create rectangle [expr { $z + 30 }] [expr { $y + ...
5455 [expr { $y + 60 * $cnt + 31...
...
.keyC create line [expr { $x + 17 }] [expr { $y + 60...
[expr { $x + 29 }] [expr { $y + 60...
...
.keyC create line $x [expr { $y + 60 * $cnt + 35 }] \
[expr { $x + 29 }] [expr { $y + 60...
.c create line [expr { $z + 30 }] [expr { $y + 60 * ...
5455 [expr { $y + 60 * $cnt + 35 }] -...
...
.keyC create rectangle $x [expr { $y + 60 * $cnt + 4...
[expr { $x + 17 }] [expr { $y...
.c create rectangle [expr { $z + 30 }] [expr { $y + ...
5455 [expr { $y + 60 * $cnt + 46...
...
.keyC create line [expr { $x + 17 }] [expr { $y + 60...
[expr { $x + 29 }] [expr { $y + 60...
...
.keyC create rectangle $x [expr { $y + 60 * $cnt + 5...
[expr { $x + 17 }] [expr { $y...
.c create rectangle [expr { $z + 30 }] [expr { $y + ...
5455 [expr { $y + 60 * $cnt + 56...
...
.keyC create line [expr { $x + 17 }] [expr { $y + 60...
[expr { $x + 29 }] [expr { $y + 60...
...
.keyC create text 12 [expr { $y + 60 * $cnt + 55 }] \
-font {Times 7} -text "C[expr {$pitch - $cnt}]" ...
...
.keyC create line $x [expr { $y + 60 * $cnt + 60 }] \
[expr { $x + 29 }] [expr { $y + 60...
.c create line [expr { $z + 30 }] [expr { $y + 60 * ...
5455 [expr { $y + 60 * $cnt + 60 }] -...
...
.keyC create line [expr { $x + 17 }] [expr { $y + 60...
[expr { $x + 29 }] [expr { $y + 60...
...
expr {$pitch - 1} ...
} ...
...
.keyC create rectangle $x [expr { $y + 60 * $cnt + 6 }] \
[expr { $x + 17 }] [expr { $y + 60 *...
.c create rectangle [expr { $z + 30 }] [expr { $y + 60 *...
5455 [expr { $y + 60 * $cnt + 8 }] -...
...
for {set cnt 0} {$cnt < 68} {incr cnt} { ...
set z [expr {($cnt * 80) + 15}] ...
.c create line $z 2 $z 441 -width 1 ...
.c create line [expr { $z + 20}] 2 [expr { $z + 20}]...
.c create line [expr { $z + 40}] 2 [expr { $z + 40}]...
.c create line [expr { $z + 60}] 2 [expr { $z + 60}]...
...
.scaleC create line $z 14 $z 34 -width 1 ...
.scaleC create text $z 8 -font {Times 7} -text "$cnt...
.scaleC create line [expr { $z + 20}] 24 [expr { $z ...
.scaleC create line [expr { $z + 40}] 21 [expr { $z ...
.scaleC create line [expr { $z + 60}] 24 [expr { $z ...
} ...
# .c create line 480 8 480 81 -fill #AAAAAA -width 1 ...
# .c create line 500 8 500 81 -fill #AAAAAA -width 1 ...
.c create line 5 10 5 441 -fill black -width 1 ...
} ...
#/Piano Roll *******************************************...
# Common Bar Generation ********************************...
proc cBarGeneration {c x y l} { ...
$c create rectangle $x $y \
[expr {$x + $l}] [expr {$y + 5}]...
} ...
#/Common Bar Generation ********************************...
} ...
# Namespace PR_DRAWING *********************************...
package provide pr_drawing 1.00 ...
#attach( [nolist] ,[noform])
*** 修正履歴 [#icd3210a]
+パッケージ化してメインファイルをスッキリさす。~
+名前空間を活用する。~
*** 課題 [#g49309ba]
表面的にはまとまってきたけどまだまだ先は長い。
+個別バーを複数生成した場合の再移動がバグってるから直す。~
→
# Select Bar *******************************************...
set coords [$c coords current] ...
set bd(x) [lindex $coords 0] ...
set bd(y) [lindex $coords 1] ...
#/Select Bar *******************************************...
+スクローラブルキャンバスにする。 → 打開~
+バーを右クリックしたら削除できるようにする。 → 打開~
+MIDI形式でファイルの入出力ができるようにする。~
→ 内部データの持ち方をどうするのか、一般的なシーケン...
+線画をファイルの読込みで行うようにする。 → 今のところ必...
~
-備考~
~
*** 参考ページ [#h30a751b]
[Active_State: http://www.activestate.com/Products/active...
[もっとTcl/Tk: http://www.interq.or.jp/japan/s-imai/tcltk...
[なもなも 屋根裏分室: http://www.geocities.co.jp/SiliconV...
ページ名: