path: root/composer/window.tk

# ------------------------------------------------------------------------
# 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 quirks_fix_int_floats 0
    # 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)  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)
        debugPrint "resizing tktable widget to ${rows}x${cols}"
        grid $w($id).t -row 10 -column 0 -sticky news
        $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]

        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

        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 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
        set currentpattern($id) {}
        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
        set data($r,$c) [string map {empty {}} $v]
    }

    proc dispatch {id args} {
        debugPrint [info level 0]
        variable w
        variable patterns
        variable length
        variable currentpattern
        variable startup
        variable showpattern
        variable quirks_fix_int_floats
        switch -exact [lindex $args 0] {
            patterns {
                set patterns($id) [lrange $args 1 end]
                debugPrint "tk::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]
                    }
                }
            }
            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
            }
        }
    }
}