aboutsummaryrefslogtreecommitdiff
path: root/composer/editor.tk
diff options
context:
space:
mode:
Diffstat (limited to 'composer/editor.tk')
-rw-r--r--composer/editor.tk614
1 files changed, 614 insertions, 0 deletions
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 <<ComboboxSelected>> "[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 <Return> "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 <ButtonPress-3> "$w($id).t activate @%x,%y; tk_popup $w($id).m %X %Y"
+ bind $w($id).t <Control-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
+ }
+ }
+ }
+}
generated by cgit v1.2.1 (git 2.18.0) at 2024-04-28 14:33:55 +0000