csound-6.15.0/util2/matrix.tk

#!/usr/bin/wish

# Utility to create scanned synthesis matrices
# John ffitch 2000 Jun 3

# The basic drawing area.  Size is a guess!
canvas .c -width 13c -height 13c
pack .c

#Creation of nodes and lines; driven my bindings later
proc mkNode {x y} {
    # Create new node at (x,y)
    global nodeX nodeY edgeFirst edgeSecond allNodes
    set new [.c creat oval [expr $x-5] [expr $y-5] \
            [expr $x+5] [expr $y+5] -outline black \
            -fill yellow -tags node]
    set nodeX($new) $x
    set nodeY($new) $y
    set edgeFirst($new) {}
    set edgeSecond($new) {}
    lappend allNodes $new
}

proc mkEdge {first second} {
                                # Create edge between nodes
    global nodeX nodeY edgeFirst edgeSecond connect
    set x1 $nodeX($first)
    set y1 $nodeY($first)
    set x2 $nodeX($second)
    set y2 $nodeY($second)
    set edge [.c create line $x1 $y1 $x2 $y2 -arrow last -arrowshape {10 20 5}]
    .c lower $edge
    lappend edgeFirst($first) $edge
    lappend edgeSecond($second) $edge
    lappend connect [list $first $second]
}

##########  LEFT BUTTON CREATION
# Create node with left button
bind .c <Button-1> {mkNode %x %y}

.c bind node <Any-Enter> {
    .c itemconfigure current -fill red
}
.c bind node <Any-Leave> {
    .c itemconfigure current -fill yellow
}

#########  FIRST EDGE DRAWING METHOD
# Line drawing with 1 and 2 -- must be a better way!

set secondNode ""
set firstNode ""
bind .c 1 {
    global firstNode secondNode
    set firstNode [.c find withtag current]
    if {($firstNode != "") && ($secondNode != "")} {
        mkEdge $firstNode $secondNode
        set firstNode ""
        set secondNode ""
    }
}

bind .c 2 {
    global firstNode
    set curNode [.c find withtag current]
    if {($firstNode != "") && ($curNode != "")} {
        mkEdge $firstNode $curNode
        set firstNode ""
    } else {
        set secondNode $curNode
    }
}

####### SECOND WAY
# Second way of drawing links using Button 2
bind .c <Button-2> {
    global newLine curX curY
    set firstNode [.c find withtag current]
    if {$firstNode != ""} {
        set newLine [.c create line %x %y %x %y -fill blue]
        set curX %x
        set curY %y
    }
}

bind .c <B2-Motion> {
    global newLine curX curY
    .c coords $newLine [lindex [.c coords $newLine] 0] \
                [lindex [.c coords $newLine] 1] %x %y
    set curX %x
    set curY %y
    foreach node $allNodes {
        set pts [.c coords $node]
        set diffx [expr $curX-[lindex $pts 0]]
        set diffy [expr $curY-[lindex $pts 1]]
        if {($diffx < 10) && ($diffx > 0) && ($diffy < 10) && ($diffy > 0)} {
            set curNode $node
        }
    }
    if {($firstNode != "") && ($curNode != "") && ($firstNode != $curNode)} {
        mkEdge $firstNode $curNode
        set firstNode ""
        .c delete $newLine
        set newLine ""
    }
}

bind .c <ButtonRelease-2> {
                                # Delete any dangling rubber line
    if {$newLine != ""} {
        .c delete $newLine
        set newLine ""
    }
}

####### REORGANISATION OF LAYOUT
# Node mobility, with attached lines
proc moveNode {node xDist yDist} {
    global nodeX nodeY edgeFirst edgeSecond
    .c move $node $xDist $yDist
    incr nodeX($node) $xDist
    incr nodeY($node) $yDist
    foreach edge $edgeFirst($node) {
        .c coords $edge $nodeX($node) $nodeY($node) \
                [lindex [.c coords $edge] 2] \
                [lindex [.c coords $edge] 3]
    }
    foreach edge $edgeSecond($node) {
        .c coords $edge [lindex [.c coords $edge] 0] \
                [lindex [.c coords $edge] 1] \
                $nodeX($node) $nodeY($node)
    }
}

.c bind node <Button-3> {
    set curX %x
    set curY %y
}

.c bind node <B3-Motion> {
    moveNode [.c find withtag current] [expr %x-$curX] [expr %y-$curY]
    set curX %x
    set curY %y
}

######## DELETIONS OF ERRORS
#Removal of unwanted nodes
proc deleteNode {node} {
    global allNodes edgeFirst edgeSecond connect
    if {[info exists $edgeFirst($node)]} {
        foreach edge $edgeFirst($node) {
            .c delete $edge
        }
    }
    if {[info exists $edgeSecond($node)]} {
        foreach edge $edgeSecond($node) {
            .c delete $edge
        }
    }
    unset edgeFirst($node)
    unset edgeSecond($node)
    set indx [lsearch $allNodes $node]
    set allNodes [lreplace $allNodes $indx $indx]
    while {[set indx [lsearch -regexp $connect "$node \[0-9\]*"]] != -1} {
        set connect [lreplace $connect $indx $indx]
    }
    while {[set indx [lsearch -regexp $connect "\[0-9\]* $node"]] != -1} {
        set connect [lreplace $connect $indx $indx]
    }
    .c delete $node
}

bind .c r {
    deleteNode [.c find withtag current]
}

bind .c k {
    deleteNode [.c find withtag current]
}

# Removal of unwanted lines
proc deleteLink {node} {
    global edgeFirst edgeSecond connect mode
    if {[info exists $edgeFirst($node)]} {
        bind .c y {
            unset edgeFirst($node)
            while {[set indx [lsearch -regexp $connect "$node \[0-9\]*"]] != -1} {
                set connect [lreplace $connect $indx $indx]
            }
            .c delete $mode
            set mode -1
        }
        bind .c n {
            set mode -1
            .c itemconfigure mode -fill black -outline black
        }
        foreach edge $edgeFirst($node) {
            .c itemconfigure edge -fill yellow -outline yellow -stipple -.
            set mode $edge
            tkwait variable mode
        }
    }
    if {[info exists $edgeSecond($node)]} {
        bind .c y {
            .c delete $mode
            unset edgeSecond($node)
            while {[set indx [lsearch -regexp $connect "\[0-9\]* $node"]] != -1} {
                set connect [lreplace $connect $indx $indx]
            }
        }
        bind .c n {
            set mode -1
            .c itemconfigure mode -fill black -outline black
        }
        foreach edge $edgeSecond($node) {
            .c itemconfigure edge -fill yellow -outline yellow -stipple -.
            set mode $edge
            tkwait variable mode
        }
    }
    bind .c y {}
    bind .c n {}
}

bind .c d {
    set node [.c find withtag current]
    if {$node != ""} {
        deleteLink $node
    }
}

focus .c

###### GENERATE OUTPUT TABLE
set connect ""
set allNodes ""
set outname "matrix.dat"

proc makeTable {} {
                                # Construct the matrix
    global allNodes connect outname
    set n 0
    set map ""
#    puts "allNodes=$allNodes"
#    puts "connections $connect"
    foreach node $allNodes {
                                # Construct a set of link tables
#        puts "Node $n"
        set links($n) ""
        while {[set indx [lsearch -regexp $connect "$node \[0-9\]*"]] != -1} {
#            puts "Indx = $indx; lindex connect indx = [lindex $connect $indx]"
            set links($n) [lappend links($n) [lindex [lindex $connect $indx] 1]]
            set connect [lreplace $connect $indx $indx]
        }
#        puts "Links $n $links($n)"
#        puts $connect
        set map [lappend map $node]
#        puts "map for $n is $map"
        set n [incr n 1]
    }
    set l 1
    while {$l < $n} {
        set l [expr $l+$l]
    }
    puts "*********************Table size is $l"
    set ff [open $outname w]
                                        # l is power-of-two version
    for {set i 0} {$i < $l} {incr i 1} {
        for {set j 0} {$j < $l} {incr j 1} {
            if {($i<$n) || ($j<$n)} {
                set k [lindex $map $j]
                if {([lsearch $links($i) $k] != -1)} {
                    puts -nonewline $ff "1 "
                } else {
                    puts -nonewline $ff "0 "
                }
            } else { puts -nonewline $ff "0 " }
        }
        puts $ff ""
    }
    puts "Ends"
}

button .ok -text Build -command makeTable
button .xit -text EXIT -command exit
set hlpShowing 0
proc doHelp {} {
    if {helpShowing==0} {
        toplevel .hlp
        wm title .hlp "Help"
        text .hlp.t -relief raised -bd 2 -yscrollcommand ".hlp.s set"
        scrollbar .hlp.s -command ".hlp.t yview"
        button .hlp.k -text OK -command endHelp
        pack .hlp.s -side right -fill y
        pack .hlp.t -side left
        pack .hlp.k
        set f [open "matrix.hlp"]
        while {![eof $f]} {
            .hlp.t insert end [read $f 1000]
        }
        close $f
        set helpShowing 1
    }
}

proc endHelp {} {
    destroy .hlp
}

button .help -text Help -command doHelp
label .label -text "File Name:"
entry .entry -width 20 -relief sunken -bd 2 -textvariable outname
pack .xit .ok .help .label .entry -side left -padx 1m -pady 2m