From f8ac52e520aa5e20a256a3fd9a649b461f3afeef Mon Sep 17 00:00:00 2001 From: mescalinum Date: Fri, 25 Sep 2009 17:19:25 +0000 Subject: rewrite in C++ svn path=/trunk/externals/ffext/; revision=12451 --- composer/editor.tk | 614 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 614 insertions(+) create mode 100644 composer/editor.tk (limited to 'composer/editor.tk') diff --git a/composer/editor.tk b/composer/editor.tk new file mode 100644 index 0000000..1b90732 --- /dev/null +++ b/composer/editor.tk @@ -0,0 +1,614 @@ +# ------------------------------------------------------------------------ +# Copyright (c) 2009 Federico Ferri. +# For information on usage and redistribution, and for a DISCLAIMER OF ALL +# WARRANTIES, see the file, "LICENSE.txt," in this distribution. +# +# composer: a music composition framework for pure-data +# +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License +# as published by the Free Software Foundation; either version 2 +# of the License, or (at your option) any later version. +# +# See file LICENSE for further informations on licensing terms. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software Foundation, +# Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +# +# Based on PureData by Miller Puckette and others. +# ------------------------------------------------------------------------ + +package require Tcl 8.5 +package require Tk 8.5 +package require Tktable 2.9 + +namespace eval pd::composer { + variable debug + variable w + array set w {} + variable songname + array set songname {} + variable trackname + array set trackname {} + variable currentpattern + array set currentpattern {} + variable length + array set length {} + variable columns + array set columns {} + variable patterns + array set patterns {} + variable tracks + array set tracks {} + + variable quirks_fix_int_floats 0 + variable symbolmap {empty {}} + # set to 1 until startup, for getting soon a pattern list + # affects the behavior of dispatcher::patterns branch + variable startup + array set startup {} + variable showpattern + array set showpattern {} + + proc debugPrint {args} { + variable debug + if {![info exists debug]} {set debug 0} + if {$debug} {puts stderr "composer-TCL: $args"} + } + + proc sendGui {what} { + debugPrint "sendGui $what" + catch {netsend $what} + lappend what \;\n + catch {pdsend $what} + catch {pd {*}$what} + } + + proc createPattern {id name len} { + debugPrint [info level 0] + variable length + variable patterns + + if {$name in $patterns($id)} { + return -code error "Pattern '$name' already exists" + } + set len [expr {int($len)}] + if {$len <= 0} { + return -code error "Length must be positive integer" + } + + sendGui [concat $id EDIT addpattern $name $len] + } + + proc removePattern {id name} { + debugPrint [info level 0] + variable length; + variable patterns; + + sendGui [concat $id EDIT removepattern $name] + } + + proc copyPattern {id src dst} { + debugPrint [info level 0] + variable length; + + sendGui [concat $id EDIT copypattern $src $dst] + } + + proc resizePattern {id name newSize} { + debugPrint [info level 0] + variable currentpattern; + variable length; + + if {$newSize == [dict get $length($id) $name]} return + + set len [expr {int($newSize)}] + if {$len <= 0} { + return -code error "Length must pe positive integer" + } + + sendGui [concat $id EDIT resizepattern $name $len] + } + + proc renamePattern {id name newName} { + debugPrint [info level 0] + variable length; + variable patterns; + + if {$name == $newName} return + if {$newName in $patterns($id)} { + return -code error "Pattern name '$newName' already exists" + } + set idx [lsearch -exact $patterns($id) $name] + if {$idx == -1} { + return -code error "No such pattern: '$name'" + } + + sendGui [concat $id EDIT renamepattern $name $newName] + } + + proc generateNewPatternName {id} { + debugPrint [info level 0] + variable patterns; + set n 0 + while 1 { + set t "P[format %.02d $n]" + if {$t in $patterns($id)} {incr n} else {return $t} + } + } + + proc displayPattern {id name} { + debugPrint "request-pattern-length" + variable showpattern + set showpattern($id) 1 + sendGui [concat $id EDIT getpatternlength $name] + } + + proc updateTitle {id} { + variable w + variable songname + variable trackname + variable currentpattern + set t "Song: $songname($id)" + if {$currentpattern($id) == "Arrangement"} { + append t " Arrangement" + } else { + append t " Track: $trackname($id)" + if {$currentpattern($id) != {}} { + append t " Pattern: $currentpattern($id)" + } + } + wm title $w($id) $t + } + + proc displayPattern_async {id name} { + debugPrint [info level 0] + variable currentpattern + variable patterns + variable length + variable columns + variable w + variable songname + variable trackname + variable [getDataVar $id] + + set currentpattern($id) $name + updateTitle $id + + if {$currentpattern($id) == {}} { + grid forget $w($id).t + return + } + + set rows [dict get $length($id) $name] + set cols $columns($id) + grid $w($id).t -row 10 -column 0 -sticky news + debugPrint "resizing tktable widget to ${rows}x${cols}" + $w($id).t configure -state normal -variable [getDataVar $id] -rows $rows -cols [expr {1+$cols}] + $w($id).f.p configure -values $patterns($id) + $w($id).f.p current [lsearch -exact $patterns($id) $name] + } + + proc displayCurrentPattern {id} { + debugPrint [info level 0] + variable currentpattern + variable w + debugPrint "current pattern is {$currentpattern($id)}" + displayPattern $id $currentpattern($id) + } + + proc rowTag {id r} { + if {$r % $::div1 == 0} {return "alt0"} + if {$r % $::div2 == 0} {return "alt1"} + } + + proc refreshGrid {id} { + debugPrint [info level 0] + variable currentpattern + debugPrint "currentPattern is {$currentpattern($id)}" + variable w + $w($id).t configure -padx [$w($id).t cget -padx] + } + + proc edit {id r c bwrite value} { + # NOT USED + #if {$bwrite} { + # sendGui [concat $id EDIT setcell $currentpattern($id) $r $c $value] + #} else { + #} + } + + proc getDataVar {id {P {}}} { + variable currentpattern + variable songname + variable trackname + if {$P == ""} {set P $currentpattern($id)} + set n "[namespace current]::data_$songname($id)_$trackname($id)_$P" + if {![info exists $n]} {array set $n {}} + return $n + } + + proc createMainWindow {id} { + debugPrint [info level 0] + variable currentpattern; + variable w + variable songname + variable trackname + variable patterns + variable startup + variable showpattern + variable [getDataVar $id] + + catch {destroy $w($id)} + debugPrint "creating window with path = '$w($id)'" + toplevel $w($id) + + debugPrint "top-toolbar(frame)" + grid [ttk::frame $w($id).f] \ + -row 5 -columnspan 2 -sticky news + debugPrint "label" + grid [ttk::label $w($id).f.l -text "Pattern: "] \ + -row 0 -column 0 -in $w($id).f + debugPrint "combobox patterns" + grid [ttk::combobox $w($id).f.p -textvariable "[namespace current]::currentpattern($id)"] \ + -row 0 -column 1 -in $w($id).f + debugPrint "divs" + grid [ttk::label $w($id).f.ld1 -text "Div1: "] \ + -row 0 -column 2 -in $w($id).f + grid [spinbox $w($id).f.d1 -command "[namespace current]::refreshGrid $id" -from 8 -to 64 \ + -increment 1 -format %3.0f -width 3 -textvar ::div1] \ + -row 0 -column 3 -in $w($id).f + grid [ttk::label $w($id).f.ld2 -text "Div2: "] \ + -row 0 -column 4 -in $w($id).f + grid [spinbox $w($id).f.d2 -command "[namespace current]::refreshGrid $id" -from 2 -to 64 \ + -increment 1 -format %3.0f -width 3 -textvar ::div2] \ + -row 0 -column 5 -in $w($id).f + + debugPrint "step2" + $w($id).f.p state readonly + + debugPrint "bindevent" + bind $w($id).f.p <> "[namespace current]::displayCurrentPattern $id" + debugPrint "table" + + table $w($id).t -state disabled \ + -insertofftime 0 \ + -bordercursor sb_h_double_arrow \ + -colorigin -1 -sparsearray 1 \ + -relief ridge -takefocus 1 -borderwidth 1 -colwidth 4 \ + -browsecmd "[namespace current]::activeCellChanges $id %r %c" \ + -cols 0 -rows 0 \ + -cache 0 \ + -usecommand 0 -command "[namespace current]::edit $id %r %c %i %s" \ + -colstretchmode none -rowstretchmode none \ + -flashmode 1 -flashtime 2 -autoclear 1 \ + -justify left -multiline 0 -resizeborders col \ + -selectmode extended -selecttype cell \ + -titlecols 1 -titlerows 0 -validate 1 \ + -validatecommand "[namespace current]::validateCommand $id %r %c %s %S" \ + -variable [getDataVar $id] -exportselection 1 \ + -xscrollcommand "$w($id).hscroll set" \ + -yscrollcommand "$w($id).vscroll set" \ + -rowtagcommand "[namespace current]::rowTag $id" + #grid $w($id).t -row 10 -column 0 -sticky news + + debugPrint "scrollbars" + grid [ttk::scrollbar $w($id).vscroll -orient vertical -command "$w($id).t yview"] -row 10 -column 1 -sticky ns + grid [ttk::scrollbar $w($id).hscroll -orient horizontal -command "$w($id).t xview"] -row 15 -column 0 -sticky ew + #grid [ttk::sizegrip $w($id).resize] -row 15 -column 1 -sticky se + + grid [ttk::entry $w($id).eval] -row 20 -columnspan 2 -sticky ew + bind $w($id).eval "set cmd \[$w($id).eval get]; namespace eval [namespace current] \$cmd; $w($id).eval delete 0 end" + + debugPrint "grid" + grid columnconfigure $w($id) 0 -weight 1 + grid rowconfigure $w($id) 10 -weight 1 + + debugPrint "table-tags" + $w($id).t tag configure active -relief solid -background gray -foreground black + $w($id).t tag configure flash -background red -foreground white + $w($id).t tag configure sel -background blue -foreground white + $w($id).t tag configure title -background gray -foreground white -justify right + $w($id).t tag configure alt0 -background "#20a8b8" + $w($id).t tag configure alt1 -background "#0f7f9f" + $w($id).t tag configure notecol -background "#dddded" + + debugPrint "wm" + wm minsize $w($id) 300 150 + wm protocol $w($id) WM_DELETE_WINDOW "[namespace current]::sendGui {$id EDIT editor-close}" + + debugPrint "menu" + menu $w($id).m -tearoff 0 + $w($id).m add command -label "New pattern..." \ + -command "[namespace current]::newPatternDialog $id" + $w($id).m add command -label "Pattern properties..." \ + -command "[namespace current]::patternPropertiesDialog $id" + $w($id).m add command -label "Remove pattern..." \ + -command "[namespace current]::removePatternConfirm $id" + $w($id).m add command -label "Create copy..." \ + -command "[namespace current]::copyPatternDialog $id" + + menu $w($id).mb + $w($id) configure -menu $w($id).mb + menu $w($id).mb.tools -tearoff 0 + $w($id).mb.tools add command -label {Reload} \ + -command {uplevel 0 {source $argv0}} + $w($id).mb add cascade -label {Pattern} -menu $w($id).m + $w($id).mb add cascade -label {Utils} -menu $w($id).mb.tools + + debugPrint "more-bind-events" + bind $w($id).t "$w($id).t activate @%x,%y; tk_popup $w($id).m %X %Y" + bind $w($id).t "switchColumnType $id" + + set startup($id) 1 + set showpattern($id) 0 + debugPrint "request-patterns" + sendGui [concat $id EDIT getpatterns] + sendGui [concat $id EDIT gettracks] + + return $w($id) + } + + proc switchColumnType {id} { + debugPrint [info level 0] + variable w + global colType + set curcol [$w($id).t index active col] + set tag {} + if {![info exists colType(c$curcol)]} { + set colType(c$curcol) {notes} + set tag {notecol} + } elseif {$colType(c$curcol) == {notes}} { + unset colType(c$curcol) + } + + $w($id).t tag col $tag $curcol + #refreshGrid + } + + proc activeCellChanges {id row col} { + debugPrint [info level 0] + variable w + if {$col < 0} {$w($id).t activate $row,[incr col]} + } + + proc validateCommand {id row col curVal newVal} { + debugPrint [info level 0] + variable currentpattern + variable symbolmap + + debugPrint "BEFORE: newVal = '$newVal'" + set newVal [dict get [dict merge [list $newVal $newVal] [lreverse $symbolmap]] $newVal] + debugPrint "AFTER: newVal = '$newVal'" + + sendGui [concat $id EDIT setcell $currentpattern($id) $row $col $newVal] + + return 1 + } + + proc patternPropertiesDialog_common {id options} { + debugPrint [info level 0] + variable currentpattern + variable w + set bname 1 + set blength 1 + set old_name {} + catch {set old_name $currentpattern($id)} + set vname {} + set vlength {} + set action_cancel {destroy %w} + set action_ok $action_cancel + + set opts {vname vlength bname blength action_ok action_cancel} + foreach opt $opts { + catch {set $opt [dict get $options $opt]} + } + foreach {o v} $options { + if {$o ni $opts} { + return -code error "Invalid option: $o" + } + } + + set w_ $w($id).patternProps + catch {destroy $w_} + toplevel $w_ + + foreach v {action_ok action_cancel} { + set $v [string map [list %ns [namespace current] %id $id %w $w_ %old_name $old_name] [set $v]] + } + + grid [ttk::label $w_.lname -text "Name: "] -row 0 -column 0 + grid [ttk::label $w_.llength -text "Rows: "] -row 1 -column 0 + grid [ttk::entry $w_.ename] -row 0 -column 1 + grid [ttk::entry $w_.elength] -row 1 -column 1 + grid [ttk::frame $w_.b] -row 2 -columnspan 2 + grid [ttk::button $w_.b.ok -text Ok -command $action_ok] -row 0 -column 0 -in $w_.b + grid [ttk::button $w_.b.cancel -text Cancel -command $action_cancel] -row 0 -column 1 -in $w_.b + + $w_.ename insert 0 $vname + $w_.elength insert 0 $vlength + + if {!$bname} {$w_.ename configure -state disabled} + if {!$blength} {$w_.elength configure -state disabled} + } + + proc patternPropertiesDialog {id {options {}}} { + debugPrint [info level 0] + variable currentpattern; + variable length; + + dict set options action_ok { + %ns::resizePattern %id %old_name [%w.elength get] + %ns::renamePattern %id %old_name [%w.ename get] + destroy %w + } + dict set options vname $currentpattern($id) + dict set options vlength [dict get $length($id) $currentpattern($id)] + patternPropertiesDialog_common $id $options + } + + proc copyPatternDialog {id {options {}}} { + debugPrint [info level 0] + variable w; + variable length; + + dict set options blength 0 + dict set options vname [generateNewPatternName $id] + dict set options vlength [dict get $length($id) $currentpattern($id)] + dict set options action_ok { + %ns::copyPattern %id %old_name [%w.ename get] + destroy %w + } + patternPropertiesDialog_common $id $options + } + + proc removePatternConfirm {id} { + debugPrint [info level 0] + variable currentpattern; + if {[tk_messageBox \ + -type yesno -default no \ + -title "Question" \ + -icon question -message "Do you confirm pattern delete?" \ + -detail "The operation cannot be undone" \ + -parent $w] == {yes}} { + removePattern $id $currentpattern($id) + } + } + + proc newPatternDialog {id {options {}}} { + debugPrint [info level 0] + dict set options action_ok { + %ns::createPattern %id [%w.ename get] [%w.elength get] + destroy %w + } + dict set options vname [generateNewPatternName $id] + dict set options vlength 16 + patternPropertiesDialog_common $id $options + } + + #entrypoint + proc init {id song_name track_name cols set_current_pattern debug_flag} { + debugPrint [info level 0] + variable debug + set debug [expr {$debug_flag != 0}] + variable w + variable songname + variable trackname + variable length + variable currentpattern + variable columns + set w($id) .w_${song_name}_${track_name} + set songname($id) $song_name + set trackname($id) $track_name + if {$set_current_pattern == {NULL}} { + set currentpattern($id) {} + } else { + set currentpattern($id) $set_current_pattern + } + set length($id) {} + set columns($id) $cols + } + + proc openWindow {id} { + debugPrint [info level 0] + createMainWindow $id + } + + proc closeWindow {id} { + debugPrint [info level 0] + variable w + destroy $w($id) + } + + proc setCellValueUI {id pat r c v} { + upvar 0 [getDataVar $id $pat] data + variable symbolmap + set data($r,$c) [dict get [dict merge [list $v $v] $symbolmap] $v] + } + + proc dispatch {id args} { + debugPrint [info level 0] + variable w + variable patterns + variable length + variable currentpattern + variable startup + variable showpattern + variable columns + variable quirks_fix_int_floats + switch -exact [lindex $args 0] { + patterns { + # for track mode + set patterns($id) [lrange $args 1 end] + debugPrint "patterns <- $patterns($id)" + $w($id).f.p configure -values $patterns($id) + if {$startup($id)} { + set startup($id) 0 + if {[llength $patterns($id)] > 0} { + displayPattern $id [lindex $patterns($id) 0] + } + } + } + tracks { + # for song mode + set tracks($id) [lrange $args 1 end] + debugPrint "tracks <- $tracks($id)" + set cols [llength $tracks($id)] + #debugPrint "resizing tktable widget to ${cols} cols" + #$w($id).t configure -state normal -cols $cols + set columns($id) $cols + } + patternlength { + set pat_name [lindex $args 1] + set pat_length [lindex $args 2] + debugPrint "got patternlength: '$pat_name' (len=$pat_length)" + if {![dict exists $length($id) $pat_name] || [dict get $length($id) $pat_name] != $pat_length || $showpattern($id)} { + dict set length($id) $pat_name $pat_length + for {set i 0} {$i < $pat_length} {incr i} { + sendGui [concat $id EDIT getrow $pat_name $i] + } + } + } + row { + set pat_name [lindex $args 1] + if {$quirks_fix_int_floats} { + set row_num [expr {int([lindex $args 2])}] + } else { + set row_num [lindex $args 2] + } + set row [lrange $args 3 end] + debugPrint "got row: '$pat_name' ($row_num) {$row}" + setCellValueUI $id $pat_name $row_num -1 [expr {1+$row_num}] + for {set i 0} {$i < [llength $row]} {incr i} { + setCellValueUI $id $pat_name $row_num $i [lindex $row $i] + } + if {$row_num + 1 == [dict get $length($id) $pat_name]} { + if {$showpattern($id)} { + set showpattern($id) 0 + displayPattern_async $id $pat_name + } + } + } + cell { + set pat_name [lindex $args 1] + if {$quirks_fix_int_floats} { + set row_num [expr {int([lindex $args 2])}] + set col_num [expr {int([lindex $args 3])}] + } else { + set row_num [lindex $args 2] + set col_num [lindex $args 3] + } + set cell [lindex $args 4] + debugPrint "got cell: '$pat_name' ($row_num,$col_num) {$cell}" + debugPrint "dataVar = [getDataVar $id $pat_name]" + setCellValueUI $id $pat_name $row_num $col_num $cell + } + } + } +} -- cgit v1.2.1