#!/usr/bin/env wish set svnid {$Id$} #-----------------------------------------------------------------------------------# # # DesireData # Copyright (c) 2004 by Mathieu Bouchard # Copyright (c) 2005,2006,2007 by Mathieu Bouchard and Chun Lee # # 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 ../COPYING.desire-client.txt 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. # # Note that this is not under the same license as the rest of PureData. # Even the DesireData server-side modifications stay on the same license # as the rest of PureData. # #-----------------------------------------------------------------------------------# # this command rebuilds the package index: echo pkg_mkIndex . | tclsh set debug 0 ;# DON'T TOUCH THIS, make yourself a debug.tcl instead! if {$tcl_version < 8.5} {puts "Please upgrade to Tcl/Tk 8.5... Thank You.\n(your version is $tcl_version)"; exit 84} if {[catch {winfo children .}]} {set tk 0} {set tk 1} set argh0 [file normalize [file join [pwd] $argv0]] set auto_path [concat . \ [list [file join [file dirname [file dirname $argh0]] lib/pd/bin]] \ /usr/share/tcltk/tcllib1.10/profiler \ /usr/lib/tclx8.4 \ $auto_path] package require poe if {$tk} {package require bgerror} catch {package require Tclx} #if {[catch {source /home/matju/src/svn-pd/desiredata/src/profile_dd.tcl}]} {error_dump} if {[file exists debug.tcl]} {source debug.tcl} proc which {file} { global env foreach dir [split $::env(PATH) ":"] { if {[file exists $dir/$file]} {return $dir/$file} } return "" } #-----------------------------------------------------------------------------------# # some list processing functions and some math too # these could become another library like objective.tcl # if they become substantial enough # min finds the smallest of two values # max finds the biggest of two values # [clip $v $min $max] does [max $min [min $max $v]] proc min {x y} {expr {$x<$y?$x:$y}} proc max {x y} {expr {$x>$y?$x:$y}} proc clip {x min max} { if {$x<$min} {return $min} if {$x>$max} {return $max} return $x } # set several variables from elements of a list # WARNING: for @-variables, use [list @a @b @c] instead of {@a @b @c} proc mset {vars list} { uplevel 1 "foreach {$vars} {$list} {break}" } # add or subtract two lists proc l+ { al bl} {set r {}; foreach a $al b $bl {lappend r [expr {$a+$b}]}; return $r} proc l- { al bl} {set r {}; foreach a $al b $bl {lappend r [expr {$a-$b}]}; return $r} # halve a list proc l/2 { al } {set r {}; foreach a $al {lappend r [expr {$a/2 }]}; return $r} # like l+ or l- but for any infix supported by expr proc lzip {op al bl} { set r {} set e "\$a $op \$b" foreach a $al b $bl {lappend r [expr $e]} return $r } # do an operation between all elements of a list and a second argument proc lmap {op al b } { set r {} set e "\$a $op \$b" foreach a $al {lappend r [expr $e]} return $r } # sum and product of a list, like math's capital Sigma and capital Pi. proc lsum {al} {set r 0; foreach a $al {set r [expr {$r+$a}]}; return $r} proc lprod {al} {set r 1; foreach a $al {set r [expr {$r*$a}]}; return $r} # all elements from end to beginning proc lreverse {list} { set r {} for {set i [expr {[llength $list]-1}]} {$i>=0} {incr i -1} {lappend r [lindex $list $i]} return $r } # list substraction is like set substraction but order-preserving # this is the same algorithm as Ruby's - operation on Arrays proc lwithout {a b} { set r {} foreach x $b {set c($x) {}} foreach x $a {if {![info exists c($x)]} {lappend r $x}} return $r } proc lintersection {a b} { set r {} foreach x $b {set c($x) {}} foreach x $a {if {[info exists c($x)]} {lappend r $x}} return $r } # removes duplicates from a list, but it must be already sorted. proc luniq {a} { set last [lindex $a 0] set r [list $last] set i 0 foreach x $a { if {$i && [string compare $last $x]} {lappend r $x} incr i; set last $x } return $r } # one-dimensional intervals (left-closed, right-open); not much in use at the moment, not that they wouldn't deserve to! # (slightly buggy) proc inside {x x0 x1} {return [expr {$x>=$x0 && $x<$x1}]} proc overlap {y0 y1 x0 x1} {return [expr {[inside $y0 $x0 $x1] || [inside $y1 $x0 $x1]}]} proc distance {point1 point2} { set off [l- $point1 $point2] return [expr {sqrt([lsum [lzip * $off $off]])}] } proc rect_centre {rect} { mset {x1 y1 x2 y2} $rect return [list [expr {($x1+$x2)/2}] [expr {($y1+$y2)/2}]] } proc lmake {start end} {for {set i $start} {$i<=$end} {incr i} {lappend l $i}; return $l} #-----------------------------------------------------------------------------------# set callback_list {} proc append_callback {mode when def} { global callback_list dict set callback_list $mode $when $def } proc remove_callback {mode} { global callback_list set callback_list [dict remove $callback_list $mode] } proc modes_callback {self def {args}} { global callback_list set i 0 dict for {mode callbacks} $callback_list { foreach {when call} $callbacks { if {$def == $when} {eval $self $call $args; incr i} } } if {!$i} {return 0} else {return 1} } #-----------------------------------------------------------------------------------# # Observer pattern # there's no class for "observer". # it's anything that has def $myclass notice {args} {...} in which args indicate # attributes that have changed, or is an empty list if an unspecified number of # attributes (maybe all) have changed. class_new Observable {} def Observable init {args} { eval [concat [list super] $args] set @subscribers {} } def Observable subscribe {observer} { set i [lsearch $@subscribers $observer] if {$i<0} {lappend @subscribers $observer} } def Observable unsubscribe {observer} { set i [lsearch $@subscribers $observer] if {$i>=0} {set @subscribers [lreplace $@subscribers $i $i]} } if {$have_expand} { #def Observable changed {args} { # puts "Observable changed $self called from [info level [expr [info level]-2]]" # foreach x $@subscribers {$x notice $self {expand}$args]} #} def Observable changed {args} {foreach x $@subscribers {$x notice $self {expand}$args}} def Observable child_changed {origin args} {foreach x $@subscribers {$x notice $origin {expand}$args}} } else { def Observable changed {args} {foreach x $@subscribers {$x notice $self {*}$args}} def Observable child_changed {origin args} {foreach x $@subscribers {$x notice $origin {*}$args}} } def Observable subscribers {} {return $@subscribers} #-----------------------------------------------------------------------------------# set poolset(foo) bar array unset poolset foo class_new Manager {Thing} def Manager init {} { set @q {} $self call } def Manager call {} { #if {[llength $@q]} {post "client queue %d" [llength $@q]} for {set i 0} {$i < [llength $@q]} {incr i} { set o [lindex $@q $i] unset ::poolset($o) if {[info exists _($o:_class)]} { if {[catch {$o draw_maybe}]} {puts [error_dump]} } else { puts " tries to draw ZOMBIE $o" } if {$i == [expr {[llength $@q]-1}]} {set @q {}} } after 25 [list $self call] } def Manager notice {origin args} { if {[info exists ::poolset($origin)]} { # post %s "def Manager notice: double dirty" # nothing for now } { set ::poolset($origin) {-1} lappend @q $origin } #post "Manager notice: queue length is now %d" [llength $@q] } set serial 0 proc serial {n obj} { if {$n >= $::serial} {error "object creation serial number is in the future"} eval [concat $::replyset($n) [list $obj]] array unset ::replyset $n } proc philtre {atoms} { set r {} foreach atom $atoms {lappend r [regsub -all {([;,\\ ])} $atom {\\\1}]} return [join $r] } # you pass the 2nd argument if and only if the message creates an object (or pretends to). # this happens with #N canvas, and those methods of #X: # obj, msg, floatatom, symbolatom, text, connect, text_setto, array. # this does NOT happen with #X coords/restore/pop. proc netsend {message {callback ""}} { #if {$message == ""} {error "empty message... surely a mistake"} if {$::sock == ""} {error "connection to server needed for doing this"} if {$callback != ""} { set ::replyset($::serial) $callback set message [concat [lrange $message 0 0] [list with_reply $::serial] [lrange $message 1 end]] incr ::serial } set text "[philtre $message];" if {$::debug} {puts "[VTcyan]<- $text[VTgrey]"} puts $::sock $text } #-----------------------------------------------------------------------------------# # This is not a real Hash, just the same interface as a Ruby/Python/Perl Hash... or quite like Tcl arrays themselves class_new Hash {Thing} def Hash init {args} { super; foreach {k v} $args {$self set $k $v}} def Hash reinit {args} {$self clear; foreach {k v} $args {$self set $k $v}} def Hash set {k v} {set ::hash($self:$k) $v} def Hash exists {k} {info exists ::hash($self:$k)} def Hash get {k} {set ::hash($self:$k)} def Hash size {} {llength [$self keys]} def Hash unset {k} {unset ::hash($self:$k)} def Hash list {} {set r {}; foreach k [$self keys] {lappend r $k [$self get $k]}; return $r} def Hash keys {} { set r {} set n [string length $self:] foreach k [array names ::hash $self:*] {lappend r [string range $k $n end]} return $r } def Hash values {} { set r {} foreach k [array names ::hash $self:*] {lappend r $::hash($k)} return $r } def Hash clear {} {foreach k [$self keys] {$self unset $k}} def Hash delete {} {$self clear; super} def Hash search {v} { foreach k [$self keys] {if {[$self get $k] == $v} {return $k}} return -1 ;# this is not correct as -1 could be a Hash key, though not in its current context of use... } if 0 { set h [Hash new foo bar 1 2 3 4] $h set hello world puts keys=[$h keys] puts values=[$h values] puts list=[$h list] $h unset foo puts list=[$h list] $h clear puts list=[$h list] foreach i {1 2 3 4} {puts "exists $i : [$h exists $i]"} } class_new Selection {Hash} def Selection set {k v} {super $k $v; $v selected?= 1} def Selection unset {k} { #set v [$self get $k]; puts "$v ::: [$v class]" if {[$self exists $k]} {[$self get $k] selected?= 0} super $k } #-----------------------------------------------------------------------------------# # abstract class: subclass must def {value value= <<} class_new Clipboard {Observable Thing} def Clipboard init {{value ""}} {super; $self value= $value; set @copy_count 0} # uses system clipboard class_new Clipboard1 {Clipboard} def Clipboard1 value= {value} {clipboard clear; clipboard append $value; $self changed} def Clipboard1 << {value} { clipboard append $value; $self changed} def Clipboard1 value {} {clipboard get} # uses string buffer (not system clipboard) class_new Clipboard2 {Clipboard} def Clipboard2 value= {value} {set @value $value; $self changed} def Clipboard2 << {value} {append @value $value; $self changed} def Clipboard2 value {} {return $@value} if {$tk} { set clipboard [Clipboard1 new] } else { set clipboard [Clipboard2 new] } #-----------------------------------------------------------------------------------# class_new EventHistory {Observable Thing} def EventHistory init {} {super; set @list {}} def EventHistory add {e} {lappend @list $e; $self changed add $e} def EventHistory list {{formatted 1}} { if {!$formatted} {return $@list} set r {} foreach event $@list { mset {type W x y mod K k} $event lappend r [format "%-13s %9s %4d %4d %4d %4d %s" $type $K $k $x $y $mod $W] } return $r } set ::event_history [EventHistory new] #-----------------------------------------------------------------------------------# class_new CommandHistory {Observable Thing} def CommandHistory init {} { super set @undo_stack {} set @redo_stack {} } def CommandHistory can_undo? {} {return [expr {[llength @undo_stack] > 0}]} def CommandHistory can_redo? {} {return [expr {[llength @redo_stack] > 0}]} def CommandHistory next_undo_name {} {return stuff} def CommandHistory next_redo_name {} {return stuff} def CommandHistory undo_stack {} {return $@undo_stack} def CommandHistory redo_stack {} {return $@redo_stack} # overload this if you want to control how many levels # of undo may be kept. # keep in mind that undo information is kept hierarchically. def CommandHistory add {message} { lappend @undo_stack [list do $message [lrange [info level -3] 1 end]] set @redo_stack {} $self changed } def CommandHistory can't {} { lappend @undo_stack [list can't {} [lrange [info level -3] 1 end]] set @redo_stack {} $self changed } # runs the restore procedure for the last item in the root undo queue. def CommandHistory undo {} { if {![$self can_perform? [lindex $@undo_stack end]]} {error "Can't undo this!"} set backup $@undo_stack set @undo_stack $@redo_stack set @redo_stack {} #set err [catch {$self perform [lindex $backup end]}]; if {$err} {set err $::errorInfo} $self atomically [list atomic_undo] { $self perform [lindex $backup end] } set @redo_stack $@undo_stack set @undo_stack [lrange $backup 0 end-1] $self changed #if {$err} {post %s $err; error "undo: $err"} } def CommandHistory redo {} { if {![$self can_perform? [lindex $@undo_stack end]]} {error "Can't redo this!"} set backup $@redo_stack set @redo_stack {} set err [catch {$self perform [lindex $backup end]}]; if {$err} {set err $::errorInfo} $self atomically [list atomic_redo] { $self perform [lindex $backup end] } set @redo_stack [lrange $backup 0 end-1] $self changed #if {$err} {post %s $err; error "redo: $err"} } def CommandHistory can_perform? {action} { switch -- [lindex $action 0] { do {return 1} can't {return 0} default { foreach x [lrange $action 1 end] { if {![$self can_perform? $x]} {return 0} } return 1 } } } def CommandHistory perform {action} { switch -- [lindex $action 0] { do {eval [lindex $action 1]} can't {error "can't undo this!"} default {foreach x [lreverse [lindex $action 1]] {$self perform $x}} } } def CommandHistory atomically {what code} { set ubackup @undo_stack; set @undo_stack {} set rbackup @redo_stack; set @redo_stack {} uplevel 2 $code set atom $@undo_stack set @undo_stack $ubackup set @redo_stack $rbackup lappend @undo_stack [list $what $atom [lrange [info level -3] 1 end]] $self changed } def CommandHistory list {} { set r {} set hist [concat [$self undo_stack] [list "You Are Here"] [lreverse [$self redo_stack]]] set i 0 foreach e $hist {lappend r "$i: $e"; incr i} return $r } set command_history [CommandHistory new] #-----------------------------------------------------------------------------------# class_new History {Thing} def History init {size} { set @size $size set @hist {{}} set @histi -1 } def History histi= {val} {set @histi $val} def History histi {} {return $@histi} def History set_hist {idx stuff} {set @hist [lreplace $@hist $idx $idx $stuff]} def History prepend {stuff} { set @hist [linsert $@hist 1 $stuff] if {[llength $@hist] >= $@size} {set @hist [lrange $@hist 0 [expr {$@size-1}]]} } def History traverse {incr} { set @histi [expr {$@histi + $incr}] set mod [min [llength $@hist] [expr {$@size+1}]] if {$@histi >=$mod} {set @histi [expr $@histi%$mod]} if {$@histi < 0} {set @histi [expr ($@histi+$mod)%$mod]} return [lindex $@hist $@histi] } History new_as obj_hist 5 #-----------------------------------------------------------------------------------# # this is the beginning of the more application-dependent part. switch $tcl_platform(os) { Darwin {set OS osx} default {set OS $tcl_platform(platform)} } if {$tk} { option add *foreground #000000 option add *font {Helvetica -12} foreach tkclass {Menu Button Checkbutton Radiobutton Entry Text Spinbox Scrollbar Canvas} { option add *$tkclass*borderWidth 1 option add *$tkclass*activeBorderWidth 1 } foreach tkclass {CheckButton RadioButton} { option add *$tkclass*selectColor #dd3000 } foreach tkclass {Entry Text} { option add *$tkclass*background #b0c4d8 option add *$tkclass*selectBackground #6088b0 } option add *__tk__messagebox*Canvas*borderWidth 0 foreach tkclass {Listbox} { option add *$tkclass*background #c4d8b0 option add *$tkclass*selectBackground #88b060 } foreach tkclass {Label} { #option add *$tkclass*background #909090 } # very small icons: foreach {name w h values} { icon_empty 7 7 "0,0,0,0,0,0,0" icon_plus 7 7 "8,8,8,127,8,8,8" icon_minus 7 7 "0,0,0,127,0,0,0" icon_close 7 7 "99,119,62,28,62,119,99" icon_wedge_up 7 5 "8,28,62,127,0" icon_wedge_down 7 5 "0,127,62,28,8" icon_up 7 7 "8,28,62,127,28,28,28" icon_down 7 7 "28,28,28,127,62,28,8" icon_right 7 7 "8,24,63,127,63,24,8" icon_left 7 7 "8,12,126,127,126,12,8" } { image create bitmap $name -data "#define z_width $w\n#define z_height $h static unsigned char z_bits[] = { $values };" } set main [. cget -class] set ::current_window . bind $main <FocusIn> {set ::current_window %W} bind Toplevel <FocusIn> {set ::current_window %W} proc tk_messageBox2 {args} {tk_messageBox -parent $::current_window {*}$args} # Also we have to get rid of tab's changing the focus. bind all <Key-Tab> "" #bind all <Key-Shift-Tab> "" bind all <<PrevWindow>> "" set mods {{} 0 Shift- 1 Control- 4 Shift-Control- 5 Alt- 8 Shift-Alt- 9 Control-Alt- 12 Shift-Control-Alt- 13} foreach type {KeyPress KeyRelease} { foreach {subtype mod} $mods { bind all <$subtype$type> "$::event_history add \[list $type %W %x %y $mod %K %k\]" } } foreach type {ButtonPress ButtonRelease} { foreach {subtype mod} $mods { bind all <$subtype$type> "$::event_history add \[list $type %W %x %y $mod %b %b\]" } } } proc modekey {k mode} { set s "" if {$mode&1} {append s Shift-} if {$mode&4} {append s Control-} if {$mode&8} {append s Alt-} if {[regexp {[0-9]} $k]} {set k Key-$k} return $s$k } proc modeclick {k mode event} { set s "" if {$mode&1} {append s Shift-} if {$mode&4} {append s Control-} if {$mode&8} {append s Alt-} if {[regexp {[0-9]} $k]} {set k $event-$k} return $s$k } # there are two palettes of 30 colours used in Pd # when placed in a 3*10 grid, the difference is that # the left corner of 3*3 (the greys) are transposed (matrixwise) # here is the one used in the swatch color selector: set preset_colors { fcfcfc e0e0e0 bcbcbc fce0e0 fce0c0 fcfcc8 d8fcd8 d8fcfc dce4fc f8d8fc a0a0a0 7c7c7c 606060 fc2828 fcac44 e8e828 14e814 28f4f4 3c50fc f430f0 404040 202020 000000 8c0808 583000 782814 285014 004450 001488 580050 } switch $::OS { osx {set pd_tearoff 0} default {set pd_tearoff 1} } proc guess_lang {} { set lang C if {[info exist ::env(LC_ALL)]} {set lang $::env(LC_ALL)} if {[info exist ::env(LANG)]} {set lang $::env(LANG)} set lang [lindex [split $lang {[_.]}] 0] return $lang } #temporary set leet 0 proc say {k args} { global text if {[llength $args]} { set text($k) [lindex $args 0] } else { if {[info exist text($k)]} { if {$::leet} { return [string map -nocase {a 4 e 3 t 7 s 5 i 1 o 0 g 9} $text($k)] } else { return $text($k) } } else {return "{{$k}}"} } } proc can_say {k args} { return [info exist ::text($k)] } proc say_namespace {k code} {uplevel 1 $code} proc say_category {text} {} switch -- [lindex [file split $argh0] end] { desire.tk {set cmdline(server) [file join [file dirname $argh0] pd]} default {set cmdline(server) [file join [file dirname [file dirname $argh0]] bin/pd]} } set cmdline(rcfilename) ~/.pdrc set cmdline(ddrcfilename) ~/.ddrc set cmdline(console) 1000 if {[file exists ../icons/mode_edit.gif]} { set cmdline(icons) ../icons } else { set cmdline(icons) [file join [file dirname [file dirname $argh0]] lib/pd/icons] } #-----------------------------------------------------------------------------------# set accels {} proc read_client_prefs_from {filename} { global cmdline look key accels set ::accels {} puts "reading from $filename" set fd [open $filename] set contents [read $fd] close $fd foreach {category category_data} $contents { foreach {class class_data} $category_data { foreach {var val} $class_data {set ${category}($class:$var) $val} } } foreach k [array names key] { if {[llength $key($k)]} { if {![dict exists $accels $key($k)]} { dict set accels $key($k) $k } else { dict lappend accels $key($k) $k } } } } proc read_ddrc {} { ;# load defaults then load .ddrc if {[file exists "defaults.ddrc"]} { read_client_prefs_from "defaults.ddrc" } else { read_client_prefs_from [file join [file dirname [file dirname $::argh0]] "lib/pd/bin/defaults.ddrc"] } if {[file exists $::cmdline(ddrcfilename)]} { read_client_prefs_from $::cmdline(ddrcfilename) } } read_ddrc #-----------------------------------------------------------------------------------# set cmdline(port) 0 set cmdline(gdb) 0 set cmdline(gdbconsole) 1 set cmdline(valgrind) 0 if {$look(View:language) eq "auto"} { set language [guess_lang] } else { set language $look(View:language) } set files_to_open {} proc cmdline_help {} { puts "DesireData commandline options: -serverargs (for future use) -server select the executable for the pd server -gdb run pd server through gdb -manualgdb run gdb in the terminal -valgrind run pd server through valgrind -novalgrind ... or don't -safemode run desiredata with all default settings -dzinc use zinc emulation" } for {set i 0} {$i < $argc} {incr i} { global cmdline files_to_open set o [lindex $argv $i] switch -regexp -- $o { ^-port\$ {incr i; set cmdline(port) [lindex $argv $i]} ^-serverargs\$ {error "not supported yet"} ^-server\$ {incr i; set cmdline(server) [lindex $argv $i]} ^-gdb\$ {set cmdline(gdb) 1} ^-manualgdb\$ {set cmdline(gdbconsole) 0} ^-valgrind\$ {set cmdline(valgrind) 1} ^-novalgrind\$ {set cmdline(valgrind) 0} ^-safemode\$ {set cmdline(safemode) 1} ^-dzinc\$ {set cmdline(dzinc) 1} ^(-h|-help|--help)\$ {cmdline_help; exit 1} ^- {puts "ERROR: command line argument: unknown $o"} default {lappend files_to_open [lindex $argv $i]} } } #set cmdline(server) \"$cmdline(server)\" set encoding "" if {$language == "C"} {set language en} proc localedir {x} {file join [file dirname [file dirname $::argh0]] lib/pd/bin/$x} if {[regexp {desire\.tk$} $argh0]} {source locale/index.tcl} {source [localedir locale/index.tcl]} puts "locale/index.tcl vs [localedir locale/index.tcl]" set langentry [figure_out_language $language] set encoding [lindex $langentry 0] set langfile locale/[lindex $langentry 1].tcl if {[regexp {desire\.tk$} $argh0]} { if {$encoding != ""} {source -encoding $encoding $langfile} else {source $langfile} } else { if {$encoding != ""} {source -encoding $encoding [localedir $langfile]} else {source [localedir $langfile]} } if {[info exists ::cmdline(safemode)]} {read_client_prefs_from "defaults.ddrc"} if {[info exists ::cmdline(dzinc)]} {package require dzinc} #-----------------------------------------------------------------------------------# #!@#$ is this still valid? set look(Box:extrapix) [switch $::OS { osx {concat 2} default {concat 1}}] #font is defined as Thing for now, as the completion needs to get to these ones. #!@#$ View->??? #set look(View:tooltip) 1 #!@#$ View->TextBox ? #set look(View:minobjwidth) 21 #!@#$ View->ObjectBox #set look(View:fg) #000000 #set look(View:bg) #ffffff #set look(View:frame1) #99cccc #set look(View:frame2) #668888 #set look(View:frame3) #000000 set zoom(canned) [list 25 33 50 75 100 125 150 200 250 300 400] set scale_amount 1.1 ################## set up main window ######################### class_new Console {View} def Console osx_scroll {axis diff} {$@c.1 yview scroll [expr {-2-abs($diff)/$diff}]} def Console init {c} { set @c $c frame $c text $c.1 -width 72 -height 20 -yscrollcommand "$c.2 set" -font [$self look font] scrollbar $c.2 -command "$c.1 yview" pack $c.1 -side left -fill both -expand yes pack $c.2 -side left -fill y -expand no pack $c -fill both -expand yes $c.2 set 0.0 1.0 switch $::OS {osx {bind $c.1 <MouseWheel> [list $self osx_scroll %D]}} set @lines 0 } def Console widget {} {return $@c} def Console post_string {x} { set oldpos [lindex [$@c.2 get] 1] $@c.1 insert end $x regsub -all "\n" $x "" y set n [expr {[string length $x]-[string length $y]}] incr @lines $n set max $::cmdline(console) if {$@lines >= $max} {$@c.1 delete 1.0 [expr {$@lines-$max+1}].0; set @lines $max} if {$oldpos > 0.9999} {$@c.1 see end} } #class_new Client {Menuable View} class_new Client {Menuable Thing} set ctrls_audio_on 0 set ctrls_meter_on 0 def Client window {} {return .} def Client init_binds {} { bind . <Control-Key> {$main ctrlkey %x %y %K %A 0} bind . <Control-Shift-Key> {$main ctrlkey %x %y %K %A 1} switch $::OS { osx { bind . <Mod1-Key> {$main ctrlkey %x %y %K %A 0} bind . <Mod1-Shift-Key> {$main ctrlkey %x %y %K %A 1} } } # bind . <Motion> {.debug.1 configure -text "widget = %W"} } # miller uses this nowadays (matju fished it in pd-cvs for 0.40). we don't use it for now. # remember to fix all quoting problems, which in the end may or may not involve the following proc. proc pdtk_unspace {x} { set y [string map {" " "_" ";" "" "," "" "{" "" "}" "" "\\" ""} $x] if {$y == ""} {set y "empty"} concat $y } proc pdtk_pd_meters {indb outdb inclip outclip} { foreach {z clip db} [list in $inclip $indb out $outclip $outdb] { .controls.$z.1.mtr coords m 0 0 $db 0 .controls.$z.1.clip configure -background [if {$clip==1} {concat red} {concat black}] } } proc pd_startup {version apilist midiapilist args} { set ::pd_version $version set ::pd_apilist $apilist set ::pd_midiapilist $midiapilist foreach api $apilist { lappend ::pd_apilist2 "-[string tolower [lindex $api 0]]" } set version [regsub "^DesireData " $::pd_version ""] post "DesireData server version $version" } def Client init_controls {} { menu .mbar pack [frame .controls] -side top -fill x foreach t {file window help} { .mbar add cascade -label [say $t] -menu [menu .mbar.$t -tearoff $::pd_tearoff] } .mbar.window configure -postcommand "$self fix_window_menu" foreach {z fill} {in #0060ff out #00ff60} { set f .controls.$z frame $f frame $f.1 -borderwidth 2 -relief groove canvas $f.1.mtr -width 100 -height 10 -bg #222222 $f.1.mtr create line [list 0 0 0 0] -width 24 -fill $fill -tags m canvas $f.1.clip -width 5 -height 10 -bg #222222 pack $f.1.mtr $f.1.clip -side left pack [label $f.2 -text [say $z]:] $f.1 -side left pack $f -side left -pady 0 -padx 0 } foreach {w x y z} { audiobutton audio ctrls_audio_on {netsend [list pd dsp $ctrls_audio_on]} meterbutton meters ctrls_meter_on {netsend [list pd meters $ctrls_meter_on]} } { pack [checkbutton .controls.$w -text [say $x] -variable $y -anchor w -command $z] -side left } button .controls.clear -text [say console_clear] -command {.log.1 delete 0.0 end} -padx 2 -pady 0 button .controls.dio -text [say io_errors] -command {netsend [list pd audiostatus]} -padx 2 -pady 0 pack .controls.clear .controls.dio -side right if {$::debug} { frame .debug pack [label .debug.1 -anchor w -text ""] -side left pack [entry .debug.3 -textvariable ::serial -width 5] -side right pack [label .debug.2 -text "obj.serial: " -justify right] -side right pack .debug -side bottom -fill x } if {$::cmdline(console)} {set ::console [Console new .log]} . configure -menu .mbar wm title . "DesireData" catch {wm iconphoto . icon_pd_32} if {[regexp {\d\d\d\d-\d\d-\d\d} $::svnid date]} { regsub -all "/" $date "." date regexp {desire.tk (\d+)} $::svnid blah revision set version "svn#$revision ($date)" } {set version "(unknown svn version)"} set ::pd_version_client $version post "DesireData client version %s" $version post "Running from %s" [info script] post "Using Tcl %s and Tk %s" $::tcl_patchLevel $::tk_patchLevel } proc pdtk_pd_dsp {value} { global ctrls_audio_on set ctrls_audio_on $value } proc pdtk_pd_dio {red} { .controls.dio configure -background red -activebackground [if {$red==1} {list red} {list lightgrey}] } ############### set up global variables ################################ set pd_opendir [pwd] ############### set up socket ########################################## set sock {} set sock_lobby {} proc poll_sock {} { global sock sock_lobby cmdline if {[llength $sock]==0} {return} while {1} { set cmd [gets $sock] if {[eof $sock]} { if {!$cmdline(gdb)} { tk_messageBox2 -message "connection ended by server.\n(crash? try: desire -gdb)" -type ok } set sock {} return } if {[fblocked $sock]} {break} if {$::debug} {if {[string first pdtk_post $cmd]!=0} {puts "[VTmagenta]-> $cmd[VTgrey]"}} append sock_lobby "\n$cmd" if {[catch {eval $sock_lobby}]} { switch -regexp -- $::errorInfo { "^missing close-brace" { #puts "waiting for the end of: [string range $sock_lobby 0 40]" continue }} error_dump } set sock_lobby {} } flush $sock after 25 poll_sock } set server_pid 0 proc poll_gdb {} { global gdb while {1} { set line [gets $gdb] if {$line=="" || [fblocked $gdb]} {break} ;# which way should i check for no input? if {[eof $gdb]} {return} regsub {^\(gdb\) ?} $line {} line if {[regexp {^\[Thread debug} $line]} {continue} if {[regexp {^\[New Thread.*LWP (\d+)} $line dummy pid]} { if {!$::server_pid} { set ::server_pid $pid post "server pid=$pid" continue } } if {[regexp {^Reading symbols from} $line]} {continue} if {[regexp {^Using host libthread_db} $line]} {continue} if {[regexp {^Starting program:} $line]} {continue} if {[regexp {^Program received signal (\w+), (.*)\.} $line bogus sig1 sig2]} { set where "" # can anyone figure out why a long backtrace won't be slurped in this case? set timeout [expr {[clock seconds]+2}] #fconfigure $gdb -blocking 1 -buffering none while {![eof $gdb] && [clock seconds] < $timeout} { set line [gets $gdb] if {$line eq ""} {continue} ;# busy-wait regsub {^\(gdb\) ?} $line {} line append where "$line\n" #puts "where size = [string length $where]" } OopsDialogue new $sig1 $sig2 $where } post "\[gdb\] %s" $line } after 100 poll_gdb } proc pd_connect {} { global sock if {[catch {set sock [socket 127.0.0.1 13666]}]} { post "can't connect... wait a second" after 1000 pd_connect return } post "Connected to server" fconfigure $sock -blocking 0 -buffering line netsend [list pd init] poll_sock foreach f $::files_to_open { set ff [file split [file normalize $f]] set ffl [llength $ff] set file [lindex $ff [expr $ffl-1]] set dir [join [lrange $ff 0 [expr $ffl-2]] [file separator]] netsend [join [list pd open $file $dir]] } } set server_port 13666 after 1000 pd_connect after 0 { if {$cmdline(port)} { set server_port $cmdline(port) # and then do nothing... } elseif {$cmdline(valgrind)} { #exec valgrind --tool=memcheck $cmdline(server) -guiport $server_port & exec valgrind --tool=memcheck --gen-suppressions=all --suppressions=valgrind3.supp $cmdline(server) -guiport $server_port & } else { if {$cmdline(gdb)} { if {$cmdline(console) && $cmdline(gdbconsole)} { set gdb [open "| gdb --quiet 2&>1" w+] fconfigure $gdb -blocking 0 -buffering none puts $gdb "file \"$cmdline(server)\"" ;# bad quoting, sorry puts $gdb "set width 242" puts $gdb "run -guiport $server_port" puts $gdb "where" puts $gdb "quit" flush $gdb after 0 poll_gdb } else { exec gdb --args $cmdline(server) -guiport $server_port & #exec gdb --tui --args $cmdline(server) -guiport $server_port & } } else { exec $cmdline(server) -guiport $server_port & } } } ################ utility functions ######################### proc enquote {x} { set foo [string map {"," "" ";" "" "\"" ""} $x] return [string map {" " "\\ " "{" "" "}" ""} $foo] } proc pdtk_watchdog {} {netsend [list pd ping]; after 2000 {pdtk_watchdog}} proc accel_munge {acc} { switch $::OS { osx { set tmp [string toupper [string map {Ctrl Meta} $acc] end] if [string is upper [string index $acc end]] { return Shift+$tmp } else { return $tmp } } default {return $acc} } } # a menuable must be a View # and it must have a window so that the Menuable methods work # it could be renamed to Windowed class_new Menuable {} def Menuable init {args} { eval [concat [list super] $args] set @accel {} set @menubar .$self.m } # this doesn't have to do with menus, only with toplevel windows. def Menuable raise {} { set w [$self window] set w $w.c raise $w focus -force $w } set untitled_number 1 set untitled_folder [pwd] # just a dummy proc proc none {args} {} def Client new_file {} { global untitled_number untitled_folder netsend [list pd filename Untitled-$untitled_number $untitled_folder] netsend [list #N canvas] netsend [list #X pop 1] incr untitled_number } set patch_filetypes { {"pd files" ".pd"} {"max files" ".pat"} {"all files" "*"} } set image_filetypes { {"image files" ".gif .png"} {"gif files" ".gif"} {"png files" ".png"} {"all files" "*"} } catch {tk_getOpenFile -load-once} ;#only works with tcltk 8.5 catch { set ::tk::dialog::file::showHiddenBtn 1 set ::tk::dialog::file::showHiddenVar 0 } def Client open_file {} { global pd_opendir patch_filetypes set filename [tk_getOpenFile -parent $::current_window -defaultextension .pd -filetypes $patch_filetypes -initialdir $pd_opendir] if {$filename != ""} {$self open_file_really $filename} } def Client open_file_really {filename} { set i [string last / $filename] set folder [string range $filename 0 [expr $i-1]] set ::pd_opendir $folder set basename [string range $filename [expr $i+1] end] if {[string last .pd $filename] >= 0} { netsend [list pd open $basename $folder] } } def Client send_message {} { toplevel .sendpanel set e .sendpanel.entry pack [entry $e -textvariable send_textvar] -side bottom -fill both -ipadx 100 $e select from 0 $e select adjust end bind $e <KeyPress-Return> {netsend $send_textvar; after 50 {destroy .sendpanel}} focus $e } def Client quit {} { set answer [tk_messageBox2 -message "Do you really wish to quit?" -type yesno -icon question] switch -- $answer {yes {netsend [list pd quit]; exit}} } def Client abort_server {} { set answer [tk_messageBox2 -message "Do you really wish to abort?" -type yesno -icon question] switch -- $answer {yes {exec kill -ABRT $::server_pid}} } def Client server_prefs {} {ServerPrefsDialogue new_as pdrc} def Client client_prefs {} {ClientPrefsDialogue new_as ddrc} proc menu_pop_pd {} {raise .} def Menuable populate_menu {menu list} { global key if {[string index $menu 0] != "."} {set menu $@menubar.$menu} foreach name $list { if {$name == ""} {$menu add separator; continue} set k "" if {[info exists key($@_class:$name)]} { if {[string length $key($@_class:$name)]} {set k $key($@_class:$name)} } $menu add command -label [say $name] -command "$self $name" -accelerator [accel_munge $k] } } def Client init_menus {} { #removed paths after send_message $self populate_menu file { new_file open_file {} server_prefs client_prefs send_message {} audio_on audio_off {} abort_server quit} $self populate_menu help { about documentation class_browser do_what_i_mean {} test_audio_and_midi load_meter latency_meter {} clipboard_view command_history_view event_history_view keyboard_view client_class_tree} } def Client init {} { super set @menubar .mbar $self init_controls $self init_binds $self init_menus # it's necessary to raise the window on OSX switch $::OS { osx {raise .; wm iconify .; after 100 {wm deiconify .}}} after 0 { Listener new .tcl [say "tcl_console"] tcl_eval Listener new .pd [say "pd_console"] pd_eval } #wm geometry .[$self keyboard_view] -0+0 #wm geometry .[$self event_history_view] -0-0 } proc post {args} { set s "[eval [linsert $args 0 format]]\n" # set s "[info level -1]: $s" if {$::cmdline(console)} {$::console post_string $s} else {puts stderr $s} } proc pdtk_post {s} { if {$::cmdline(console)} {$::console post_string $s} else {puts stderr $s} } def Menuable eval% {code} { regsub -all %W $code $self code uplevel [info level] $code } def Menuable getkey {k} { global accels if {[dict exists $accels $k]} { set vars [dict get $accels $k] foreach var $vars { #mset {class key} [split [dict get $accels $k] ":"] mset {class key} [split $var ":"] #if {$class != $@_class} {return ""} else {return $key} if {$class == $@_class} {return $key} } } } def Menuable ctrlkey {x y key iso shift} { set key [if {$shift} {string toupper $key} {string tolower $key}] set key "Ctrl+$key" set cmd [$self getkey $key] if {![string length $cmd]} { switch [$self class]:$key { #explicitly listed here to do nothing Client:Ctrl+c {} Client:Ctrl+v {} default {post "unknown key $key"} } } else {$self eval% "%W $cmd"} } def Menuable altkey {x y key iso shift} { set key [if {$shift} {string toupper $key} {string tolower $key}] set key "Alt+$key" set cmd [$self getkey $key] if {[string length $cmd]} {$self eval% "%W $cmd"} else {post "unknown key $key"} } #-----------------------------------------------------------------------------------# set pd_apilist "{ALSA 1}" set pd_apilist2 "default" #-----------------------------------------------------------------------------------# #fixme: actually, is it ok that View<Menuable ? --matju class_new View {Menuable Observable Thing} # normally ninlets/noutlets should be in class "Box", but server-side isn't smart enough def View pdclass= {v} {set @pdclass $v} def View pdclass {} {return $@pdclass} def View ninlets= {v} {set @ninlets $v} def View ninlets {} {return $@ninlets} def View noutlets= {v} {set @noutlets $v} def View noutlets {} {return $@noutlets} def View click {x y f target} {} def View unclick {x y f target} {} def View motion {x y f target} {} def View subpatch {} {if {[info exists @subpatch]} {return 1} else {return 0}} def View look_cache {k} { global look look_cache foreach super [$@_class ancestors] { if {[info exists look($super:$k)]} { set look_cache($@_class:$k) $super return $super } } } def View look {k} { if {![info exists ::look_cache($@_class:$k)]} {$self look_cache $k} return $::look($::look_cache($@_class:$k):$k) } def View init {} { super set @selected? 0 set @index 0xDEADBEEF set @ninlets 1 ;# should be in Box init set @noutlets 0 ;# should be in Box init set @canvas "" # set @inside_box 42 ;# temporary fix set @ioselect {} } def View classtags {} {return {foo}} set item { set canvas [$self get_canvas] if {$canvas == ""} {return} set c [$self cwidget] set zoom [$canvas zoom] set coords [lmap * $coords $zoom] set find [lsearch $args "-width"] if {$find >= 0} { incr find set w [lindex $args $find] lset args $find [format %.0f [expr {$w*$zoom}]] } set find [lsearch $args "-font"] if {$find >= 0} { incr find set fs [lindex [lindex $args $find] 1] lset args $find 1 [format %.0f [expr {$fs*$zoom}]] } #set find [lsearch $args "-fill"] #if {$find >= 0} { # incr find # set fill [lindex $args $find] # lset args $find [randomise_color $fill] #} set tags {} foreach s $suffixes {lappend tags "$self$s"} set ss [lindex $tags 0] lappend tags $self set tags [concat $tags [$self classtags]] } append item [correct_splat { if {![llength [$c gettags $ss]]} { $c create $type $coords -tags $tags {*}$args } { $c itemconfigure $ss {*}$args $c coords $ss {*}$coords } }] def View item {suffixes type coords args} $item def View item_delete {{suffix all}} { if {$@canvas == ""} {return} set c [$@canvas widget] if {![winfo exists $c]} { set canvas [$@canvas get_canvas] if {$canvas == ""} {return} set c [[$@canvas get_canvas] widget] if {![winfo exists $c]} {return} } switch -- $suffix { all {$c delete $self} default {$c delete $self$suffix}} } def View draw {} {} def View delete {} {$self erase; super} def View erase {} {$self item_delete} def View selected? {} {return $@selected?} def View selected?= {x} {set @selected? $x; $self changed} ;# this is for use by the Selection class only def View edit? {} {if {[info exists @edit]} {return $@edit} else {return 0}} def View select {state} { set ostate [$self selected?] set @selected? $state if {$state!=$ostate} {$self changed} } # give topleft point of an object in the canvas it's rendered in. # this includes GOP and excludes zoom. # inheritance problem: this doesn't work for Wire, which doesn't store its positions def View xy {} { if {$@canvas == ""} {return [list $@x1 $@y1]} set type [$@canvas type] if {$type == "gopabs" || $type == "gopsub"} { mset {xmargin ymargin} [$@canvas margin] mset {x y} [$@canvas xy] set x1 [expr {($@x1-$xmargin)+$x}] set y1 [expr {($@y1-$ymargin)+$y}] #if $self's gop is opened if {[regexp {^.x[0-9a-f]{6,8}.c} [focus] f]} { if {$f == ".$@canvas.c"} {set x1 $@x1; set y1 $@y1} } #if {[focus] != "." && [focus] == ".$@canvas.c"} {set x1 $@x1; set y1 $@y1} return [list $x1 $y1] } return [list $@x1 $@y1] } def View canvas {} {return $@canvas} def View canvas= {c} { set @canvas $c # should "subscribe" call "changed"? (or pretend to?) $self subscribe $c $self changed $self outside_of_the_box } def View visible {} {if {[info exists @inside_box]} {return $@inside_box} {return -1}} # this returns the canvas actually exists/drawn # see also def Canvas get_canvas def View get_canvas {} { set canvas $@canvas if {$canvas == ""} {return ""} #while {![$canvas havewindow]} {set canvas [$canvas canvas]} while {![winfo exists [$canvas widget]]} {set canvas [$canvas canvas]} return $canvas } # this will return the top level gop if gop is nested def View get_parent_gop {canvas} { set obj $self while {$canvas != [$obj canvas]} {set obj [$obj canvas]} return $obj } def View outside_of_the_box {} { if {$@canvas eq ""} {return} # always hide these things if {[$self class] == "Wire"} {set @inside_box 0; return} if {[$self class] == "ObjectBox"} {set @inside_box 0; return} if {[$self class] == "MessageBox"} {set @inside_box 0; return} if {[$self class] == "Comment"} {set @inside_box 0; return} if {[$self class] == "Array"} {$@canvas visibles+= $self; set @inside_box 1; return} set x1 $@x1; set y1 $@y1 if {[$@canvas gop]} { set mess [$@canvas get_mess] set pixwidth [lindex $mess 4] set pixheight [lindex $mess 5] if {[llength $mess] == 6} { set xmargin 0; set ymargin 0 } else { set xmargin [lindex $mess 6]; set ymargin [lindex $mess 7] } if {$x1 < $pixwidth +$xmargin && $x1 > $xmargin && \ $y1 < $pixheight+$ymargin && $y1 > $ymargin} { set @inside_box 1 $@canvas visibles+= $self } else { set @inside_box 0 $@canvas visibles-= $self } } else {set @inside_box 1} } def View draw_maybe {} { if {$@canvas == "" && [winfo exists .$self.c]} {$self draw; return} if {[$self class] == "Canvas" && $@canvas == ""} {return} if {$@inside_box} { #if {[$@canvas mapped] && ![$@canvas abs] && [$self gop_check]} {$self draw} if {[$@canvas mapped] && [$self gop_check]} {$self draw} } else { # for drawing opened gop if {[winfo exists .$@canvas.c]} {$self draw} } } #this checks if $self can be seen, ie nested gop. def View gop_check {} { set canvases $@canvas while {[lindex $canvases end] != ""} {lappend canvases [[lindex $canvases end] canvas]} set canvases [lreplace $canvases end-1 end]; # all canvases foreach canvas $canvases { # if a canvas is not a gop and its window does not exists if {![$canvas gop] && ![winfo exists [$canvas widget]]} {return 0; break} } return 1 } #-----------------------------------------------------------------------------------# class_new Canvas {Menuable ObjectBox} def Canvas close {} { after cancel $@motion_after_id if {$@subpatch} { #can't wait till @mapped get updated thru proc change if {$@gop} {foreach x [$@objects values] {$x outside_of_the_box}} $self save_geometry $self copy_times= 0 netsend [list .$self vis 0] #netsend [list .$self close] return } if {$@gop} { foreach x [$@objects values] {$x outside_of_the_box} netsend [list .$self close] return } switch [tk_messageBox2 -message [say save_changes?] -icon question -type yesnocancel -default cancel] { yes {$self save; netsend [list .$self close]} no { netsend [list .$self close]} cancel {} } } def Canvas save_geometry {} { set geometry [wm geometry .$self] set cw [winfo width [$self widget]]; set ch [winfo height [$self widget]] foreach {size x y} [split $geometry "+"] {mset {w h} [split $size "x"]; set x1 $x; set y1 $y} set x2 [expr $x1+$cw]; set y2 [expr $y1+$ch] netsend [list .$self bounds $x1 $y1 $x2 $y2] } def Canvas save {} { if {$@subpatch} {return [$@canvas save]} $self checkgeometry set c [$self widget] if {![regexp {^Untitled-[0-9]} $@name]} { $self save_geometry netsend [list .$self savetofile $@name $@folder] } else { $self save_as } } def Canvas save_as {} { $self checkgeometry set filename [tk_getSaveFile -parent $::current_window -filetypes $::patch_filetypes] if {$filename != ""} { set @file [string range $filename [expr [string last / $filename]+1] end] set @folder [string range $filename 0 [expr [string last / $filename]-1]] $self save_geometry puts "save $@file dir to $@folder" netsend [list .$self savetofile $@file $@folder] } } def Canvas print {} { set filename [tk_getSaveFile -parent $::current_window -initialfile pd.ps -defaultextension .ps -filetypes { {{postscript} {.ps}} }] if {$filename != ""} {[$self widget] postscript -file $filename} } def Canvas quit {} {$::main quit} def Canvas abort_server {} {$::main abort_server} proc wonder {} {tk_messageBox2 -message [say ask_cool] -type yesno -icon question} def Canvas eval% {code} { mset {x y} $@curpos regsub -all %X $code $x code regsub -all %Y $code $y code super $code } def Client documentation {} { set filename [tk_getOpenFile -parent $::current_window -defaultextension .pd -filetypes { {{documentation} {.pd .txt .htm}} } -initialdir $::docdir] if {$filename != ""} { if {[string first .txt $filename] >= 0} { menu_opentext $filename } elseif {[string first .htm $filename] >= 0} { menu_openhtml $filename } else { set i [string last / $filename] set help_directory [string range $filename 0 [expr $i-1]] set basename [string range $filename [expr $i+1] end] netsend [list pd open [enquote $basename] [enquote $help_directory]] } } } def Canvas new_file {} {$::main new_file} def Canvas open_file {} {$::main open_file} def Canvas send_message {} {$::main send_message} def Client test_audio_and_midi {} {menu_doc_open doc/7.stuff/tools testtone.pd } def Client load_meter {} {menu_doc_open doc/7.stuff/tools load-meter.pd} def Client latency_meter {} {menu_doc_open doc/7.stuff/tools latency.pd } def Client about {} {AboutDialogue new} def Client class_browser {} {Browser new_as browser browser 0 0 ""} def Client audio_on {} {netsend [list pd dsp 1]} def Client audio_off {} {netsend [list pd dsp 0]} def Client keyboard_view {} { KeyboardDialogue new $::event_history} def Client clipboard_view {} { ClipboardDialogue new $::clipboard} def Client command_history_view {} { ListDialogue new $::command_history [say command_history_view]} def Client event_history_view {} {EventHistoryDialogue new $::event_history} def Client do_what_i_mean {} {wonder} set pd_prefix [file dirname [file dirname [which pd]]] set pd_guidir ${pd_prefix}/lib/pd set doc_number 1 set updir [file dirname [file dirname $argh0]] if {[file exists $updir/lib/pd/doc]} { set docdir $updir/lib/pd/doc } else { set docdir $updir/doc } proc menu_opentext {filename} { set w [format ".help%d" $::doc_number] toplevel $w wm title $w $filename frame $w.1 frame $w.2 pack [text $w.1.text -relief raised -bd 2 -yscrollcommand "$w.1.scroll set"] -side left -fill both -expand 1 pack [scrollbar $w.1.scroll -command "$w.1.text yview"] -side right -fill y pack [button $w.2.close -text [say close] -command "destroy $w"] -side right pack $w.2 -side bottom -fill x -expand 0 pack $w.1 -side bottom -fill both -expand 1 set f [open $filename] while {![eof $f]} { set bigstring [read $f 1000] regsub -all PD_BASEDIR $bigstring $::pd_guidir bigstring regsub -all PD_VERSION $bigstring $::pd_version bigstring $w.1.text insert end $bigstring } $w.1.text configure -state disabled close $f incr ::doc_number return $w } proc menu_doc_open {subdir basename} { set dirname $::pd_guidir/$subdir if {[string first .txt $basename] >= 0} { return [menu_opentext $dirname/$basename] } else { netsend [list pd open $basename $dirname] } } #-----------------------------------------------------------------------------------# def Canvas editmode {} {return $@editmode} def Canvas editmode= {mode} { if {$mode == $@editmode} {return} if {!$mode} {$self deselect_all} $self redraw ;# why this??? set @editmode $mode; $self changed editmode # catch {.$self.bbar.edit configure -image icon_mode_$mode} if {$@mapped} { if {$mode} {set im icon_mode_edit} else {set im icon_mode_run} [$self window].bbar.edit configure -image $im if {[$self look hairstate] && !$@editmode} {$@crosshair erase} if {[$self look gridstate]} { if {$@editmode} {$@grid draw} else {$@grid erase} } } # comment's look depends on the value of @editmode foreach child [$@objects values] {if {[[$child class] <= Comment]} {$child changed}} #!@#$ should update the checkbox in the editmenu } def Canvas editmodeswitch {} {$self editmode= [expr !$@editmode]} def Canvas window {} { #if {$@gop && $@canvas != ""} {return [$@canvas window]} return .$self } def Canvas widget {} {return .$self.c} def View cwidget {} {return .[$self get_canvas].c} #-----------------------------------------------------------------------------------# def Canvas atomically {proc} {$@history atomically $proc} def Canvas undo {} {$@history undo} def Canvas redo {} {$@history redo} def Canvas init {mess} { set @mapped 0 set @gop 0 set @goprect "" set @abs 0 set @name "" set @folder "???" set @file "" super {#X obj 666 666 pd} ;# bogus $self reinit $mess set @zoom 1.0 ;# must be a float, not int set @action none set @objects [Hash new]; set @objectsel [Selection new]; set @visibles {} set @wires [Hash new]; set @wiresel [Selection new] set @focus "" set @curpos {30 30} set @bbox {0 0 100 100} set @dehighlight {} # if {$@mapped} {$self init_window} ;#!@#$ @mapped can't possibly be 1 at this point set @history $::command_history $self subscribe $::manager $self changed #$self canvas= $self ;#!@#$ EEVIL set @coords 0 set @jump 0 set @keynav_iocount 0 ;# the io select count set @keynav_port 0 ;# which in/outlet is selected set @keynav 0 ;# the list of objects that has io selected set @keynav_iosel 0 ;# last object that is io selected set @keynav_iosel_o {} ;# list of objects that has outlet selected set @keynav_iosel_i {} ;# list of objects that has inlet selected set @iosel_deselect 0 ;# if selected should be deselected by clicking at empty space set @keynav_current 0 set @keynav_last_obj 0 set @keynav_last_wire 0 set @keynav_tab_sel "wire" set @keynav_shift 0 set @copy_count 0 set @findbar "" set @find_string "" set @iohilite {-1 0 0 0 0} set @keyprefix 0 set @coords {0 0 1 1} ;# default #X coords line set @pixsize {0 0} set @margin {0 0} set @macro_q {} set @macro_delay 200 set @blinky "" set @editmode 0 set @show_id 0 set @motion_queue {} } def Canvas reinit {mess} { switch -- [lindex $mess 0] { "#N" { # those four are not to be confused with other @variables of similar names. set @canvas_pos [lrange $mess 2 3] set @canvas_size [lrange $mess 4 5] set args [lrange $mess 6 end] switch [llength $args] { 1 { set @subpatch 0 mset [list @fontsize] $args set @name "" set @mapped 1 } 2 { set @subpatch 1 mset [list @name @mapped] $args set @fontsize "what?" } default {error "wrong number of arguments (expecting 5 or 6, got [expr 4+[llength $args]])"} } } "#X" { switch -- [lindex $mess 1] { obj {} restore { set @x1 [lindex $mess 2] set @y1 [lindex $mess 3] set args [lrange $mess 4 end] $self text= [lrange $mess 4 end] if {!$@subpatch && [llength $args] != 0} {set @abs 1} if {$@mapped && !$@gop} { #if {!$@subpatch && $@text != ""} {set @abs 1; return} #if {![winfo exists .$self.c]} {$self init_window} } } coords { set @coords [lrange $mess 2 5] set @pixsize [lrange $mess 6 7] switch [llength $mess] { 8 {set @gop 0} 9 {set @gop [lindex $mess 8]} 11 { set @gop [lindex $mess 8] set @margin [lrange $mess 9 10] } default {error "what???"} } if {$@gop} {set @mapped 1} } } } "" {return} default {error "huh? mess=$mess"} } } # doesn't this look like Canvas deconstruct ? def Canvas get_mess {} { return [concat $@coords $@pixsize $@margin] } def Canvas margin {} {return $@margin} def Canvas gop {} {return $@gop} def Canvas hidtext {} {return $@hidetext} def Canvas abs {} {return $@abs} #def Canvas abs {} {if {!$@subpatch} {return 1} else {return 0}} def Canvas subpatch {} {return $@subpatch} def Canvas get_dimen {} {return $@canvas_size} def Canvas gop_rect {} { mset {pxs pys} $@pixsize mset {mx my} $@margin set rect [list $mx $my [expr $mx+$pxs] [expr $my+$pys]] if {$@goprect == ""} { set @goprect [GopRect new $self $rect] } elseif {!$@editmode} {$@goprect delete; set @goprect ""; return} $@goprect draw } rename toplevel toplevel_orig proc toplevel {name args} { eval [concat [list toplevel_orig $name] $args] catch {wm iconphoto $name icon_pd_32} } # should be called once and only from init def Canvas init_window {} { lappend ::window_list $self set win .$self set c [$self widget] if {$::tcl_platform(platform) == "macintosh"} { toplevel $win -menu $win.m } else { if {[$self look menubar]} {toplevel $win -menu $win.m} else {toplevel $win -menu ""} } set @menubar $win.m $self init_menus # turn buttonbar on/off set @buttonbar [ButtonBar new $self] if {[$self look buttonbar]} {pack [$@buttonbar widget] -side top -fill x -expand no} set @statusbar [StatusBar new $self] # turn statusbar on/off if {[$self look statusbar]} {pack [$@statusbar widget] -side bottom -fill x} set w [expr [lindex $@canvas_size 0]-4];# dd canvas is 4 pixel out with pd canvas? set h [expr [lindex $@canvas_size 1]-4] pack [canvas $c -width $w -height $h -background white] -side left -expand 1 -fill both set @yscroll $win.yscroll; set @xscroll $win.xscroll $self init_scrollbars wm minsize $win 1 1 wm geometry $win +[lindex $@canvas_pos 0]+[lindex $@canvas_pos 1] wm protocol $win WM_DELETE_WINDOW "$self close" focus $c $self new_binds $self update_title $self motion_update set @runcommand [Runcommand new .$self "command" canvas_eval] set @crosshair [Crosshair new $self] set @active [Active new $self] set @sense [Sense new $self] set @grid [Grid new $self] } def Canvas activate_menubar= {val} {if {$val} {.$self configure -menu $@menubar} {.$self configure -menu ""}} def Canvas activate_buttonbar= {val} { if {$val} { pack [$@buttonbar widget] -side top -fill x -expand no -before [$self widget] } else {pack forget [$@buttonbar widget]} } def Canvas activate_statusbar= {val} { if {$val} { if {[winfo exists $@yscroll]} {set w .$self.yscroll} else {set w .$self.c} pack [$@statusbar widget] -side bottom -fill x -before $w } else {pack forget [$@statusbar widget]} } def Canvas activate_scrollbars= {val} {if {!$val} {$self init_scrollbars} {$self remove_scrollbars}} def Canvas activate_grid= {val} {if {$val} {$@grid draw} {$@grid erase}} def Canvas init_scrollbars {} { set win .$self set c [$self widget] if {[winfo exists $win.yscroll]} {return} set size [$c bbox foo] mset {xs ys} $@canvas_size pack [scrollbar $win.yscroll -command "$c yview" ] -side right -fill y -before $c pack [scrollbar $win.xscroll -command "$c xview" -orient horizontal] -side bottom -fill x -before $c set xw $win.xscroll; set yw $win.yscroll $c configure -yscrollcommand "$self scroll_set $yw" -xscrollcommand "$self scroll_set $xw" after 0 [list $self adjust_scrollbars] } def Canvas remove_scrollbars {} { set win .$self set c [$self widget] if {![winfo exists $win.yscroll]} {return} #use destroy instead of pack forget so that it can be tested with winfo exists destroy $win.yscroll destroy $win.xscroll $c configure -yscrollcommand "" -xscrollcommand "" -scrollregion "" } def Canvas adjust_scrollbars {} { set c [$self widget] set size [$c bbox foo] if {[$self look scrollbar]} {$self auto_scrollbars} if {$size != ""} { mset {xmin ymin xmax ymax} {0 0 100 100} mset {x1 y1 x2 y2} $size if {$x2 > 100} {set xmax $x2} if {$y2 > 100} {set ymax $y2} set bbox [list $xmin $ymin $xmax $ymax] set oldbbox [$c cget -scrollregion] # it is very inefficient to call "configure" here if {"$oldbbox" != "$bbox"} {$c configure -scrollregion $bbox} set @bbox $bbox } } def Canvas auto_scrollbars {} { set c [$self widget] if {[$c bbox foo] != ""} { mset {cx1 cy1 cx2 cy2} [$c bbox foo] } else { set cx2 [lindex $@canvas_size 0]; set cy2 [lindex $@canvas_size 1] } set x2 [$c canvasx [winfo width $c]] set y2 [$c canvasy [winfo height $c]] if {$x2 == 1} {set x2 $cx2; set y2 $cy2} if {$cx2 <= $x2 && $cy2 <= $y2} {$self remove_scrollbars} {$self init_scrollbars} } def Canvas delete_window {} { set wl {} foreach w $::window_list {if {$w != $self} {lappend wl $w}} set ::window_list $wl destroy .$self } def Canvas delete {} { $self delete_window super } def Canvas focus {} {return $@focus} def Canvas focus= {o} {set @focus $o} def Canvas history {} {return $@history} #-----------------------------------------------------------------------------------# def Canvas find {} { if {[info exists ::_(findmodel:_class)]} { focus .$self.find.find findmodel reinit } else { FindModel new_as findmodel $self FindView new $self focus .$self.find.find } } def Canvas find_again {} { if {[info exists ::_(findmodel:_class)]} {findmodel remove_info;findmodel search_recursive} } def Canvas find_last_error {} {netsend [list pd finderror]} def Canvas bind {eventtype selector args} { set c [$self widget] #bind $c $eventtype [concat [list $self $selector] $args \; $self statusbar_draw %x %y] #bind $c $eventtype "puts \[time {[concat [list $self $selector] $args \; $self statusbar_draw %x %y]}\]" #bind $c $eventtype "puts \[time {[concat [list $self $selector] $args]}\]" if {[$self look statusbar]} { bind $c $eventtype [concat [list $self $selector] $args \; $self statusbar_draw %x %y] } else { bind $c $eventtype [concat [list $self $selector] $args] } } def Canvas new_binds {} { # mouse buttons $self bind <Button> click_wrap %x %y %b 0 $self bind <Shift-Button> click_wrap %x %y %b 1 $self bind <Control-Button> click_wrap %x %y %b 2 $self bind <Control-Shift-Button> click_wrap %x %y %b 3 $self bind <Alt-Button> click_wrap %x %y %b 4 $self bind <Alt-Shift-Button> click_wrap %x %y %b 5 $self bind <Alt-Control-Button> click_wrap %x %y %b 6 $self bind <Alt-Control-Shift-Button> click_wrap %x %y %b 7 switch $::OS { osx { $self bind <Button-2> click_wrap %x %y %b 8 $self bind <Control-Button> click_wrap %x %y 3 8 } default { $self bind <Button-3> click_wrap %x %y %b 8 } } switch $::OS { unix { $self bind <Button-4> scroll y -1 $self bind <Button-5> scroll y +1 $self bind <Shift-Button-4> scroll x -1 $self bind <Shift-Button-5> scroll x +1 } default { $self bind <MouseWheel> scroll y %D $self bind <Shift-MouseWheel> scroll x %D }} $self bind <ButtonRelease> unclick_wrap %x %y %b 0 $self bind <Shift-ButtonRelease> unclick_wrap %x %y %b 1 # keyboard $self bind <Control-Key> ctrlkey %x %y %K %A 0 $self bind <Control-Shift-Key> ctrlkey %x %y %K %A 1 $self bind <Alt-Key> altkey %x %y %K %A 0 $self bind <Alt-Shift-Key> altkey %x %y %K %A 1 switch $::OS { unix { $self bind <Mod1-Key> altkey %x %y %K %A 0 $self bind <Mod1-Shift-Key> altkey %x %y %K %A 1 $self bind <Mod4-Key> altkey %x %y %K %A 0 $self bind <Mod4-Shift-Key> altkey %x %y %K %A 1 } osx { $self bind <Mod1-Key> ctrlkey %x %y %K %A 0 $self bind <Mod1-Shift-Key> ctrlkey %x %y %K %A 1 } } $self bind <Key> key_wrap %x %y %K %A 0 $self bind <Shift-Key> key_wrap %x %y %K %A 1 $self bind <KeyRelease> keyup_wrap %x %y %K %A 0 $self bind <Shift-KeyRelease> keyup_wrap %x %y %K %A 1 $self bind <Control-KeyRelease> keyup_wrap %x %y %K %A 0 $self bind <Motion> motion_wrap %x %y 0 $self bind <Alt-Motion> motion_wrap %x %y 4 $self bind <Control-Motion> motion_wrap %x %y 9 #$self bind <Map> map #$self bind <Unmap> unmap $self bind <Leave> leave $self bind <Configure> configure %h %w } def Canvas configure {h w} { if {[$self look gridstate]} { $@grid update $h $w if {[winfo exists .$self.yscroll]} {return}; # scrollbar will update grid already $@grid draw } } #def Canvas map {} {} #def Canvas unmap {} {} def Canvas leave {} {$@crosshair erase} def Canvas scroll {axis diff} { set c [$self widget] $c [list $axis]view scroll $diff units if {[$self look hairstate] && $@editmode} { # this should be changed so that we don't need to recompute x,y here. set x [expr [$c canvasx [expr [winfo pointerx $c] - [winfo rootx $c]]]/$@zoom] set y [expr [$c canvasy [expr [winfo pointery $c] - [winfo rooty $c]]]/$@zoom] set target [$self identify_target $x $y 0] $@crosshair data= $x $y $target $@crosshair draw } else { $@crosshair erase } } # this allows the grid to update when scroll def Canvas scroll_set {w v1 v2} {if {[$self look gridstate] && $@editmode} {$@grid draw}; $w set $v1 $v2} def Canvas reload {} {netsend [list .$self reupload]} def Canvas redraw {} { $self changed foreach x [$@objects values] {$x changed} foreach x [ $@wires values] {$x changed} } #patch editing commandline shortcuts def Canvas o {x y {name ""}} { set c [$self widget] if {[$self snap_grid]} {set off [expr [$self look grid_size]/2]} {set off 0} set @curpos [list [expr [$c canvasx $x]+$off] [expr [$c canvasy $y]+$off]] $self new_object obj $name } def Canvas c {from outlet to inlet} { set out_objs [$self parse_idx $from] set in_objs [$self parse_idx $to] foreach out $out_objs { foreach in $in_objs { $self connect [list $out $outlet $in $inlet] } } } def Canvas pc {from outlet to inlet} { set out_objs [$self parse_idx $from] set in_objs [$self parse_idx $to] if {[llength $out_objs] != [llength $in_objs]} {return "No can do :("} for {set i 0} {$i < [llength $out_objs]} {incr i} { $self connect [list [lindex $out_objs $i] $outlet [lindex $in_objs $i] $inlet] } } def Canvas s {selection} { set objs [$self parse_idx $selection] foreach obj $objs {$self selection+= [$@objects get $obj]} } def Canvas s+ {selection} { set objs [$self parse_idx $selection]; set ids {} foreach obj $objs { set v [$@objects get $obj]; lappend ids $v $self selection+= $v } $self selection_wire= [$self implicit_wires $ids] } def Canvas sw {from outlet to inlet} { set out_objs [$self parse_idx $from] set in_objs [$self parse_idx $to] foreach out $out_objs { foreach in $in_objs { set id [$self wire_idx [list $out $outlet $in $inlet]] if {$id>=0} {$self selection_wire+= [$@wires get $id]} } } } def Canvas parse_idx {val} { set objs {} foreach obj [split $val ","] { if {[regexp {\d+-\d+} $obj range]} { set l [split $range "-"] set objs [concat $objs [lmake [lindex $l 0] [lindex $l 1]]] continue } lappend objs $obj } return $objs } def Canvas xy_snap {x y} { if {[$self look snap_grid]} { set grid [$self look grid_size] set x [expr floor($x/$grid)*$grid] set y [expr floor($y/$grid)*$grid] } return [list $x $y] } def Canvas new_object {sel args} { $self editmode= 1 $self deselect_all mset {x y} $@curpos if {[$self look snap_grid]} { set grid [$self look grid_size] set x [expr floor($x/$grid)*$grid] set y [expr floor($y/$grid)*$grid] } switch -- $sel { obj { set goto [list $self new_object_edit]} msg { set goto [list $self new_object_edit]} text { set goto [list $self new_object_edit]} default {set goto [list $self new_object_callback]} } netsend [concat [list .$self $sel $x $y] $args] $goto } def Canvas new_wire_callback {wire} {} def Canvas new_object_callback {obj} { $self add_to_obj_history $obj set @keynav_last_obj $obj $self selection+= $obj if {$@keynav} {$self update_Active $obj} } def Canvas new_object_copyselect {obj} { $self selection+= $obj #set @action "move" #$self click_on_object $obj 0 } def Canvas new_wire_select {wire} {$self selection_wire+= $wire} def Canvas new_object_edit {obj} { if {[$obj class] == "NumBox"} {return} $obj edit } def Canvas add_to_obj_history {obj} { if {![[$obj class] <= ObjectBox]} {return} obj_hist prepend [$obj text] } def Canvas insertxy {} {return [list $@insert_x $@insert_y]} def Canvas insert_object {} {$self do_insert_obj "none" "none"} def Canvas get_canvas {} { if {![info exists @gop]} { if {[info exists @subpatch]} {if {$@subpatch} {return [$self canvas]}} if {[info exists @abs]} {if {$@abs} {return [$self canvas]}} if {[winfo exists .$self.c]} {return $self} } #if {[info exists @subpatch]} {if {$@subpatch} {return [$self canvas]}} return [super] } def Canvas get_topcanvas {} { set canvas $@canvas if {$@canvas == ""} {return $self} while {[$canvas canvas] != ""} {set canvas [$canvas canvas]} return $canvas } def Canvas do_insert_obj {x y} { if {$x == "none" && $y == "none"} { if {[$@wiresel size] != 1} {return} set wire [$@wiresel values] puts "insert object for wire $wire" mset {from outlet to inlet} [$wire report] set c [$self widget] set iowidth [$self look iowidth] mset {ox1 oy1 ox2 oy2} [lmap / [$c bbox ${from}o${outlet}] [$self zoom]] mset {ix1 iy1 ix2 iy2} [lmap / [$c bbox ${to}i${inlet} ] [$self zoom]] set x1 [expr $ox1 + $iowidth/2]; set y1 [expr ($oy1+$oy2)/2] set x2 [expr $ix1 + $iowidth/2]; set y2 [expr ($iy1+$iy2)/2] set x [expr $x1 + ($x2-$x1)/2] set y [expr $y1 + ($y2-$y1)/2] } netsend [list .$self obj $x $y] [list $self new_object_edit] set @action insert } def Canvas new_object_insert_wire {obj} { set wire [$self selection_wire] $self selection_wire-= $wire mset {from outlet to inlet} [$wire report] $self disconnect [$wire connects] set @keynav 0; $@active hide; set @keynav_tab_sel "object" set from_idx [$@objects search $from] set to_idx [$@objects search $to] set obj3_idx [$@objects search $obj] $self connect [list $from_idx $outlet $obj3_idx 0] [list $self keynav_current=] $self connect [list $obj3_idx 0 $to_idx $inlet] $self action= none } def Canvas chain_object {} { if {[$@objectsel size] != 1} {return} set o [$@objectsel values] mset {x1 y1 x2 y2} [$o bbox] set grid [$self look grid_size] if {[$self look snap_grid]} {set y [expr floor(($y2+$grid)/$grid)*$grid]} {set y [expr $y2+10]} netsend [list .$self obj $x1 $y] [list $self new_object_edit] set @action chain_obj } def Canvas new_object_chain_wire {obj} { obj_hist prepend [$obj text] set from_idx [$@objects search [lindex [$self selection] 0]] $self deselect_all set to_idx [$@objects search $obj] $self connect [list $from_idx 0 $to_idx 0] $self action= none $self selection= $obj } def Canvas objects {} {return $@objects} #def Canvas wires {} {return $@wires} def Canvas selection {} {$@objectsel values} def Canvas selection= {objs} {$@objectsel clear; $self selection+= $objs} def Canvas selection+= {objs} {foreach obj $objs {$@objectsel set [$obj index] $obj}} def Canvas selection-= {objs} {foreach obj $objs {set k [$obj index]; if {[$@objectsel exists $k]} {$@objectsel unset $k}}} def Canvas selection_wire {} {$@wiresel values} def Canvas selection_wire= {objs} {$@wiresel clear; $self selection_wire+= $objs} def Canvas selection_wire+= {objs} {foreach obj $objs {$@wiresel set [$obj index] $obj}} def Canvas selection_wire-= {objs} {foreach obj $objs {set k [$obj index]; if {[ $@wiresel exists $k]} { $@wiresel unset $k}}} def Canvas Object {} {$self new_object obj} def Canvas Message {} {$self new_object msg} def Canvas Number {} {$self new_object floatatom} def Canvas Symbol {} {$self new_object symbolatom} def Canvas Comment {} {$self new_object text} #!@#$ these 9 should be harmonised with the class list instead of having special names def Canvas bng {} {$self new_object obj bng} def Canvas tgl {} {$self new_object obj tgl} def Canvas nbx {} {$self new_object obj nbx} def Canvas vsl {} {$self new_object obj vsl} def Canvas hsl {} {$self new_object obj hsl} def Canvas vradio {} {$self new_object obj vradio} def Canvas hradio {} {$self new_object obj hradio} def Canvas vu {} {$self new_object obj vu} def Canvas cnv {} {$self new_object obj cnv} def Canvas Graph {} {$self editmode= 1; netsend [list .x$self graph ]} def Canvas Array {} {$self editmode= 1; netsend [list .x$self menuarray]} def Canvas init_menus {} { set name .$self set m $name.m menu $m #removed Paths after send_message foreach x {file edit find view put window help} {menu $m.$x -tearoff $::pd_tearoff} $self populate_menu file {new_file open_file {} send_message {} close save save_as print {} abort_server quit} $self populate_menu edit {undo redo {} cut copy paste duplicate select_all subpatcherize {} tidy_up {}} $self populate_menu find {find find_again find_last_error} #!@#$ those shortcuts should be looked up in the key table!!! $m.view add checkbutton -label [say visual_diff] -selectcolor grey0 -command [list $self visual_diff] \ -accelerator [accel_munge "Ctrl+E"] -indicatoron 1 $self populate_menu view {get_elapsed {} reload redraw} $self populate_menu put {Object Message Number Symbol Comment {} bng tgl nbx vsl hsl vradio hradio vu cnv {} Graph Array} $self populate_menu window {{}} $m.edit add checkbutton -label [say edit_mode] -selectcolor grey0 -command [list $self editmodeswitch] \ -accelerator [accel_munge "Ctrl+e"] -indicatoron 1 $m.edit configure -postcommand "$self fix_edit_menu" $m.window configure -postcommand "$self fix_window_menu" foreach x {file edit view find put window help} { if {$x=="help"} { # help menu is in the wrong place in patch windows because it's taken from .mbar ??? $m add cascade -label [say $x] -menu .mbar.$x } { $m add cascade -label [say $x] -menu $m.$x } } } # corrects edit menu, enabling or disabling undo/redo # LATER also cut/copy/paste def Canvas fix_edit_menu {} { set e .$self.m.edit switch $::OS {osx {set i 0} default {set i 1}} set t [say undo] if {[$@history can_undo?]} { $e entryconfigure $i -state normal -label "$t [$@history next_undo_name]" } else { $e entryconfigure $i -state disabled -label "[say cannot] $t" } incr i set t [say redo] if {[$@history can_redo?]} { $e entryconfigure $i -state normal -label "$t [$@history next_redo_name]" } else { $e entryconfigure $i -state disabled -label "[say cannot] $t" } } def Menuable fix_window_menu {} { set menu $@menubar.window $menu delete 0 end foreach w $::window_list {$menu add command -label [wm title [$w window]] -command "$w raise"} # {"parentwindow" {menu_windowparent} ""} } #-----------------------------------------------------------------------------------# #this just tells whether an object is part of the selection, that is, what usually makes objects turn blue. def Canvas selection_include? {member} {expr [$@objectsel search $member]>=0} def Canvas type {} { if {$@subpatch && !$@gop} {return "sub"} if {$@subpatch && $@gop} {return "gopsub"} if {$@abs && !$@gop} {return "abs"} if {$@abs && $@gop} {return "gopabs"} if {!$@subpatch && !$@abs && !$@gop} {return "toplevel"} } def Canvas draw {} { if {$@gop} { if {[$self gop_check]} {$self all_changed} #if the focus is not in the opened gop if {[regexp {^.x[0-9a-f]{6,8}.c} [focus] f]} { if {$@canvas != ""&& $f != [$self widget]} {super;return} } elseif {$@canvas != "" && [focus] != [$self widget]} {super;return} } elseif {$@subpatch || $@abs} {super} if {!$@mapped} {return} else {if {![winfo exists [$self widget]]} {return}} $self check_findbar if {$@editmode} {set bg [$self look bgedit]} else {set bg [$self look bgrun]} [$self widget] configure -background $bg $self adjust_scrollbars if {$@gop} {$self gop_rect} } def Canvas popup_properties {} {CanvasPropertiesDialogue new $self} def Canvas gop_target {id} { while {[$id canvas] != $self} {set id [$id canvas]}; return $id } #-----------------------------------------------------------------------------------# class_new MacroRect {View} def MacroRect init {} {super; $self data= 0 0 0 0 blue} def MacroRect data= {x1 y1 x2 y2 col} { set @x1 $x1; set @y1 $y1 set @x2 $x2; set @y2 $y2 set @col $col } def MacroRect flash {x1 y1 x2 y2 col} { $self data= $x1 $y1 $x2 $y2 $col $self draw after 500 $self erase } def MacroRect draw {} { set @canvas [string range [focus] 1 [string first . [focus] 1]-1] $self item MACRO rect [list $@x1 $@y1 $@x2 $@y2] -outline $@col } class_new Macro {EventHistory} def Macro init {} { $::event_history subscribe $self set @idx 0 set @state 0 set @list {} set @ref_list {} set @delay 200 set @offset_x 0 set @offset_y 0 set @rect [MacroRect new] } def Macro state= {val} { set @state $val if {$val} { set @ref_list {} set @list {} post %s "start recording macro..." } else { post %s "end..." } } def Macro state {} {return $@state} def Macro dump {} {set i 0; foreach step $@list {post %s "step $i -> $step"; incr i}} def Macro idx= {val} {set @idx $val} def Macro idx {} {return $@idx} def Macro delay {} {return $@delay} def Macro append_ref {mess} {lappend @ref_list $mess} def Macro ref_list {} {puts "$@ref_list";return $@ref_list} def Canvas ref_list {} {$::macro ref_list} def Macro notice {args} { if {$@state} { set mess [lindex $args 2] switch [lindex $args 1] { add {$self add $mess} default {} } } } def Macro add {mess} { mset {event widget x y mode k kval} $mess if {[regexp {^Control_} $k]} {return} if {[regexp {^Alt_} $k]} {return} if {[regexp {^Shift_} $k]} {return} if {$event == "KeyRelease"} {return} if {$event == "ButtonRelease"} {lappend @list [lreplace $mess 0 0 "Motion"]} if {$event == "KeyPress" } {lappend @list [lreplace $mess 0 0 "Motion"]} if {$event == "ButtonPress" } {lappend @list [lreplace $mess 0 0 "Motion"]} lappend @list $mess } def Macro test_playable {x y} { mset {macro_width macro_height} [$self calc_size] set c [string range [focus] 0 [string first . [focus] 1]+1] set cwidth [winfo width $c]; set cheight [winfo height $c] set cx1 [$c canvasx 0]; set cy1 [$c canvasy 0] set cx2 [$c canvasx $cwidth]; set cy2 [$c canvasy $cheight] set new_x [expr $x+$macro_width]; set new_y [expr $y+$macro_height] $@rect flash $x $y $new_x $new_y blue if {$new_x > $cx2 || $new_x < $cx1 || $new_y > $cy2 || $new_y < $cy1} { puts "Can't playback Macro:: outside of canvas area" return } else {$self idx= 0; $self offset $x $y; $self play [$self delay]} } def Macro offset {new_x new_y} { mset {event widget x y mode k kval} [lindex $@list 0] set @offset_x [expr $new_x-$x] set @offset_y [expr $new_y-$y] } def Macro play {delay} { if {$@idx == [llength $@list]} {return} #$self test_canvas_size set i 0 set focus [string range [focus] 1 [string first . [focus] 2]-1] set step [lindex $@list $@idx] #puts "\t $step" mset {event widget x y mode k kval} $step switch $event { #KeyRelease {set name [modekey $k $mode]} KeyPress {set name [modekey $k $mode]} ButtonPress {set name $event-$k} ButtonRelease {set name $event-$k} Motion {set name $event} default {puts "Error: event $event should not have been here.."} } if {$@idx < [llength $@list]} { #after $delay [list $self run $event $name $k [expr $X+$@offset_x] [expr $Y+$@offset_y] \ # [expr $x+$@offset_x] [expr $y+$@offset_y]] after $delay [list $self run $event $name $k $x $y] } } #this don't make sense when multiple window, and should be re implemeneted somehow def Macro calc_size {} { set x1 66666; set x2 0 set y1 66666; set y2 0 foreach step $@list { mset {event widget x y mode k kval} $step set x1 [min $X $x1]; set x2 [max $x2 $X] set y1 [min $Y $y1]; set y2 [max $y2 $Y] } return [list [expr $x2-$x1] [expr $y2-$y1]] } def Macro test_canvas_size {} { set c [string range [focus] 0 [string first . [focus] 1]+1] set cwidth [winfo width $c]; set cheight [winfo height $c] set cx1 [$c canvasx 0]; set cy1 [$c canvasy 0] set cx2 [$c canvasx $cwidth]; set cy2 [$c canvasy $cheight] mset {x1 y1 x2 y2} [$self calc_size] } def Macro run {event name k x y} { set w [focus] incr @idx event generate $w <$name> -x $x -y $y if {$event=="KeyPress"} {event generate $w <KeyRelease-$k> -x $x -y $y} $self play $@delay } def Macro copy {} { clipboard clear selection clear set i 0 foreach step $@list { if {$i == [expr [llength $@list]-1]} {set comma ""} else {set comma ","} mset {event widget x y mode k kval} $step set mess [list $event $x $y $mode $k] set t ${mess}$comma switch $event { KeyPress {clipboard append [lreplace $t 0 0 "key"]} ButtonPress {clipboard append [lreplace $t 0 0 "click"]} ButtonRelease {clipboard append [lreplace $t 0 0 "unclick"]} } incr i } selection handle -selection PRIMARY [focus] "$self getdata" selection own -command lost -selection PRIMARY } def Macro getdata {offset maxchar} { puts "clipboard ::: [clipboard get]" return [string range [format %s [clipboard get]] $offset [expr {$offset+$maxChars}]] } def Macro reset {} {set @idx 0} set ::macro [Macro new] set ::macro_state 0 def Canvas macro_toggle {} {if {![$::macro state]} {set ::macro_state 1} {$::macro state= 0; $::macro dump}} #def Canvas macro_play {} {puts ">> $@click_at <<"; $::macro idx= 0; $::macro play [$::macro delay]} def Canvas macro_play {} { mset {x y} $@click_at $::macro reset $::macro play [$::macro delay] #$::macro test_playable $x $y } def Canvas keyevent {} { focus [$self widget] event generate [$self widget] <Control-Key-1> } def Canvas macro_copy {} {$::macro copy} #-----------------------------------------------------------------------------------# class_new TextBox {Box} def TextBox init {mess} { super $mess set @edit 0 set @x1 [lindex $mess 2] set @y1 [lindex $mess 3] set @text [$self remove_braces [join [lrange $mess 4 end]]] set @multi 0 set @max_width 40 # @textoffset is for offseting the text item/widget, ie, ObjectBox vs NumBox switch [$self class] { NumBox {set @textoffset [list 10 2]} default {set @textoffset [list 2 2]} } } def TextBox text= {text} {set @text [$self remove_braces [join $text]]} def TextBox text {} {return $@text} def TextBox filter_text {{for_edit 0}} {return $@text} def TextBox draw {} { if {[$self class] == "Canvas"} {if {$@text == "graph"} {$self update_size; super; return}} # "TEXT" is the text label while "text" is the the input text field tk widget. # the text should be drawn before, so that update_size works at the right time. mset {x1 y1} [$self xy] set z [$@canvas zoom] if {$@edit} { $self draw_edit } else { set fw [font measure [$self look font] 0] set text [$self filter_text] if {$::leet} {set text [string map -nocase {a 4 e 3 t 7 s 5 i 1 o 0 g 9} $text]} $self item TEXT text [l+ $@textoffset [$self xy]] \ -font [$self look font] -text $text \ -fill [$self look fg] -anchor nw -width [expr ($fw*$@max_width)-1] # set width with -1 because text item seem to be inclusive at wrap point # where as the text widget is exclusive } $self update_size super } def TextBox edit {} { if {$@edit} {return}; set @edit 1; $self changed edit if {[[$self class] <= AtomBox]} {set @clear 1} } def TextBox new_bind {} { set t [$self cwidget].${self}text bind $t <Key> "$self key_input %W %x %y %K %A 0" bind $t <Control-Return> "$self key_input %W %x %y 10 %A 0" bind $t <Control-v> "$self paste_resize" bind $t <Return> "$self unedit" bind $t <Escape> "$self unedit 0" bind $t <Up> "$self scroll_history +1" bind $t <Down> "$self scroll_history -1" bind $t <Control-p> "$self scroll_history +1" bind $t <Control-n> "$self scroll_history -1" bind $t <Alt-BackSpace> "$self clear" } def TextBox draw_edit {} { set c [$self cwidget] switch $::tcl_platform(os) { Linux {$c configure -cursor crosshair} #need to find equivalent names for other os } if {[lsearch [$@canvas selection] $self] < 0} {$@canvas selection+= $self} set t $c.${self}text if {[winfo exists $t]} {return} set @edit 1 set @tab_repeats 0 obj_hist histi= 0 set @selected? 1 set z [$@canvas zoom] set font_height [font metrics [$self look font] -linespace] if {[$c bbox ${self}TEXT] != ""} { mset {ix1 iy1 ix2 iy2} [lmap / [$c bbox ${self}TEXT] $z] if {($iy2-$iy1)/$z > $font_height} {set @multi 1} } else { set ix1 0; set iy1 0 set ix2 [font measure [$self look font] 0] set iy2 [font metrics [$self look font] -linespace] } $c delete ${self}TEXT set font_str [$self look font] set new_size [format %.0f [expr [lindex $font_str 1]*$z]] set font_str [lreplace $font_str 1 1 $new_size] foreach char [split $@text ""] {lappend l [scan $char %c]} mset {width height} [$self get_size [expr $ix2-$ix1] [expr $iy2-$iy1]] set insertbg [$self look fg]; set fg [$self look fg] if {[[$self class] <= AtomBox]} {set fg "red"; set insertbg [$self look bgedit]} text $t -width $width -height $height -relief flat -bg [$self look bgedit] -borderwidth 0 \ -highlightthickness 0 -font $font_str -fg $fg -insertbackground $insertbg -wrap word $self new_bind $@canvas focus= $self $self item text window [l+ [lmap / $@textoffset $z] [$self xy]] -window $t -anchor nw -tags "${self}text $self text" $t insert 1.0 $@text $t configure -pady 0 -padx 0 # dnd bindtarget $c.${self}text text/uri-list <Drop> {} # tkdnd::drop_target register $c.${self}text #set w .[$self get_canvas] #tkdnd::drop_target register $w * #bind $w <<Drop>> {post %s "Drop %e %W %X %Y %ST %TT %a %A %CST %CTT %t %T %b %D"} #bind $w <<Drop:DND_Files>> {post %s "Drop:DND_Files %e %W %X %Y %ST %TT %a %A %CST %CTT %t %T %b %D"} #bind $w <<DropEnter>> {post %s "DropEnter %e %W %X %Y %ST %TT %a %A %CST %CTT %t %T %b %D"} #bind $w <<DropPosition>> {post %s "DropPosition %e %W %X %Y %ST %TT %a %A %CST %CTT %t %T %b %D"} #bind $w <<DropLeave>> {post %s "DropLeave %e %W %X %Y %ST %TT %a %A %CST %CTT %t %T %b %D"} # "pd \"x[list ${self}] symbol \[ enquote %D \] ;\"" $self resize focus $t } def TextBox resize {} { if {[[$self class] <= AtomBox]} {return} set c [$self cwidget] set t $c.${self}text #set z [$@canvas zoom] set pix_height [$t count -update -ypixels 1.0 end] set pix_width [font measure [$self look font] [$t get 1.0 end]] mset {width height} [$self get_size $pix_width $pix_height] $t configure -width [min $width $@max_width] -height $height -wrap word } def TextBox get_size {w h} { set c [$self cwidget] set t $c.${self}text set pix_height $h set pix_width $w set char_width [font measure [$self look font] 0] set line_height [font metrics [$self look font] -linespace] set round_chars [expr int(ceil($pix_width/$char_width.0))] if {$round_chars < $@max_width && !$@multi} { set round_lines 1 } else { set @multi 1 set round_chars $@max_width set round_lines [expr int(ceil($pix_height/$line_height))] } return [list $round_chars $round_lines] } def TextBox key_input {widget x y key iso shift} { after 0 "$self after_key $widget" set c [$@canvas widget] set t $c.${self}text if {[[$self class] <= AtomBox]} {if {$@clear} {$t delete 1.0 1.end; set @clear 0}} switch -- $key { Tab { if {[$self class] == "ObjectBox"} { $self propose_completions; $widget configure -state disabled } } 10 {$t configure -height [expr [lindex [$t configure -height] 4] + 1]} } } def TextBox after_key {widget} { $widget configure -state normal; # for in case there is completion box $self resize $self changed } def TextBox paste_resize {} { if {[[$self class] <= AtomBox]} {return} set c [$self cwidget] set t $c.${self}text set fixed [font metrics [$self look font] -fixed] set text [clipboard get] if {$fixed} { set width [string length $text] } else { set textpix [font measure [$self look font] $text] set fwidth [font measure [$self look font] 0] set width [expr (($textpix+$fwidth-1)/$fwidth)+1] } set maxwidth 40 mset {y1 y2} [$t yview] if {$width < $maxwidth} {set height 1} {set height [expr ceil($width/$maxwidth.0)]} $t configure -width [min $width $maxwidth] -height $height -wrap word after 0 [list $t mark set insert 1.end] $t mark set insert 1.0 $self update_size $self changed } def TextBox scroll_history {incr} { if {[[$self class] <= MessageBox]} {return} set c [$self cwidget] set t $c.${self}text if {![obj_hist histi]} {obj_hist set_hist 0 [$t get 1.0 1.end]} $t delete 1.0 1.end set text [obj_hist traverse $incr] $t insert 1.0 $text $t configure -width [string length $text] $self update_size after 0 $self changed } def TextBox clear {} { set c [$self cwidget] set t $c.${self}text $t delete 1.0 1.end } def TextBox text {} {return $@text} def TextBox update_size {} { if {[info exists @gop]} {if {$@gop} {mset [list @xs @ys] $@pixsize; return}} if {$@canvas == ""} {puts "update_size: this textbox has no canvas, try again later"; return} set c [$self cwidget] set t_widget $c.${self}text set t_item $c.${self}TEXT set w2 0; set h2 0 set xpad 2; set ypad 3 set z [$@canvas zoom] if {[winfo exists $t_widget]} { set textwidth [expr ([winfo reqwidth $t_widget]+$xpad)/$z] set height [expr ([winfo reqheight $t_widget]+$ypad)/$z] } else { mset {x1 y1 x2 y2} [[[$self canvas] widget] bbox ${self}TEXT] set textwidth [expr ($x2-$x1+$xpad)/$z] set height [expr ($y2-$y1+$ypad)/$z] } set iowidth [$self look iowidth] set topwidth [expr {(2* $@ninlets-1)*$iowidth}] set bottomwidth [expr {(2*$@noutlets-1)*$iowidth}] set @xs [max [$self look minobjwidth] [max $bottomwidth [max $topwidth $textwidth]]] set @ys $height } #----------------------------------------------------------------------------------- class_new ObjectBox {TextBox} def ObjectBox init {mess} { super $mess set @valid 0 ;# only ObjectBox needs a @valid. (removed all others) set @ninlets 0 set @noutlets 0 set @pdclass "" } def ObjectBox valid= {v} {set @valid $v} def ObjectBox valid {} {return $@valid} def Canvas objectsel {} {return $@objectsel} def Canvas wiresel {} {return $@wiresel} def ObjectBox draw_box {} { super set xya [$self bbox] mset {x1 y1 x2 y2} $xya # the 3d look could be done quicker using incr on x1 y1 x2 y2 like BlueBox does. #set xyb [l+ [list $x2 $y1 $x1 $y1 $x1 $y2] [list -1 +1 +1 +1 +1 -1]] #set xyc [l+ [list $x2 $y1 $x2 $y2 $x1 $y2] [list -1 +1 -1 -1 +1 -1]] if {[$self selected?]} {set fg [$self look selectframe]} {set fg [$self look frame3]} if {$@valid} { $self item BASE rectangle $xya -fill [$self look bg] -outline $fg -width 1 } else { $self item BASE rectangle $xya -fill [$self look bg] -outline $fg -width 1 -dash {3 3} } #$self item BASE1 line $xyb -fill [$self look frame1] -width 1 #$self item BASE2 line $xyc -fill [$self look frame2] -width 1 #[$@canvas widget] lower ${self}BASE ${self}TEXT [[$self get_canvas] widget] lower ${self}BASE ${self}TEXT #[[$self get_canvas] widget] lower ${self}BASE } def ObjectBox draw {} {super; $self draw_io} # this is called from the GUI; text= is reserved for server. def TextBox setto {text} { [$@canvas history] add [list $self setto $@text] [$@canvas widget] configure -cursor {} set @text $text set l {} foreach char [split $@text ""] {lappend l [scan $char %c]} $@canvas selection-= [list $self] switch [$@canvas action] { insert {set goto [list $@canvas new_object_insert_wire]} chain_obj {set goto [list $@canvas new_object_chain_wire]} subpatcherize {set goto [list $@canvas new_object_subpatcherize_redraw]} default {set goto [list $@canvas new_object_callback]} } netsend [concat [list .$@canvas text_setto $self] $l] $goto } def TextBox unedit {{accept 1}} { if {!$@edit} {return} set @edit 0 $self changed edit set c [[$self get_canvas] widget] set t $c.${self}text if {$accept} {$self setto [$t get 1.0 "end - 1 chars"]} after 1 "destroy $t" if {[winfo exists .completion]} {$@action cancel} focus $c $@canvas focus= "" } #-----------------------------------------------------------------------------------# def Canvas name {} {return $@name} def Canvas folder {} {return $@folder} def Canvas name= {name} {if {!$@mapped} {return}; set @name $name ; $self update_title} def Canvas folder= {folder} {if {!$@mapped} {return}; set @folder $folder; $self update_title} def Canvas make_title {} { if {!$@mapped} {return} if {$@subpatch} { if {$@canvas == "" || 0==[string compare $@canvas $self]} { set t "(uh)" } else { set t [$@canvas make_title] } set t "subpatch '$@name' of $t" } else { #set t "$@name in $@folder" set t "$@name" } if {[$self modified?]} {append t "(*)"} return $t } def Canvas update_title {} { if {[winfo exists .$self]} {wm title .$self [$self make_title]} } # UNIMPLEMENTED: this should indicate whether the patch in pd is different from the last saved patch def Canvas modified? {} {return 1} def Canvas mapped {} {return $@mapped} def Canvas mapped= {v} {set @mapped $v} def Canvas havewindow= {flag} { set was [winfo exists .$self] if {$flag && !$was} {$self init_window; $self redraw} #if {$flag && $was && [$self gop]} {$self redraw} if {$flag && $was} {$self raise} if {!$flag && $was} {$self delete_window} } def Canvas visibles+= {child} { if {[lsearch $@visibles $child] < 0} {lappend @visibles $child; $self changed visibles} } def Canvas visibles-= {child} { if {[lsearch $@visibles $child] >= 0} {set @visibles [lwithout $@visibles $child]; $self changed visibles} } def Canvas visibles {} {return $@visibles} def Canvas all_changed {} { foreach x $@visibles { if {[$x class] == "Canvas"} {if {$@gop} {$x all_changed}} $x changed } } # this is a shim between the client's new-style indices and the server's remaining old-style indices proc dex {h k} {lsearch [lsort -integer [$h keys]] $k} # for undo; calls the server def Canvas ins {i constructor} { set parts [pd_mess_split $constructor] set last [lindex $parts end] set parts [lrange $parts 0 end-1] foreach part $parts {netsend $part} netsend [concat [list .$self object_insert $i] $last] $@history add [list $self del $i] } def Canvas del {i} { set o [$@objects get $i] #this keynav should be better sorted out if {$o == $@keynav_current || $o == $@keynav_last_obj} { set @keynav_current 0 set @keynav_last_obj 0 } # this "if" might not be necessary... try deconstruct_to for everything. if {[$o class] != "Canvas"} { $@history add [list $self ins $i [$o deconstruct]] } else { set meuh [Clipboard2 new] $o deconstruct_to $meuh $@history add [list $self ins $i [$meuh value]] $meuh delete } netsend [list .$self object_delete $o] } def Canvas wires {} {return $@wires} def Canvas delete_selection {} { $@history atomically [list delete_selection] { if {![$@objectsel size] && ![$@wiresel size]} {return} #this keynav should be better sorted out if {$@keynav} { set @keynav 0 switch [$@keynav_current class] { Wire {set @keynav_last_wire 0} default {set @keynav_last_obj 0} } set @keynav_current 0 $@active hide } set del_wire {} foreach obj [$@objectsel values] { foreach wire [$obj wires2] { if {[$@wires search $wire] != -1 && [lsearch $del_wire $wire] < 0} { $self disconnect [$wire connects] lappend del_wire $wire } } $self del [$@objects search $obj] } foreach x [$@wiresel values] { if {[$@wires search $x] != -1 && [lsearch $del_wire $x] < 0} { $self disconnect [$x connects] } } $@objectsel clear $@wiresel clear } } def View position= {xy1} {mset [list @x1 @y1] $xy1; $self changed x1 y1} def View set_orig_xy {x y} {set @orig_x $x; set @orig_y $y} def Canvas motion_wrap {x y f} { set c [$self widget] set x [expr [$c canvasx $x]/$@zoom] set y [expr [$c canvasy $y]/$@zoom] lappend @motion_queue [list $x $y $f] #$self motion $x $y $f [$self identify_target $x $y $f] } def Canvas motion_update {} { if {[llength $@motion_queue]} { mset {x y f} [lindex $@motion_queue end]; set @motion_queue {} $self motion $x $y $f [$self identify_target $x $y $f] } set @motion_after_id [after 50 "$self motion_update"] } def Canvas click_wrap {x y b f} { set c [$self widget] set x [expr [$c canvasx $x]/$@zoom] set y [expr [$c canvasy $y]/$@zoom] set f [expr 1<<($b+7)|$f] $self click $x $y $f [$self identify_target $x $y $f] } def Canvas unclick_wrap {x y b f} { set c [$self widget] set x [expr [$c canvasx $x]/$@zoom] set y [expr [$c canvasy $y]/$@zoom] set f [expr 1<<($b+7)|$f] $self unclick $x $y $f [$self identify_target $x $y $f] } def Canvas key_wrap {x y key iso shift} { set c [$self widget] $self key [expr [$c canvasx $x]/$@zoom] [expr [$c canvasy $y]/$@zoom] $key $iso $shift } def Canvas keyup_wrap {x y key iso shift} { set c [$self widget] $self keyup [expr [$c canvasx $x]/$@zoom] [expr [$c canvasy $y]/$@zoom] $key $iso $shift } proc lsearch_minimum {l} { set i 0 set j 0 set min [lindex $l 0] foreach o $l { if {$o < $min} {set i $j; set min $o} incr j } return $i } def Canvas quadrant {du dv array} { if {$@keynav_current == 0} {set @keynav_current [$@objects get [lindex [$@objects keys] 0]]} set foo {} set bar {} set pos [$@keynav_current xy] foreach o $array { mset {x y} [l- $pos [$o xy]] set u [expr $x+$y] set v [expr $x-$y] if {$u*$du>0 && $v*$dv>0} {lappend foo $o; lappend bar [distance $pos [$o xy]]} } if {![llength $bar]} {return $@keynav_current} set best [lindex $foo [lsearch_minimum $bar]] return $best } def Canvas motion {x y f target} { #modes_callback $self "motion" $x $y $f $target set c [$self widget] $self motion_checkhairtip $target $x $y eval $@dehighlight set @dehighlight {} set oldpos $@curpos set @curpos [list $x $y] # detects if the focus is not on the canvas itself in run mode, ie. numbox if {!$@editmode & [$self focus] != $self & [$self focus] != ""} { [$self focus] motion $x $y $f $target } mset {type id detail} $target switch $@action { edit {$self motion_edit $x $y $f} insert {} chain_obj {} imove {$self motion_imove $oldpos $x $y; return} mouse_copy {$self motion_move $oldpos $x $y; return} move {$self motion_move $oldpos $x $y; return} none {} default {$@action motion $x $y $f $target} } if {$@editmode} {$self motion_iohilite2 $x $y $f} if {$id == ""} {return} } proc remainder {val val2} { if {[expr {abs($val)}]} {return [expr {(abs($val)%$val2)*($val/abs($val))}]} else {return 0} } def Canvas motion_move {oldpos x y} { mset {ox oy} $oldpos if {$@keynav} {$@active draw} foreach obj [$@objectsel values] { #if {[[$obj class] <= Box]} { if {[$self look snap_grid]} { set grid [$self look grid_size] set ax [expr {(int($x)/$grid)*$grid}] set ay [expr {(int($y)/$grid)*$grid}] set oax [expr {(int($ox)/$grid)*$grid}] set oay [expr {(int($oy)/$grid)*$grid}] mset {x1 y1} [$obj xy] if {![expr {($ax-$oax)%$grid}]} { set xoff [remainder [expr {int($x1-$ax)}] $grid] } else {set xoff 0} if {![expr {($ay-$oay)%$grid}]} { set yoff [remainder [expr {int($y1-$ay)}] $grid] } else {set yoff 0} $obj move [expr ($ax-$oax)-$xoff] [expr ($ay-$oay)-$yoff] } else { $obj move [expr {$x-$ox}] [expr {$y-$oy}] } #} else { # puts "Canvas motion warning: trying to move non-Box explicitly" #} } } def Canvas motion_imove {oldpos x y} { mset {ox oy} $oldpos if {$@keynav} {$@active draw} if {[$@objectsel size] == 1} { set obj [$@objectsel values] set in_objs $obj set out_objs $obj } else { if {![llength $@keynav_iosel_i] || ![llength $@keynav_iosel_o]} { return } else { set obj [lindex $@keynav_iosel_i 0] set in_objs $@keynav_iosel_i set out_objs $@keynav_iosel_o } } if {[[$obj class] <= Box]} { if {[$obj class] == "Canvas"} { if {[$obj gop]} {[$self widget] raise [list $obj [$obj visibles]]} } else { [$self widget] raise $obj } mset {type id detail} [$self identify_target $x $y 0] if {$type == "wire"} { mset {from outlet to inlet} [$id report] $self disconnect [$id connects] set from_idx [$@objects search $from] set to_idx [$@objects search $to] foreach obj $in_objs { set obj3_idx [$@objects search $obj] if {![llength [$obj ioselect]]} {set port 0} else {set port [lindex [$obj ioselect] 0]} set w1 [list $from_idx $outlet $obj3_idx $port] if {[$@wires search $w1]<0} {$self connect $w1} } foreach obj $out_objs { set obj3_idx [$@objects search $obj] if {![llength [$obj ioselect]]} {set port 0} else {set port [lindex [$obj ioselect] 0]} set w2 [list $obj3_idx $port $to_idx $inlet] if {[$@wires search $w2]<0} {$self connect $w2} } set @action move } foreach obj [$@objectsel values] {$obj move [expr $x-$ox] [expr $y-$oy]} } else { puts "Canvas motion warning: trying to move non-Box explicitly" } } def Canvas motion_edit {x y f} { if {[distance [list $x $y] $@click_at] > 5} { foreach obj [$@objectsel values] { if {[[$obj class] <= Box]} { $obj backupxy= [$obj xy] } else { puts "Canvas motion warning: trying to backup coordinates of non-Box" } } if {$f == 9} {set @action imove} else {set @action move; $self motion_move $@click_at $x $y} mset {ox oy} $@click_at } } def Canvas motion_checkhairtip {target x y} { global tooltip if {[$self look hairstate] && $@editmode} { $@crosshair data= $x $y $target $@crosshair draw } else { $@crosshair erase } if {[$self look tooltip]} { if {$tooltip ne "" && ![$tooltip iserror] && [expr [distance [$tooltip curpos] [list $x $y]] > 10]} { $tooltip delete set tooltip "" } } } def Canvas motion_iohilite2 {x y f} { set c [$self widget] set io [$self identify_closestio $x $y $f] if {$io<0} {set @iohilite [list -1 0 0 0 0]; return} foreach item {i o} { set type_idx [string first $item $io] set type [string index $io $type_idx] set port [string range $io [expr $type_idx+1] end] set object [string range $io 0 [expr $type_idx-1]] if {$type_idx >= 0} {break} } mset {iox ioy} [lmap / [rect_centre [$c bbox $io]] $@zoom] set @iohilite [list $object $iox $ioy $type $port] $object hilite_io $type $iox $ioy set @dehighlight [list $c delete ${io}b] } def Canvas iohilite {} {return $@iohilite} def Canvas motion_iohilite {target x y} { set c [$self widget] mset {type id detail} $target if {[llength $@keynav_iosel_i] || [llength $@keynav_iosel_o]} {return} if {$@editmode && [$id canvas] == $self} { switch $type { inlet {set io i} outlet {set io o} default {return} } set port [$id hilite_io $io $x $y] set @dehighlight [list $c delete ${id}$io${port}b] } } #-----------------------------------------------------------------------------------# # returns one of those five things: # object $id : the body of an object # inlet $id $inlet : an inlet of an object # outlet $id $outlet : an outlet of an object # wire $id : a wire # label $id : a label # nothing : nothing def Canvas identify_target {x y f} { set c [$self widget] set cx [expr $x*$@zoom] set cy [expr $y*$@zoom] set stack [$c find overlapping [expr $cx-2] [expr $cy-2] [expr $cx+2] [expr $cy+2]] # reversing the stack is necessary for some things # not reversing the stack is also necessary for some other things # we have to figure out something. set stack [lreverse $stack] set target "" foreach tag $stack {set target [$self target $x $y $f $tag]; if {[llength $target] > 1} {break}} if {[llength $target] > 1} {return $target} {return [list "nothing"]} } def Canvas target {x y f tag} { set c [$self widget] set cx [expr $x*$@zoom] set cy [expr $y*$@zoom] set tags [$c gettags $tag] if {[regexp {^[xo][0-9a-f]{6,8}} $tags id]} { # prior to Aug 15th, Wires had lower priority as all objects together # now it's same priority, so just stacking order (and it's prolly wrong) if {[$id classtags] == ""} {return [list "nothing"]} set class [$id class] if {[$self == $id]} {continue} if {[$class <= Wire]} {if {$@action != "imove"} {return [list "wire" $id]}} if {[$class <= Box]} { if {$@action == "imove"} { foreach tag [$self item_stack $x $y] { set tags2 [$c gettags $tag] if {[regexp {^[xo][0-9a-f]{6,8}} $tags2 id2]} { set class [$id2 class] if {[$class == Wire]} {return [list "wire" $id2]} } } } mset {x1 y1 x2 y2} [$id bbox] if {[regexp {^x[0-9a-f]{6,8}LABEL} $tags label]} { if {$x>$x1 && $x<$x2 && $y>$y1 && $y<$y2} { return [list "object" $id] } else { return [list "label" $id] } } set outs [$id noutlets] set ins [$id ninlets] if {$y>=$y2-6 && $outs} { set val [expr int(($x-$x1)*$outs/($x2-$x1))] if {$val==$outs} {incr val -1} return [list "outlet" $id $val] } if {$y< $y1+2 && $ins} { set val [expr int(($x-$x1)* $ins/($x2-$x1))] if {$val== $ins} {incr val -1} return [list "inlet" $id $val] } return [list "object" $id] } #puts "skipped a $class" } } def Canvas item_stack {x y} { set c [$self widget] set cx [expr {$x*$@zoom}] set cy [expr {$y*$@zoom}] set sense [$self pointer_sense] set stack [$c find overlapping [expr {$cx-$sense}] [expr {$cy-$sense}]\ [expr {$cx+$sense}] [expr {$cy+$sense}]] set stack [lreverse $stack] return $stack } def Canvas identify_closestio {x y f} { set c [$self widget] set ios {} set objs {} foreach tag [$self item_stack $x $y] { set tags [$c gettags $tag] if {[regexp {^[x][0-9a-f]{6,8}[oi][0-9]{1,3}} $tags io]} { foreach item {i o} { set type_idx [string first $item $io] set object [string range $io 0 [expr $type_idx-1]] if {$type_idx >= 0} {break} } if {[$object canvas] == $self} {lappend ios $io} } } if {![llength $ios]} {return -1} set mindist 66666 set idx 0; set i 0 foreach io $ios { set point2 [rect_centre [$c bbox $io]] set point1 [list $x $y] set dist [distance $point2 $point1] if {$dist < $mindist} {set mindist $dist; set idx $i} incr i } return [lindex $ios $idx] } def Canvas pointer_sense {} {return [$self look pointer_sense]} def Canvas pointer_sense= {sense} { set ::look(Canvas:pointer_sense) $sense mset {x y} $@curpos $@sense flash $x $y $sense "red" } #-----------------------------------------------------------------------------------# class_new StatusBar {View} ;# no, using View is wrong here. View is for tk canvas item collections. def StatusBar widget {} {return .$@canvas.stat} def StatusBar addw {a b text args} { set f [$self widget] if {$text!=""} { eval [concat [list pack [label $f.${a}_l -text $text -font {helvetica -10} -pady 0] -side left] $args] } label $f.$a -width $b -font {helvetica -10} -background #cccccc -foreground black -anchor w -pady 0 pack $f.$a -side left } def StatusBar init {canvas} { super set @canvas $canvas set f [$self widget] frame $f -border 1 -relief ridge $self addw px 4 "" $self addw py 4 "" $self addw what 28 " " -fill x -expand yes $self addw action 12 " Action: " $self addw sel 3 " Sel: " $self addw focus 10 " Focus: " } def Canvas statusbar_draw {x y} {$@statusbar draw $x $y} def Canvas action {} {return $@action} def Canvas action= {action} {set @action $action} def Canvas zoom {} {return $@zoom} def StatusBar draw {x y} { if {$x == "??"} {return} set c [$@canvas widget] set f [$self widget] set zoom [$@canvas zoom] set x [expr [$c canvasx $x]/$zoom] set y [expr [$c canvasy $y]/$zoom] set target [$@canvas identify_target $x $y -1] mset {type id detail} $target set t $target switch -- $type { object { if {[info exists _($id:pdclass)]} {set class $_($id:pdclass)} {set class unknown} append t " \[$class\]" } } set action [$@canvas action] if {[regexp ^o $action]} {set action [$action class]} if {[string length [$@canvas focus]]} {set t "focus: [$@canvas focus]"} $f.px configure -text [format "%4d" [expr round($x)]] $f.py configure -text [format "%4d" [expr round($y)]] if {$::debug} { $f.what configure -text [$c gettags [lindex [$c find overlapping [expr $x-2] [expr $y-2] [expr $x+2] [expr $y+2]] end]] } { $f.what configure -text $t } $f.action configure -text $action $f.sel configure -text [llength [$@canvas selection]] $f.focus configure -text [$@canvas focus] } #-----------------------------------------------------------------------------------# class_new FindModel {Thing} def FindModel init {canvas} { set @orig_canvas $canvas set @find_string "" set @next_canvases $canvas set @last_canvas 0 set @result "" set @results {} set @views {} set @recursive 1 set @info "" } def FindModel reinit {} { set @next_canvases $@orig_canvas set @last_canvas 0 set @result "" set @results {} $self remove_info } def FindModel remove_info {} { foreach view $@views { set f [$view widget] destroy $f.info_l; destroy $f.info } } def FindModel delete {} {foreach view $@views {destroy [$view widget]}; super} def FindModel find_string= {s} {set @find_string $s} def FindModel find_string {} {return $@find_string} def FindModel result= {s} { $@orig_canvas deselect_all $@orig_canvas selection= $s set @result $s } def FindModel result {} {return $@result} def FindModel views+ {view} {lappend @views $view} def FindModel views {} {return $@views} def FindModel end? {} {return $@end} def FindModel end= {v} {set @end 0} def FindModel search_recursive {} { if {![llength $@next_canvases]} {$self end; return} if {[llength $@results]} {$self result= [lindex $@results 0]; set @results [lreplace $@results 0 0];return} while {$@last_canvas < [llength $@next_canvases]} { set canvas [lindex $@next_canvases $@last_canvas] if {[$self cache_results $canvas]} { if {![winfo exists [$canvas widget]]} {$canvas popup_open} else {focus [$canvas widget]} $self result= [lindex $@results 0] set @results [lreplace $@results 0 0] incr @last_canvas } else { incr @last_canvas $self search_recursive } return } set old_canvases $@next_canvases set @next_canvases {} if {$@recursive} { foreach canvas $old_canvases {foreach x [$canvas get_childcanvas] {lappend @next_canvases $x}} } else { set @next_canvases {} } set @last_canvas 0 $self search_recursive } def FindModel end {} { $self reinit $@orig_canvas deselect_all set @info " \"$@find_string\" not found" foreach view $@views { $view addw label "info" "info" } } def FindModel cache_results {canvas} { set @results {} foreach child [$@objects values] { if {[string first $@find_string [$child text] 0] >= 0} { lappend @results $child } } if {[llength $@results]} {return 1} else {return 0} } class_new FindView {FindModel} ;# no, using View is wrong here. View is for tk canvas item collections. def FindView widget {} {return .$@canvas.find} def FindView init {canvas} { findmodel views+ $self set @canvas $canvas set @break 0 set f [$self widget] frame $f -border 1 -relief ridge $self addw button "close" "" $self addw text "find" "find" $self addw checkbutton "recursive" "recursive" if {[winfo exists .$@canvas.yscroll]} {set w .$@canvas.yscroll} else {set w .$@canvas.c} pack $f -side bottom -fill x -before $w set string [findmodel find_string] if {$string != ""} {$f.find insert 0 $string} } def FindView addw {type name label} { set f [$self widget] if {$label!=""} { eval [concat [list pack [label $f.${label}_l -text ${label}: -font {helvetica -10} -pady 0] -side left]] } switch $type { text { entry $f.$name -width 10 -relief flat -bg white -borderwidth 0 -highlightthickness 0 bind $f.$name <Escape> "findmodel delete" bind $f.$name <Return> "$self find" } checkbutton { checkbutton $f.$name if {$name == "recursive"} {$f.$name configure -variable _(findmodel:recursive)} } button { button $f.$name -border 1 -command "findmodel delete" -image icon_close -width 9 -height 9 if {$name == "close"} {bind $f.$name <Return> "findmodel delete"} } label {label $f.$name -textvariable _(findmodel:info) -font {helvetica -10} -pady 0} } pack $f.$name -side left bind $f.$name <Tab> "$self traversal %K %W forward" } def FindView find {} { set f [$self widget] findmodel find_string= [$f.find get] findmodel search_recursive focus .$@canvas.c } def FindView traversal {k w direction} { set f [$self widget] if {$w == "$f.recursive"} {set next $f.close} else {set next [tk_focusNext $w]} focus $next } def Canvas check_findbar {} { if {[info exists ::_(findmodel:_class)] && ![winfo exists .$self.find.find]} {FindView new $self} } def Canvas get_childcanvas {} { set canvases {} foreach child [$@objects values] {if {[$child class] == "Canvas"} {lappend canvases $child}} return $canvases } def Canvas runcommand {} {$@runcommand pack_prompt} class_new Runcommand {Listener} def Runcommand canvas {} {return $@canvas} def Runcommand init {serf name command} { set @history [History new 20] set @serf ${serf}.run set @command $command set @expanded 0 set @canvas [string trimleft $serf "."] set @defs {} set @completions {} set @comp_i 0 set @comp_s "666" set @show_id 0 $self defs set f $@serf frame $f -border 1 -relief ridge button $f.close -border 1 -command "$self unpack_prompt" -image icon_close -width 9 -height 9 bind $f.close <Return> "$self unpack_prompt" pack $f.close -side left bind $f.close <Tab> "$self traversal %K %W forward" label $f.cmd_l -text Command: -font {helvetica -10} -pady 0 pack $f.cmd_l -side left entry $f.entry -width 30 -relief flat -bg white -borderwidth 0 -highlightthickness 0 bind $f.entry <Escape> "$self unpack_prompt" bind $f.entry <Control-g> "$self unpack_prompt" bind $f.entry <Return> "$self eval" bind $f.entry <Up> "$self scroll_history +1" bind $f.entry <Down> "$self scroll_history -1" bind $f.entry <Control-p> "$self scroll_history +1" bind $f.entry <Control-n> "$self scroll_history -1" bind $f.entry <Tab> "$self completion +" switch $::tcl_platform(os) { Linux {bind $f.entry <ISO_Left_Tab> "$self completion -"} default {bind $f.entry <Shift-Tab> "$self completion -"} } pack $f.entry -side left -fill x -expand yes bind $f.entry <Control-Tab> "$self traversal %K %W forward" } def Runcommand pack_prompt {} { set f $@serf set @show_id [$@canvas show_id] if {!$@show_id} {$@canvas show_id= 1} if {[winfo exists .$@canvas.yscroll]} {set w .$@canvas.yscroll} else {set w .$@canvas.c} pack $f -side bottom -fill x -before $w focus $f.entry } def Runcommand unpack_prompt {} { if {!$@show_id} {$@canvas show_id= 0} pack forget $@serf focus [$@canvas widget] } def Runcommand traversal {k w direction} { set f $@serf if {$w == "$f.entry"} {set next $f.close} else {set next [tk_focusNext $w]} focus $next } def Runcommand eval {} { set f $@serf if {[winfo exists $f.completion]} { set l [string range $@comp 0 [expr [string first ":" $@comp 0]-1]] $self replace $l destroy $f.completion return } #$self unpack_prompt super $self unpack_prompt } def Runcommand defs {} { set name [$@canvas class] set len [string length ${name}_] foreach def [$name methods] {lappend @defs $def} } def Runcommand completion {which} { set f $@serf set text [$f.entry get] if {$text != $@comp_s} { set @comp_s $text set @completions {} set @comp_i 0 foreach def $@defs {if {[regexp ^$@comp_s $def]} {lappend @completions $def}} } if {![llength $@completions]} return set def [lindex $@completions $@comp_i] set args [$@canvas args $def] if {[lindex $args 0] == "self"} { set args2 [lreplace $args 0 0] } else { set args2 $args } if {![llength $args2]} {set args2 "none"} set @comp [join [list $def ":" $args2]] if {$which == "+"} { set @comp_i [expr ($@comp_i+1)%[llength $@completions]] } else { set @comp_i [expr $@comp_i-1] if {$@comp_i<0} {set @comp_i [expr [llength $@completions]-1]} } if {![winfo exists $f.completion]} { label $f.completion -textvariable _($self:comp) -pady 0 pack $f.completion -side right } } def Thing args {def} { set class [$self class] set ancestors [$class ancestors] set name ${class}_$def set n 0 foreach class $ancestors { set name ${class}_$def if {[info exists ::__args($name)]} {break} } return $::__args($name) } def Canvas visible_rect {} { set c [$self widget] set height [winfo height $c] set width [winfo width $c] if {$width == 1 && $height == 1} {set height 300; set width 450} mset {l r} [$c xview] mset {t b} [$c yview] if {$l == $r} {set l 0; set r 1} if {$t == $b} {set t 0; set b 1} set w [expr $width / ($r - $l)] set h [expr $height / ($b - $t)] mset {l2 r2} [lmap * [list $l $r] $w] mset {t2 b2} [lmap * [list $t $b] $h] return [list $l2 $t2 $r2 $b2] } def Canvas clipboard_coords {offset} { set in 0 foreach mess [pd_mess_split [$::clipboard value]] { set type [lindex $mess 1] switch $type { canvas {set in 1} "" {} connect {} default { if {$type == "restore"} {set in 0} mset {x y} [lmap + [lrange $mess 2 3] $offset] if {!$in} {lappend xcoords $x; lappend ycoords $y} } } } return [list $xcoords $ycoords] } def Canvas paste_visible? {x1 y1 x2 y2 offset} { set in 0 foreach mess [pd_mess_split [$::clipboard value]] { set type [lindex $mess 1] switch $type { canvas {set in 1} "" {} connect {} default { if {$type == "restore"} {set in 0} mset {x y} [lmap + [lrange $mess 2 3] $offset] if {!$in} { if {$x > $x2 || $x < $x1} {return 0} if {$y > $y2 || $y < $y1} {return 0} } } } } return 1 } def Canvas copy_times= {c} {set @copy_count $c} def Canvas copy_times {} {return $@copy_count} def Canvas copy {} { if {![$@objectsel size]} {return} $clipboard value= "" $self copy_times= 1 array unset ::obj_index_sel $self:* set j 0 foreach i [lsort -integer [$@objectsel keys]] { set child [$@objectsel get $i] #set ::obj_index_sel($self:$child) [$@objectsel search $child] set ::obj_index_sel($self:$child) $j; incr j $child deconstruct_to $::clipboard } foreach wire [$@wiresel values] { if {[array names ::obj_index_sel $self:[$wire from]] == ""} {continue} if {[array names ::obj_index_sel $self:[$wire to ]] == ""} {continue} $wire deconstruct_to $::clipboard $self } } def Canvas paste {} { if {[$self look snap_grid]} {set offset [$self look grid_size]} {set offset 15} $self do_paste [expr [$self copy_times] * $offset] $self copy_times= [expr [$self copy_times] + 1] } def Canvas do_paste {offset} { set in 0 $self deselect_all netsend [list .$self "push"] foreach mess [pd_mess_split [$::clipboard value]] { set type [lindex $mess 1] if {$type == "restore"} {incr in -1} if {!$in} {set with [list $self new_object_copyselect]} else {set with ""} switch $type { "" {} canvas {incr in; netsend $mess} connect { if {$with != ""} {set with [list $self new_wire_select]} netsend $mess $with} default {netsend [$self paste_coords $mess $offset] $with} } } netsend [list #X pop 1] } def Canvas paste_coords {mess offset} { set x [lindex $mess 2]; set y [lindex $mess 3] mset {vx1 vy1 vx2 vy2} [$self visible_rect] mset {xcoords ycoords} [$self clipboard_coords $offset] set visible [$self paste_visible? $vx1 $vy1 $vx2 $vy2 $offset] set ref [lsearch $ycoords [lindex [lsort -real -increasing $ycoords] 0]] if {!$visible} { set xoff [expr ($vx2 - $vx1) * 0.25] set yoff [expr ($vy2 - $vy1) * 0.25] set x2 [expr [lindex $mess 2] - [lindex $xcoords $ref] + $vx1 + $xoff] set y2 [expr [lindex $mess 3] - [lindex $ycoords $ref] + $vy1 + $yoff] return [lreplace $mess 2 3 $x2 $y2] } else { puts "\t \t [expr $x+$offset] [expr $y+$offset] <<<<<" return [lreplace $mess 2 3 [expr $x+$offset] [expr $y+$offset]] } } def Canvas cut {} { $@history atomically [list cut] { $self copy $self delete_selection } } def Canvas duplicate {} { if {[$self look snap_grid]} {set off [$self look grid_size]} {set off 15} $self do_duplicate $off } def Canvas do_duplicate {offset} { global clipboard set backup $clipboard set clipboard [Clipboard2 new] $self copy $self do_paste $offset $clipboard delete set clipboard $backup } def Canvas mouse_copy {} { $self do_duplicate 0 } def Canvas select_all {} { $self editmode= 1 eval [concat [list $@objectsel reinit] [$@objects list]] eval [concat [list $@wiresel reinit] [ $@wires list]] } def Canvas deselect_all {} { #$self editmode= 1 $@objectsel clear $@wiresel clear } def Canvas popup_help {} {$::main class_browser} def Canvas popup_open {} { #$self init_window #set @mapped 1 if {[winfo exists [$self widget]]} {raise .$self; return} netsend [list .$self vis 1] #$self init_window #$self redraw } def Canvas popup {id x y} { set p .$self.popup catch {destroy $p} menu $p -tearoff false if {$id == $self} { $self populate_menu $p {popup_properties popup_help} } elseif {[$id class] == "Wire"} { $id populate_menu $p {popup_insert} } else { $id populate_menu $p {popup_properties popup_open popup_help popup_clear_wires popup_remove_from_path popup_delete_from_path popup_copy_id} } tk_popup $p [expr $x-5] [expr $y-5] } def View popup_copy_id {} { clipboard clear clipboard append $self } def Canvas disconnect {wire} { set @keynav_tab_sel "wire" set id [$@wires get [$self wire_idx $wire]] if {$id == $@keynav_current || $id == $@keynav_last_wire} { set @keynav_current 0 set @keynav_last_wire 0 } mset {from outlet to inlet} $wire netsend [list .$self disconnect $from $outlet $to $inlet] $@history add [list $self connect $wire] } def Canvas connect {wire {callback ""}} { mset {from outlet to inlet} $wire netsend [list .$self connect $from $outlet $to $inlet] $callback $@history add [list $self disconnect $wire] } def Canvas clear_wires_of {obj} { if {![llength [$obj ioselect]]} { set port 0; set type "none" } else { set port [lindex [$obj ioselect] 0] set type [lindex [$obj ioselect] 1] } foreach wire [$obj wires2] { mset {from outlet to inlet} [$wire report] switch $type { i {if { $to==$obj && $inlet==$port} {$self disconnect [$wire connects]; if { !$inlet} {lappend @auto_wire_from $from}}} o {if {$from==$obj && $outlet==$port} {$self disconnect [$wire connects]; if {!$outlet} {lappend @auto_wire_to $to }}} none { $self disconnect [$wire connects] if {$from==$obj && !$outlet} {lappend @auto_wire_to $to } if { $to==$obj && ! $inlet} {lappend @auto_wire_from $from} } } } } def Canvas clear_wires {} { set @auto_wire_to {}; set @auto_wire_from {} if {[$@objectsel size] == 1} { set objs [$@objectsel values] } else { if {![llength $@keynav_iosel_i] && ![llength $@keynav_iosel_o]} {return} set objs [list $@keynav_iosel_i $@keynav_iosel_o] } foreach obj $objs {$self clear_wires_of $obj} } def Canvas reconnect {} { foreach from $@auto_wire_from { set idx1 [$@objects search $from] foreach to $@auto_wire_to { set idx2 [$@objects search $to] set wire [list $idx1 0 $idx2 0] if {[$self wire_idx $wire] < 0} {$self connect $wire} } } } def Canvas delete_obj_from_path {} {$self clear_wires; $self reconnect; $self delete_selection} def Canvas remove_obj_from_path {} {$self clear_wires; $self reconnect} def Canvas wire_idx {connects} { foreach {idx x} [$@wires list] { if {[string compare [join $connects] [join [$x connects]]] == 0} {return $idx} } return -1 } def Canvas reconnect_brkwires {type brk_quads obj} { set k [$@objects search $obj] foreach quad $brk_quads { mset {from outlet to inlet} $quad set orig_outlet $outlet; set orig_inlet $inlet switch $type { i {set orig_obj $to; set to $k; set inlet 0} o {set orig_obj $from; set from $k; set outlet 0} } netsend [list .$self connect $from $outlet $to $inlet] } if {$type == "i"} { netsend [list .$self connect $k 0 $orig_obj $orig_inlet] } else { netsend [list .$self connect $orig_obj $orig_outlet $k 0] } $self new_object_callback $obj } def Canvas expand_port {type idx port} { set obj [$@objects get $idx] mset {bx1 by1 bx2 by2} [$obj io_bbox $type $port] mset {ox1 oy1 ox2 oy2} [$obj bbox] mset ys [expr $oy2-$oy1] mset {brk_wires brk_quads} [$self broken_wires $type $idx $port $self] switch $type { i {mset {nx ny} [$self xy_snap $bx1 [expr $by1-25]]} o {mset {nx ny} [$self xy_snap $bx1 [expr $by1+$ys+25]]} } foreach quad $brk_quads {$self disconnect $quad} set reply [list $self reconnect_brkwires $type $brk_quads] netsend [concat [list .$self obj $nx $ny] t a] $reply } def Canvas outlet_expand {k outlet} {set reconnect [$self broken_wires o $k $inlet]} def Canvas implicit_wires {objs} { set l {}; set h $@objects foreach obj $objs { set k [$h search $obj] for {set i 0} {$i < [$obj ninlets]} {incr i} { set ws [$self com_wires i $k $i]; if {[llength $ws]} {foreach w $ws {lappend l $w}} } for {set o 0} {$o < [$obj noutlets]} {incr o} { set ws [$self com_wires o $k $o]; if {[llength $ws]} {foreach w $ws {lappend l $w}} } } #return [lsort -integer -unique $l] return [lsort -unique $l] } def Canvas com_wires {type k port} { set h $@objectsel; set obj [$@objects get $k]; set wires [$obj wires2]; set l {} foreach wire $wires { mset {f2 o2 t2 i2} [$wire connects] if {$t2==$k && $i2==$port && $type=="i" && [$h exists $f2]} {lappend l $wire} if {$f2==$k && $o2==$port && $type=="o" && [$h exists $t2]} {lappend l $wire} } return $l } def Canvas broken_wires {type k port canvas} { set shash [$canvas objectsel] set obj [[$canvas objects] get $k] set wires [$obj wires2]; set brk_wires {}; set quads {} foreach wire $wires { mset {f2 o2 t2 i2} [$wire connects] if {$t2==$k && $i2==$port && $type=="i" && ![$shash exists $f2]} { lappend brk_wires $wire; lappend quads [$wire connects] } if {$f2==$k && $o2==$port && $type=="o" && ![$shash exists $t2]} { lappend brk_wires $wire; lappend quads [$wire connects] } } return [list $brk_wires $quads] } def Canvas selection_center {} { set x 0; set y 0 foreach obj [$@objectsel values] { mset {x1 y1} [$obj xy] incr x $x1 incr y $y1 } set n [$@objectsel size] set x [expr $x / $n] set y [expr $y / $n] return [list $x $y] } # translate the key/idx in $@objects to key/idx in $@objectsel def Canvas idx_map {idx} { set i 0; set obj [$@objects get $idx] foreach sobj [$@objectsel values] {if {$obj == $sobj} {return $i}; incr i} return -1 } def Canvas subpatcherize_mkio {center iolist offset} { mset {x y} $center; set inx 0; set outx 0 for {set i 0} {$i < [llength $iolist]} {incr i} { mset {type io port dsp} [lindex $iolist $i] if {$type == "i"} { if {$dsp} {set inlet "inlet~"} {set inlet "inlet"} netsend [list #X obj [expr ($inx+1)*100] 0 $inlet] netsend [list #X connect $offset 0 $io $port] incr inx } else { if {$dsp} {set outlet "outlet~"} {set outlet "outlet"} netsend [list #X obj [expr ($outx+1)*100] [expr $y*2] $outlet] netsend [list #X connect $io $port $offset 0] incr outx } incr offset } } def Canvas subpatcherize_iopos {orig io} { set tab {}; set result {} for {set x 0} {$x < [llength $orig]} {incr x} { mset {from k1 io1 dsp} [lindex $orig $x]; mset {k2 io2} [lindex $io $x] set obj1 [$@objects get $k1] mset {x1 y1 x2 y2} [$obj1 io_bbox $from $io1]; set x1 [expr int($x1)] lappend pos $x1; lappend tab [list $k1 $x1 [list $k2 $io2 $dsp]] #lappend pos $x1; lappend tab [list $k1 $x1 [list $k2 $io2]] } set tab [lsort -index 1 -real $tab]; set foo "" foreach item $tab {mset {k1 val foo2} $item; if {$foo2 != $foo} {lappend result $foo2}; set foo $foo2} return $result } def Canvas subpatcherize {} { set center [$self selection_center] set rewire_off [llength [$@objectsel values]] set ins {}; set outs {}; set toins {}; set fromouts {}; set broken {}; set iolist {} foreach obj [$@objectsel values] { for {set i 0} {$i < [$obj ninlets]} {incr i} { mset {brk_wires brk_quads} [$self broken_wires i [$@objects search $obj] $i $self] if {[llength $brk_wires]} { foreach wire $brk_quads { set out_obj_name [[$@objects get [lindex $wire 0]] text] if {[regexp {~} $out_obj_name]} {set dsp 1} {set dsp 0} lappend broken [concat i $wire $dsp] } } } for {set o 0} {$o < [$obj noutlets]} {incr o} { mset {brk_wires brk_quads} [$self broken_wires o [$@objects search $obj] $o $self] if {[llength $brk_wires]} { foreach wire $brk_quads { set out_obj_name [[$@objects get [lindex $wire 0]] text] if {[regexp {~} $out_obj_name]} {set dsp 1} {set dsp 0} lappend broken [concat o $wire $dsp] } } } } # $broken stores total number of broken connections, i= need [inlet] o = need [outlet] foreach c $broken { mset {type f o t i dsp} $c if {$type == "i"} { lappend ins [list $t $i]; lappend toins [list o $f $o $dsp] } else { lappend outs [list $f $o]; lappend fromouts [list i $t $i $dsp] } } # figures out the inlet/outlet positioning and num of in/outlet to create set ins [$self subpatcherize_iopos $toins $ins] set outs [$self subpatcherize_iopos $fromouts $outs] # iolist stores in/outlets to be conected inside the subpatch foreach in $ins {mset {idx p dsp} $in; lappend iolist [list i [$self idx_map $idx] $p $dsp]} foreach out $outs {mset {idx p dsp} $out; lappend iolist [list o [$self idx_map $idx] $p $dsp]} puts "\t \t Cutting..............." $self cut puts "\t \t Push.................." netsend [list .$self "push"] netsend [list #N canvas 0 0 450 300 sub 0] [list $self subpatcherize_id] puts "\t \t Push clipboard........" foreach mess [pd_mess_split [$::clipboard value]] {netsend $mess} #creating in/outlets $self subpatcherize_mkio $center $iolist $rewire_off #netsend [list [concat #X restore $center pd sub]] netsend [concat #X restore $center pd sub] puts "\t \t Pop..................." netsend [list .$self "pop"] [list $self subpatcherize_rewire $broken $ins $outs] } def Canvas subpatcherize_id {id} {set @subpatcherize_id $id} def Canvas subpatcherize_rewire {wires inlist outlist bogus} { set obj $@subpatcherize_id foreach wire $wires { mset {type f o t i dsp} $wire if {$type == "i"} { set idx [lsearch $inlist [list $t $i $dsp]] $self connect [list $f $o [$@objects search $obj] $idx] } else { set idx [lsearch $outlist [list $f $o $dsp]] $self connect [list [$@objects search $obj] $idx $t $i] } } } def Canvas end_action {} { switch -- $@action { none {post "ending action 'none' makes no sense"} default {$@action delete; set @action "none"} } } proc shift? {f} {return [expr $f&1]} proc ctrl? {f} {return [expr $f&2]} proc alt? {f} {return [expr $f&4]} proc button_of {f} { # set f [expr $f>>8] # set b 1 # while {[expr $f&1==0} {set f [expr $f>>1]} # return $f return [expr $f>>8] } class_new FutureWire {View} def FutureWire init {canvas x y f target} { super set @canvas $canvas mset {type from port} $target switch $type { outlet {set @from $from; set @outlet $port; set @to "" ; set @inlet "" ; set port_name ${from}o${port}} inlet {set @from "" ; set @outlet "" ; set @to $from; set @inlet $port; set port_name ${from}i${port}} } mset {x y} [lmap / [rect_centre [[$@canvas widget] bbox $port_name]] [$@canvas zoom]] set @x1 $x set @y1 $y $self motion $@x1 $@y1 $f $target } def FutureWire motion {x y f target} { set @x2 $x set @y2 $y mset [list type foo bar] $target $self draw } def FutureWire unclick {x y f target} { mset [list type foo bar] $target mset {obj iox ioy io idx} [$@canvas iohilite] if {$obj != -1} { switch $io {i {set type "inlet"} o {set type "outlet"}} set target [list $type $obj $idx] } switch $type { outlet {mset [list type @from @outlet] $target} inlet {mset [list type @to @inlet] $target} default {} } set from_idx [[$@canvas objects] search $@from] set to_idx [[$@canvas objects] search $@to] if {$from_idx >= 0 && $to_idx >= 0 && $@from != $@to} { $@canvas connect [list $from_idx $@outlet $to_idx $@inlet] } if {![shift? $f]} {$@canvas end_action} } def FutureWire draw {} { $self item WIRE line [xys $@x1 $@y1 $@x2 $@y2] -dash {4 4 4 4} -fill [$self look dash] -smooth yes } class_new GopRect {View} def GopRect init {canvas rect} { set @canvas $canvas set @rect $rect } def GopRect draw {} { $self item GOPRECT rectangle $@rect -outline [$self look fg] } class_new SelRect {View} def SelRect init {canvas x y bf target} { super set @x1 $x set @y1 $y set @canvas $canvas $self motion $x $y 0 $target } def SelRect motion {x y f target} { set @x2 $x set @y2 $y $self draw } def SelRect unclick {x y f target} { $self motion $x $y 0 $target set sel {} set c [$@canvas widget] mset {x1 y1 x2 y2} [lmap * [list $@x1 $@y1 $@x2 $@y2] [$@canvas zoom]] set sel [$c find overlapping $x1 $y1 $x2 $y2] set selrect_index [lsearch $sel [$c find withtag selrect]] set sel [lreplace $sel $selrect_index $selrect_index] if {[llength $sel]} { set objects {} #set wires {} foreach tag $sel { if {[regexp {^[xo]?[0-9a-f]{6,8}} [$c gettags $tag] id]} { if {[$@canvas == $id]} {continue} if {[[$id class] <= Box]} {lappend objects $id} #elseif {[[$id class] <= Wire]} {lappend wires $id} } } set objects [lsort -unique $objects] #set wires [lsort -unique $wires] set objects2 {} #so that objects in gop won't get selected... foreach obj $objects {if {[$obj canvas] == $@canvas} {lappend objects2 $obj}} $@canvas selection+= $objects2 #$@canvas selection_wire+= $wires } $@canvas selection_wire+= [$@canvas implicit_wires $objects] set _($@canvas:keynav_tab_sel) "wire" $@canvas end_action } def SelRect draw {} { $self item RECT line [list $@x1 $@y1 $@x2 $@y1 $@x2 $@y2 $@x1 $@y2 $@x1 $@y1] \ -fill [$self look rect] -dash {3 3 3 3} -dashoffset 3 } def Canvas click {x y f target} { if {[winfo exists .completion]} { raise .completion focus .completion.comp return } mset {type id detail} $target set c [$self widget] focus $c set @click_at [list $x $y] if {$f&8} {if {$id == ""} {set id $self}; $self right_click $id $x $y; return} if {!$@editmode} {$self click_runmode $id $x $y $f $target; return} set in_selection [expr [$@objectsel search $id]>=0] switch $@action { mouse_copy {$self move_selection} } switch $type { outlet {} inlet {} object {$self click_on_object $id $f} wire {$self click_on_wire $id $f $x $y} nothing { #$self deselect_all if {[lindex $@iohilite 0] == -1} {$self click_on_nothing $f $target $x $y; return} } label {$self click_on_object $id $f} default {error "BORK: $type"} } if {$@iohilite != "" && $type != "wire"} { mset {obj iox ioy io idx} $@iohilite if {$obj < 0} {return} switch $io { i {set type "inlet"} o {set type "outlet"} } if {$@action == "none" && [$obj canvas] == $self} { set @action [FutureWire new $self $iox $ioy $f [list $type $obj $idx]] } return } } def Canvas click_runmode {id x y f target} { foreach obj [$self selection] {if {[[$obj class] <= AtomBox]} {$obj unedit}} $self deselect_all #if {$@focus != ""} {if {[[$@focus class] <= TextBox]} {$self selection-= $@focus;$@focus unedit}} if {[llength $id]} { if {[$id class] != "Canvas"} { $id click $x $y $f $target } else { if {[$id subpatch]} { if {![$id mapped]} {$id popup_open} elseif {![$id gop]} {raise .$id} } } } } def Canvas click_on_object {id f} { set c [$self widget]; set text $c.${id}text # so that if one clicks on the objectbox when editing the objectname, the focus won't get lost if {[winfo exists $text]} {focus $text; return} switch [expr $f&255] { 0 { if {[$self action] == "mouse_copy"} {$self action= "none"; return} # if $id is the content of GOP if {[$id canvas] != $self} { set obj [$id get_parent_gop $self] } else {set obj $id} if {[$@objectsel search $obj] < 0 || [$@objectsel size] == 0} { $self deselect_all $self selection+= $obj set @action edit } else {set @action edit} } 1 { if {[$@objectsel search $id] < 0} { $self selection+= $id } else { $self selection-= $id } } 2 { if {![llength [$id wires2]]} {return} $self deselect_all $self selection+= $id $self remove_obj_from_path } 3 { if {[$id canvas] != $self} { set obj [$id get_parent_gop $self] } else {set obj $id} if {![$@objectsel size]} {$self selection+= $obj} if {[$@objectsel search $obj] < 0} { $self deselect_all $self selection+= $obj } $self action= "mouse_copy" } } } def Canvas click_on_wire {id f x y} { set obj_selection [$self selection] if {[llength $obj_selection]} {$self selection-= $obj_selection} set @keynav_tab_sel "object" switch [expr $f&255] { 0 {$self selection_wire= $id} 1 {$self selection_wire+= $id} 2 { set c [$self widget] set wire [$id connects] $self disconnect $wire set from [$@objects get [lindex $wire 0]]; set outlet [lindex $wire 1] set to [$@objects get [lindex $wire 2]]; set inlet [lindex $wire 3] set opos [lmap / [rect_centre [$c bbox ${from}o${outlet}]] [$self zoom]] set ipos [lmap / [rect_centre [$c bbox ${to}i${inlet}]] [$self zoom]] set pos [list $x $y] if {[distance $pos $opos] > [distance $pos $ipos]} { mset {x1 y1} $ipos set target [list outlet $from $outlet] } else { mset {x1 y1} $opos set target [list inlet $to $inlet] } set @action [FutureWire new $self $x1 $y1 $f $target] } } } def Canvas click_on_nothing {f target x y} { # this cget check actually saves a full tk redraw if {[[$self widget] cget -cursor] != {}} {[$self widget] configure -cursor {}} if {$@focus != ""} {if {[[$@focus class] <= TextBox]} {$@focus unedit}} if {$@action == "insert"} {return} if {![expr $f&255]} { $self deselect_all #$self click_deselect_io } switch $@action { edit {} move {} none {} insert {} chain_obj {} imove {} mouse_copy {} default {$@action unclick $x $y $f $target} } set @action [SelRect new $self $x $y $f $target] } def Canvas right_click {id x y} { set c [$self widget] set @insert_x $x; set @insert_y $y if {$id != $self} {set id [$self gop_target $id]} $self popup $id [winfo pointerx $c] [winfo pointery $c] } def Canvas unclick {x y f target} { set c [$self widget] mset {type id detail} $target if {$@editmode} { switch $@action { edit { if {[$id canvas] != $self} { set obj [$id get_parent_gop $self] } else {set obj $id} if {[$id class] == "Canvas"} {if {[$id text] == "graph"} {set @action none; return}} set focus [$self focus] if {$focus != ""} {if {[[$focus class] <= TextBox]} {$focus unedit}} $obj edit; set @action none; $obj changed action } move {$self unclick_move} none {} insert {} chain_obj {} mouse_copy {$self mouse_copy} imove {$self unclick_move} default {$@action unclick $x $y $f $target} } } else {$self unclick_runmode $target $f $x $y} $self adjust_scrollbars #$self checkgeometry } def Canvas unclick_move {} { $self move_selection set @action none } def Canvas move_selection {} { foreach obj [$@objectsel values] { if {![[$obj class] <= Box]} { puts "Canvas unclick warning: trying to move non-Box explicitly" continue } mset {x1 y1} [$obj xy] switch $@action { mouse_copy {} default {$obj position= [$obj backupxy]} } $obj moveto $x1 $y1 if {[$obj edit?]} {focus [[$obj canvas] widget].${obj}text} } set objs [$@objectsel values] } def Canvas unclick_runmode {target f x y} { if {[$self focus] != ""} {[$self focus] unclick $x $y $f $target} mset {type id detail} $target if {$id != ""} { if {[$id class] == "Array"} {$id unclick $x $y $f $target; return} } } def Canvas get_bbox {} {return $@bbox} if {$have_expand} { def Canvas notice {origin args} {$self child_changed $origin {expand}$args} } else { def Canvas notice {origin args} {eval [concat [list $self child_changed $origin] $args]} } def Canvas tab_jump {} { if {![$@objects size]} {return} set @keynav 1 set olength [$@objectsel size] set wlength [ $@wiresel size] if {$@keynav_tab_sel == "object"} { if {[$@wires size]} {set @keynav_tab_sel "wire"} } else { set @keynav_tab_sel "object" } switch $@keynav_tab_sel { object {$self tab_jump_object} wire {$self tab_jump_wire} } } def Canvas tab_jump_wire {} { # if no selection done by the mouse if {![$@wiresel size]} { # see if the selected object has wire, if yes, use it # if keynav_current is already a wire, do nothing if {[$@keynav_current class] != "Wire"} { #use the last key selected wire as start if there is one if {$@keynav_last_wire != 0} { $self deselect_all set @keynav_current $@keynav_last_wire } else { if {[llength [$@keynav_current wires2]]} { $self deselect_all set @keynav_current [lindex [$@keynav_current wires2] 0] set @keynav_last_wire $@keynav_current } else { # check if the canvas has wires, if yes, use it if {[$@wires size]} { $self deselect_all set @keynav_current [lindex [$@wires values] 0] set @keynav_last_wire $@keynav_current } else {return} } } } } $self selection_wire= $@keynav_current } def Canvas tab_jump_object {} { set olength [$@objectsel size] # if there is no selection done by mouse if {!$olength} { # if keynav_current is 0, aka the start of key navigation if {$@keynav_current == 0} { if {[$@objects size]} {set @keynav_current [lindex [$@objects values] 0]} else {return} } else { # if the keynav_current is a wire, set keynav_current to a object if {[$@keynav_current class] == "Wire"} { set @keynav_last $@keynav_current $self deselect_all # use the last key selected obj as the start if there is one if {$@keynav_last_obj != 0} { set @keynav_current $@keynav_last_obj } else { set @keynav_current [lindex [$@keynav_current report] 0] set @keynav_last_obj $@keynav_current } } } } elseif {$olength == 1} { set @keynav_current [lindex [$@objectsel values] 0] $self deselect_all } else { $self deselect_all set @keynav_current [$@objects get 0] set @keynav_last_obj $@keynav_current } $self selection= $@keynav_current } def Canvas key_nav_up {} {$self key_nav +1 -1 0} def Canvas key_nav_down {} {$self key_nav -1 +1 0} def Canvas key_nav_right {} {$self key_nav -1 -1 0} def Canvas key_nav_left {} {$self key_nav +1 +1 0} def Canvas key_nav_up_shift {} {$self key_nav +1 -1 1} def Canvas key_nav_down_shift {} {$self key_nav -1 +1 1} def Canvas key_nav_right_shift {} {$self key_nav -1 -1 1} def Canvas key_nav_left_shift {} {$self key_nav +1 +1 1} def Canvas key_nav {du dv shift} { if {$@keynav_shift && !$shift} {} set @keynav_shift $shift if {[$@objectsel size] > 1} { if {[llength $@keynav_iosel_i] > 0 || [llength $@keynav_iosel_o] > 0} { #$self deselect_all } } if {!$@keynav} {$self tab_jump} switch $@keynav_tab_sel { object { set @keynav_next [$self quadrant $du $dv [$@objects values]] if {!$shift} { $self selection-= $@keynav_current $@keynav_current selected?= 0 set @keynav_last_obj $@keynav_next } if {[$@objectsel search $@keynav_next] < 0} {$self selection+= $@keynav_next} } wire { #$@keynav_current selected?= 0 set @keynav_next [$self quadrant $du $dv [$@wires values]] if {!$shift} { $self selection_wire-= $@keynav_current $@keynav_current selected?= 0 set @keynav_last_wire $@keynav_next } if {[$@wiresel search $@keynav_next] < 0} {$self selection_wire+= $@keynav_next} } } #$self selection+= $@keynav_next set @keynav_current $@keynav_next } def Canvas victim {} { if {[$@objectsel size]} {return [$@objectsel values]} if {[string compare $@keynav_current 0]} {return {}} return $@keynav_current } def Canvas key_nav_ioselect {} { if {![$@objectsel size]} {return} set var [lindex [$@objectsel values] end] if {$@keynav_iosel != $var} {set @keynav_iocount 0} if {$@keynav_port != 0 && $@keynav_iosel == $var} { #set hilitebox $@keynav_port foreach io $@keynav_port2 {[$self widget] delete ${io}b} } set obj [lindex [$@objectsel values] 0] set ins [$obj ninlets] set outs [$obj noutlets] set ports {}; set ports2 {}; set ports3 {} for {set i 0} {$i < $ins} {incr i} {lappend ports ${obj}i${i}; lappend ports2 "i"; lappend ports3 $i} for {set i 0} {$i < $outs} {incr i} {lappend ports ${obj}o${i}; lappend ports2 "o"; lappend ports3 $i} #incr @keynav_iocount if {$@keynav_iocount >= [llength $ports]} {set @keynav_iocount 0} set port [lindex $ports3 $@keynav_iocount] set type [lindex $ports2 $@keynav_iocount] set @keynav_port ${obj}${type}${port} set @keynav_port2 {} # @keynav_port stores the current hilited in/outlets # @keynav_ports stores the current hilited in/outlets if there are multiple objects # @keynav_iosel_i stores the selected inlets # @keynav_iosel_o stores the selected outlets foreach object [$@objectsel values] { if {$@keynav_iosel != $var} {set @keynav_iosel $var} switch $type { i { if {[lsearch $@keynav_iosel_i $object] == -1} { lappend @keynav_iosel_i $object set find [lsearch $@keynav_iosel_o $object] if {$find >= 0} {set @keynav_iosel_o [lreplace $@keynav_iosel_o $find $find]} } } o { if {[lsearch $@keynav_iosel_o $object] == -1} { lappend @keynav_iosel_o $object set find [lsearch $@keynav_iosel_i $object] if {$find >= 0} {set @keynav_iosel_i [lreplace $@keynav_iosel_i $find $find]} } } } mset {x y x1 y1} [[$self widget] bbox ${object}${type}${port}] lappend @keynav_port2 ${object}${type}${port} set _($object:ioselect) [list [lindex $ports3 $@keynav_iocount] [lindex $ports2 $@keynav_iocount]] #set _($object:ioselect) [lindex $ports3 $@keynav_iocount] $object hilite_io [lindex $ports2 $@keynav_iocount] [expr $x/$@zoom] [expr $y/$@zoom] } incr @keynav_iocount } def Canvas keyboard_mode {} { post "loading keyboard-mode...." if {[file exists kb-mode.tcl]} { package require kb-mode $@runcommand defs if {![info exists @kbcursor]} {set @kbcursor [kb-mode_init $self]} puts "cursor::: $@kbcursor" } } def Canvas keyboard_mode_exit {} { post "exiting keyboard-mode...." package forget kb-mode remove_callback kb-mode $@runcommand defs $@kbcursor delete read_ddrc remove_callback "kb-mode" unset @kbcursor } def Canvas keyprefix {} { if {!$@keyprefix} {set @keyprefix 1} else {set @keyprefix 0} } def Canvas click_deselect_io {} { if {[llength $@keynav_iosel_i] || [llength $@keynav_iosel_o]} { if {!$@iosel_deselect} {set @iosel_deselect 1} else {$self dehilite_io; set @iosel_deselect 0} } else { $self dehilite_io } } def Canvas dehilite_io {} { foreach io [concat $@keynav_iosel_i $@keynav_iosel_o] { puts "$io is a [$io class]" set box $_($io:ioselect) set type [lindex $_($io:ioselect) 1] set port [lindex $_($io:ioselect) 0] set tag ${io}${type}${port} [$self widget] delete ${tag}b set _($io:ioselect) {} } set @keynav_iosel_i {} set @keynav_iosel_o {} set @keynav_port 0 set @keynav_iocount 0 } def Canvas incr_scale {} {$self scale out} def Canvas decr_scale {} {$self scale in} def Canvas scale {mode} { set s $::scale_amount switch $mode { in { set s [expr 1/$s] }} set sel [$@objectsel values] if {![llength $sel]} {set sel [$@objects values]} foreach child $sel { mset {x y} [$child xy] set x1 [expr $x*$s] set y1 [expr $y*$s] $child position= [list $x1 $y1] netsend [list .$self object_moveto $child $x1 $y1] } foreach child $sel {$child changed_wires} } def Canvas incr_zoom {} {$self zooming in} def Canvas decr_zoom {} {$self zooming out} def Canvas zooming {mode} { global zoom bar set spinbox .$self.bbar.scale set val [string trimright [$spinbox get] %] set i [lsearch $zoom(canned) $val] set end [expr [llength $zoom(canned)] - 1] switch -regexp $mode { in|up {if {$i<$end} {incr i +1}} out|down {if {$i>0} {incr i -1}} } set per [lindex $zoom(canned) $i] $spinbox set $per% set @zoom [expr $per/100.0] ;# @zoom must be float, not int #$self propagate_zoom $@zoom $self redraw if {[$self look gridstate]} {if {$@editmode} {$@grid erase}} foreach child [$@objects values] {if {[$child class] == "Canvas" && [$child gop]} {$child all_changed}} } def Canvas propagate_zoom {zoom} { foreach child [$@objects values] { if {[$child class] == "Canvas"} { set @zoom $zoom $child propagate_zoom $zoom } } } #-----------------------------------------------------------------------------------# set lastcanvasconfigured "" set lastcanvasconfiguration "" def Canvas checkgeometry {} { set topname .$self set boo [winfo geometry $topname.c] set boo2 [wm geometry $topname] global lastcanvasconfigured lastcanvasconfiguration if {$topname != $lastcanvasconfigured || $boo != $lastcanvasconfiguration} { set lastcanvasconfigured $topname set lastcanvasconfiguration $boo } } #-----------------------------------------------------------------------------------# def Canvas selection_move {dx dy} { $@history atomically [list move] { $self selection_move2 $dx $dy } } def Canvas selection_move2 {dx dy} { if {![$self editmode]} {return} foreach o [$@objectsel values] { mset {x1 y1} [$o xy] if {[[$o class] <= Box]} { $o moveto [expr $x1+$dx] [expr $y1+$dy] } else { puts "selection_move: $o is not a Box, it's a [$o class]" } } } def Canvas key {x y key iso shift} { global tooltip; if {$tooltip ne ""} {$tooltip delete; set tooltip ""} #if {[modes_callback $self "key" $x $y $key $iso $shift]} {return} #if {[$self focus] != ""} {[$self focus] key $key $shift} #if {$iso != ""} {scan $iso %c key} #set focus [$self focus] if {!$@editmode && [llength [$self selection]] == 1} { set obj [$self selection] if {[[$obj class] <= AtomBox]} { if {[regexp {^[a-zA-Z0-9~/\._]{1}$} $key]} {$obj text= $key} {return} $obj edit $obj clear 0 return } } if {$shift} { if {[$self look snap_grid]} {set motion [expr [$self look grid_size]*2]} {set motion 10} } else { if {[$self look snap_grid]} {set motion [$self look grid_size]} {set motion 1} } set n [$@objectsel size] switch -regexp -- $key { BackSpace|Delete|KP_Delete {$self delete_selection} Up {if {$n} {$self arrow_key 0 -$motion} else {$self scroll y -$motion}} Down {if {$n} {$self arrow_key 0 +$motion} else {$self scroll y +$motion}} Left {if {$n} {$self arrow_key -$motion 0} else {$self scroll x -$motion}} Right {if {$n} {$self arrow_key +$motion 0} else {$self scroll x +$motion}} Tab {$self tab_jump} Return {$self return_key $x $y $key $iso $shift} F1 {$self deselect_all} F2 {set @keynav 0; $@active hide} default {} } } def Canvas return_key {x y key iso f} { mset {type id detail} [$self identify_target $x $y $f] if {![llength $@keynav_iosel_i] && ![llength $@keynav_iosel_o]} { if {[$@objectsel size] == 1} { mset {bx1 by1 bx2 by2} [[$self selection] bbox] set x1 [expr ($bx1+$bx2)/2]; set y1 [expr ($by1+$by2)/2] $self click_wrap $x1 $y1 1 $f $self unclick_wrap $x1 $y1 1 $f } } else { foreach out_obj $@keynav_iosel_o { set from [$@objects search $out_obj] set outlet [lindex $_($out_obj:ioselect) 0] foreach in_obj $@keynav_iosel_i { set to [$@objects search $in_obj] set inlet [lindex $_($in_obj:ioselect) 0] $self connect [list $from $outlet $to $inlet] } } $self dehilite_io } } def Canvas arrow_key {val1 val2} { if {![$self editmode]} { if {[$@objectsel size] == 1} { set o [$@selection values] if {[[$o class] <= IEMGUI] || [[$o class] == FloatBox]} {$o key_incr $val1 $val2} } } else {$self selection_move $val1 $val2} } def Canvas clear_selection {} { if {[$@objectsel size] > 0 || [$@wiresel size] > 0} { $self deselect_all $self dehilite_io } if {$@keynav} { set @keynav 0 #bogus switch so that keynav remains the same next time.. if {$@keynav_tab_sel == "object"} {set @keynav_tab_sel "wire"} {set @keynav_tab_sel "object"} } } #-----------------------------------------------------------------------------------# def Canvas keynav_current {} {return $@keynav_current} def Canvas keynav_current= {current} { set @keynav_current $current switch [$current class] { Wire {set @keynav_last_wire $current} default {set @keynav_last_obj $current} } } def Canvas keynav {} {return $@keynav} def Canvas keyup {x y key iso shift} { if {$iso != ""} {scan $iso %c key} if {$::macro_state} {$::macro state= 1; set ::macro_state 0 } $@active draw } class_new Active {View} def Active init {canvas} { super set @canvas $canvas set @length 3 set @length2 10 } def Active draw {} { set current [$@canvas keynav_current] if {$current == ""} {return} if {![string compare $current 0]} {return} set col [$self look selectframe] if {[$@canvas keynav]} { if {[$current class] == "Wire"} { $self item_delete set i 0 foreach side {1.6 -1.6} { mset {ax1 ay1 ax2 ay2} [$current bbox] set t [expr atan2($ay2-$ay1, $ax2-$ax1)] set cx1 [expr $ax1 + (($ax2-$ax1)* 0.15)] set cy1 [expr $ay1 + (($ay2-$ay1)* 0.15)] set cx2 [expr ($@length * cos($t+$side)) + $cx1] set cy2 [expr ($@length * sin($t+$side)) + $cy1] for {set n 0} {$n < 2} {incr n} { set angle [lindex {45 90 -45 -90} [expr $n+$i]] mset {ax1 ay1 ax2 ay2} [$current bbox] set t [expr atan2($ay2-$ay1, $ax2-$ax1)] set bx1 [expr $ax1 + (($ax2-$ax1)* 0.15)] set by1 [expr $ay1 + (($ay2-$ay1)* 0.15)] set bx2 [expr ($@length2 * cos($t+$angle)) + $bx1] set by2 [expr ($@length2 * sin($t+$angle)) + $by1] set line [list $cx2 $cy2 $bx2 $by2] $self item LINE$angle line $line -fill $col -width 2 } set i [expr $i+2] } } else { $self item_delete mset {x y} [lmap - [$current xy] 5] set line1 [list $x $y $x [expr $y + $@length2]] set line2 [list $x $y [expr $x + $@length2] $y] $self item LINE1 line $line1 -fill $col -width 2 $self item LINE2 line $line2 -fill $col -width 2 } } else {$self hide} } def Active hide {} {$self item_delete} def Active bbox {} { set current [$@canvas keynav_current] set l [$current xy] concat $l $l ;# happy now?? } def Canvas update_Active {item} {$self keynav_current= $item} #-----------------------------------------------------------------------------------# class_new Box {View} def Box init {{mess {}}} { super # @wires2 stores the connections to and from a object set @wires2 {} $self reinit $mess } def Box delete {} {if {$@canvas != ""} {[$@canvas objects] unset $@index}; super} def Box remove_braces {str} { # this hack is to remove the "\" in the text regsub -all {\\} $str "" text return $text } def Box reinit {mess} { global classinfo fields if {[$::macro state] && [llength $mess] > 4} {$::macro append_ref $mess} if {![llength $mess]} {return} ;# what? if {[lindex $mess 1] == "obj"} {set i 4} else {set i 1} set @pdclass [lindex $mess $i] if {[info exists fields($@pdclass)]} { set i 0 foreach f $fields($@pdclass) {set _($self:$f) [lindex $mess $i]; incr i} } else { set @text [$self remove_braces [join [lrange $mess 4 end]]] } $self outside_of_the_box } def Box update_size {} {} # will be so that @wires are updated correctly without breaking encapsulation def Box connect_out {} {} def Box connect_in {} {} def Box draw {} { $self draw_box if {[$@canvas show_id]} {$self draw_id} {$self item_delete ID} [[$self get_canvas] widget] raise $self $self update_hilite_io # if {[$self class] == "Canvas"} {$self restack} if {[info exists @elapsed]} { mset {x1 y1 x2 y2} [$self bbox] $self item ELAPSED text [l+ {10 1} [list $x1 $y2]] -anchor nw -fill "#008800" \ -text $@elapsed -font {{DejaVu Sans Mono} -8} } } def Box elapsed {f} { set @elapsed $f $self changed } def Canvas get_elapsed {} {netsend [list .$self get_elapsed]} def Canvas show_id {} {return $@show_id} def Canvas show_id= {val} {set @show_id $val; $self redraw} def Canvas id_toggle {} {if {$@show_id} {set @show_id 0} {set @show_id 1}; $self redraw} def Box draw_id {} { set id [$self index]: mset {x y} [$self xy] set fw [font measure [$self look font] 0] if {[$@canvas editmode]} { set col [complement [$@canvas look bgedit]] } else {set col [complement [$@canvas look bgrun]]} $self item ID text [list [expr $x-([string length $id]*$fw)] [expr $y+2]] \ -font [$self look font] -text $id \ -fill $col -anchor nw } def Box draw_box {} {} def Box edit {} {} def Box unedit {} {} def Box bbox {} { mset {x y} [$self xy] set xs $@xs set ys $@ys list $x $y [expr {$x+$xs}] [expr {$y+$ys}] } def Box io_bbox {type port} { mset {x1 y1 x2 y2} [$self bbox] set xs [expr {$x2-$x1}] # method calls aren't as fast as we'd want them to be. #set iowidth [$self look iowidth] #set fy [$self look iopos] set iowidth 7 set fy -1 switch $type { o {set n $@noutlets; set y [expr {$y2+$fy }]} i {set n $@ninlets; set y [expr {$y1-$fy-1}]} } set nplus [expr {$n==1 ? 1 : $n-1}] set onset [expr {$x1+($xs-$iowidth)*$port/$nplus}] set points [list $onset $y [expr {$onset+$iowidth}] $y] return $points } def Box ioselect= {type port} {set @ioselect [list $type $port]} def Box ioselect {} {return $@ioselect} def Box wires2 {} {return $@wires2} def Box wires2+= {val} {if {[lsearch $@wires2 $val] < 0} {lappend @wires2 $val}} def Box changed_wires {} {foreach wire $@wires2 {$wire changed}} def Box delete_wire {wire} { set find [lsearch $@wires2 $wire] if {$find != -1} {set @wires2 [lreplace $@wires2 $find $find]} } def Box move {dx dy} { set @x1 [expr {$@x1+$dx}]; set @y1 [expr {$@y1+$dy}] set zoom [$@canvas zoom] $self changed ;# until we find a way to avoid rounding errors on [$@canvas widget] move. $self changed_wires } # temporary hack... only used during the moving of objects. def Box backupxy= {xy} {set @backupxy $xy} def Box backupxy {} {return $@backupxy} # the only one sending to the server. # View position= is when getting position from server. # View xy is virtual (for GOP) def Box moveto {x1 y1} { netsend [list .$@canvas object_moveto $self $x1 $y1] [$@canvas history] add [list $self moveto $@x1 $@y1] if {[$self class] == "Canvas"} { if {[$self gop] && ![winfo exists .$self.c]} {foreach x $@visibles {$x changed}} } set @x1 $x1 set @y1 $y1 $self changed $self draw_wires } def Box draw_io2 {which n color} { for {set i 0} {$i<$n} {incr i} { set points [$self io_bbox $which $i] $self item [list $which$i $which] rectangle $points -outline $color -fill $color -width 1 [[$self get_canvas] widget] raise $self$which$i } } def Box draw_io {} { $self draw_io2 i $@ninlets [$self look inletfg] $self draw_io2 o $@noutlets [$self look outletfg] } def Box tips= {tips} {set @tips $tips} def Box tip {type port} { if {[info exists @tips]} { set tips $@tips } else { netsend [list .$@canvas object_get_tips $self] #after 500 $self tip $type $port set tips "" } switch $type { i {return "inlet $port: [lindex $tips $port]"} o {return "outlet $port"} } } # type is i or o def Box hilite_io {type x y} { mset {x1 y1 x2 y2} [$self bbox] set xs [expr $x2-$x1] set c [$@canvas widget] switch $type {i {set ports $@ninlets} o {set ports $@noutlets}} set port -1 set iowidth [$self look iowidth] for {set n 0} {$n<$ports} {incr n} { set tag $self$type$n set area [lmap / [$c bbox $self$type$n] [$@canvas zoom]] set center [expr ([lindex $area 2] + [lindex $area 0]) / 2 ] set dist [expr abs($x - $center)] if {$dist < [expr ($iowidth/2)+5] && $dist > 0} {set port $n} } if {$ports==0 | $port==-1} return if {$port >= $ports} {set port [expr $ports-1]} $self hilite_io_2 $type $port if {[$self look tooltip]} {$@canvas show_tooltip $x $y [$self tip $type $port] $type} return $port } def Box update_hilite_io {} { if {![llength $@ioselect]} {return} set type [lindex $@ioselect 1] set zoom [$@canvas zoom] set port [lindex $@ioselect 0] set p $type$port $self hilite_io_2 $type $port } def Box hilite_io_2 {type port} { set outline [switch $type {i {concat [$self look outletfg]} o {concat [$self look inletfg]}}] set box [l+ [$self io_bbox $type $port] [list -3 -3 +3 +3]] $self item $type${port}b rectangle $box -outline $outline -width 1 } #def Box popup_help {} {netsend [list pd help $@pdclass]} def Box popup_help {} {netsend [list .$@canvas object_help $self]} def Box show_error {text} { regsub "\n" $text "" text #mset {x1 y1 x2 y2} [$self bbox] #[$self get_canvas] show_tooltip [expr $x2+4] [expr ($y1+$y2)/2] $text object 1 mset {x1 y1 x2 y2} [$self bbox] mset {x y} [rect_centre [$self io_bbox i 0]] [$self get_canvas] show_tooltip $x $y $text i 1 } def Canvas macro_event_append {e obj} { if {![llength $@macro_q]} {after $@macro_delay [list $self macro_schedule $@macro_delay] $obj} lappend @macro_q $e } def Canvas get_clipboard {obj} { puts "get clipboard" set content [clipboard get] set l {}; set s ""; set space " "; set last_newline [string last ";" $content] #foreach char [split $content ""] {lappend l [scan $char %c]} set i 0 foreach char [split $content ""] { if {$i == $last_newline} {break} #if {$char == ";"} {set s ${s}${space}list} {set s ${s}$char} if {$char != ";"} { if {$char == "\n"} { set s ${s}${space}$char } else { set s ${s}$char } } incr i } netsend [concat [list .$obj clipboard_set] $s] } def Canvas macro_schedule {delay obj} { if {[llength $@macro_q]} { set w [focus] set m [lindex $@macro_q 0] set fudge 0 mset {event x y mode k} $m switch $event { key {set name [modekey $k $mode]; set fudge 1} click {set name [modeclick $k $mode ButtonPress]; set fudge 1} unclick {set name [modeclick $k $mode ButtonRelease]; set fudge 1} bang { after $delay [list $self macro_schedule $@macro_delay] $obj netsend [list .$obj mbang] set @macro_q [lreplace $@macro_q 0 0] return } default {puts "Error: this event $event should not have been here.."} } if {$fudge} {event generate $w <Motion> -x $x -y $y} event generate $w <$name> -x $x -y $y #puts "event generate $w <$name> -x $x -y $y" if {$event=="key"} {event generate $w <KeyRelease-$k> -x $x -y $y} set @macro_q [lreplace $@macro_q 0 0] after $delay [list $self macro_schedule $@macro_delay] $obj } } def Canvas foobar {} {$self macro_schedule 1000} def Canvas macro_q {} {puts "$@macro_q"} #-----------------------------------------------------------------------------------# class_new Wire {View} def Wire canvas= {c} { super $c mset {from outlet to inlet} $@connects set children [$c objects] set @from [$children get $from] set @to [$children get $to] $@from wires2+= $self; $@to wires2+= $self } def Box index= {i} {super $i; if {$@canvas != ""} {[$@canvas objects] set $i $self}} def Wire index= {i} {super $i; [$@canvas wires] set $i $self } def Wire init {mess} { super $self reinit $mess } def Wire reinit {mess} { if {[$::macro state]} {$::macro append_ref $mess} mset {x msg from outlet to inlet canvas} $mess set @connects [list $from $outlet $to $inlet] set @outlet $outlet set @inlet $inlet $self outside_of_the_box } def Wire from {} {return $@from} def Wire outlet {} {return $@outlet} def Wire to {} {return $@to} def Wire inlet {} {return $@inlet} def Wire move {dx dy} {$self changed} # DON'T do the former, it's so horribly slow #def View draw_wires {} {foreach wire $_($@canvas:wires) {$wire changed}} def View draw_wires {} {foreach wire $@wires2 {$wire changed}} def Wire bbox {} { set from $@from; set outlet $@outlet set to $@to; set inlet $@inlet set zoom [$@canvas zoom] set c [$@canvas widget] mset {x1 y1} [lmap / [rect_centre [$c bbox ${from}o${outlet}]] $zoom] mset {x2 y2} [lmap / [rect_centre [$c bbox ${to}i${inlet} ]] $zoom] list $x1 $y1 $x2 $y2 } def Wire xy {} { mset {x1 y1 x2 y2} [$self bbox] list [expr $x1 + (($x2-$x1)*0.05)] [expr $y1 + (($y2-$y1)*0.05)] } def Wire report {} {list $@from $@outlet $@to $@inlet} def Wire connects {} {return $@connects} proc xys {x1 y1 x2 y2} { return [list $x1 $y1 $x2 $y2] ;# just a straight line, no frills set r {} lappend r $x1 $y1 set dx [expr $x2-$x1] set dy [expr $y2-$y1] set d [expr sqrt($dx*$dx+$dy*$dy)] set n [expr 1+$d/10] for {set i 1} {$i<$n} {incr i} { set w $i*($n-$i)/(0.0+$n*$n) lappend r [expr $x1 + $dx*$i/$n + $dy*(rand()-0.5)*$w] lappend r [expr $y1 + $dy*$i/$n - $dx*(rand()-0.5)*$w] } lappend r $x2 $y2 return $r } def Wire draw {} { set zoom [$@canvas zoom] set c [$@canvas widget] set iowidth [$@from look iowidth] mset {ox1 oy1 ox2 oy2} [$@from io_bbox o $@outlet] mset {ix1 iy1 ix2 iy2} [ $@to io_bbox i $@inlet] set x1 [expr ($ox1+$ox2)/2.0]; set y1 $oy2 set x2 [expr ($ix1+$ix2)/2.0]; set y2 $iy1 set xys [xys $x1 $y1 $x2 $y2] set length [expr sqrt(pow($x2-$x1,2)+pow($y2-$y1,2))] # how to customise the arrow size/shape? set arrowsize [expr $length<100 ? $length/10 : 10] if {$arrowsize < 5} {set arrow none} {set arrow last} set arrowshape [list $arrowsize [expr $arrowsize*4/5] [expr $arrowsize/3]] set wire_width [$self look thick] set wire_color [$self look fg] if {[$self selected?]} { set wire_color [$self look fg2] ;# fg2 should be renamed } else { if {[info exists _($@from:text)] && [info exists _($@to:text)]} { if {[regexp -nocase {~$} [lindex $_($@from:text) 0]] && \ [regexp -nocase {~$} [lindex $_($@to:text) 0]]} { set wire_width [expr $wire_width*2] } } } set options {} if {[$self look wirearrow]} {lappend options -arrow $arrow -arrowshape $arrowshape} eval [concat [list $self item WIRE line $xys -width $wire_width -smooth yes -fill $wire_color] $options] } def Wire delete {} { $self unsubscribe $@canvas $@from delete_wire $self $@to delete_wire $self [$@canvas wires] unset $@index super } def Wire popup_insert {} { if {![llength [$@canvas selection_wire]]} {$@canvas selection_wire= $self} mset {x y} [$@canvas insertxy] $@canvas do_insert_obj $x $y } #-----------------------------------------------------------------------------------# ############ colouring # equivalent to color* #c0c0c0 $c proc darker {c} { scan $c #%02x%02x%02x r g b set r [expr $r*3/4] set g [expr $g*3/4] set b [expr $b*3/4] return [format #%02x%02x%02x $r $g $b] } proc brighter {c} { scan $c #%02x%02x%02x r g b set r [min 255 [expr $r*4/3]] set g [min 255 [expr $g*4/3]] set b [min 255 [expr $b*4/3]] return [format #%02x%02x%02x $r $g $b] } proc randomise_color {c} { scan $c #%02x%02x%02x r g b set r [clip [expr $r+int(rand()*65)-32] 0 255] set g [clip [expr $g+int(rand()*65)-32] 0 255] set b [clip [expr $b+int(rand()*65)-32] 0 255] return [format #%02x%02x%02x $r $g $b] } proc parse_color {c} { regsub {;$} $c {} c if {$c<0} { set c [expr ~$c] set r [expr round((($c>>12)&63)*255/63)] set g [expr round((($c>> 6)&63)*255/63)] set b [expr round((($c>> 0)&63)*255/63)] return [format #%02x%02x%02x $r $g $b] } {return #[lindex $::preset_colours2 $c]} } proc unparse_color {c} { if {[string index $c 0]=="#"} {set c [string replace $c 0 0 0x]} set r [expr round((($c>>16)&255)*63/255)] set g [expr round((($c>> 8)&255)*63/255)] set b [expr round((($c>> 0)&255)*63/255)] return [expr ~0[format %02o%02o%02o $r $g $b]] } ############ data transfer # note: @pdclass is the server-side class name # and @_class is the client-side class name # abstract classes set fields1 {foo bar x1 y1 class} set fields2 {snd rcv lab ldx ldy fstyle fs bcol fcol lcol} # real classes set fields(tgl) [eval list $fields1 w isa $fields2 on nonzero] set fields(bng) [eval list $fields1 w hold break isa $fields2] set fields(nbx) [eval list $fields1 w h min max is_log isa $fields2 val log_height] set fields(hsl) [eval list $fields1 w h min max is_log isa $fields2 val steady] set fields(hradio) [eval list $fields1 w change isa n $fields2 on] set fields(vu) [eval list $fields1 w h rcv lab ldx ldy fstyle fs bcol lcol scale isa] set fields(cnv) [eval list $fields1 hh w h snd rcv lab ldx ldy fstyle fs bcol lcol isa] set fields(vsl) $fields(hsl) set fields(vradio) $fields(hradio) set fields(hdl) $fields(hradio) set fields(vdl) $fields(hradio) set fields(coords) {foo bar xfrom yfrom xto yto w h gop x1 y1} ;# goes with #N canvas set fields(floatatom) {foo bar x1 y1 w min max pos lab rcv snd} set fields(symbolatom) {foo bar x1 y1 w min max pos lab rcv snd} set fields(array) {name n elemtype flags} proc classinfo {pdclass _class} { global classinfo classinfo2 set classinfo($pdclass) $_class set classinfo2($_class) $pdclass } # basic patchables classinfo obj ObjectBox classinfo message MessageBox classinfo floatatom FloatBox classinfo symbolatom SymbolBox classinfo text Comment # non-patchables (scalars, arrays, ...) classinfo array Array # GUI patchables classinfo bng Bang classinfo tgl Toggle classinfo nbx NumBox classinfo hsl Slider classinfo vsl Slider classinfo vu Vu classinfo hradio Radio classinfo vradio Radio classinfo hdl Radio classinfo vdl Radio classinfo canvas Canvas classinfo cnv Cnv classinfo display Display # remember, _($foo:$bar) notation should die # because objects ought to be autonomous. # in array objects, number of inlets is bogus? #X array array1 1 float 3; #A 0 0; def View index= {i} {set @index $i} def View index {} {return $@index} proc change {self canvas index e {ninlets 0} {noutlets 0} {valid 1}} { foreach mess [pd_mess_split $e] {change_2 $self $mess} #the server ought to take care of this: #if {[lindex $e 1] == "array"} {set ninlets 0; set noutlets 0} if {$canvas != "x0"} {$self canvas= $canvas} $self index= $index $self ninlets= $ninlets $self noutlets= $noutlets if {[$self class] == "ObjectBox"} {$self valid= $valid} if {[$self class] == "Canvas"} { if {[$self subpatch]} {$self valid= $valid} if {[$self gop]} {$self valid= $valid} if {[$self abs]} {$self valid= $valid} } $self changed } proc change_2 {self mess} { set isnew [expr ![info exists ::_($self:_class)]] switch -- [lindex $mess 0] { "#N" {if {$isnew} {Canvas new_as $self $mess} else {$self reinit $mess}} "#X" { set i 1 # would it be possible to merge floatatom,symbolatom as gatom ? switch -- [lindex $mess 1] { obj {set class [lindex $mess 4]} msg {set class message} default {set class [lindex $mess 1]}} if {[info exists ::classinfo($class)]} { set _class [lindex $::classinfo($class) 0] } else { if {[lindex $mess 1] == "connect"} { set _class Wire } else { set _class ObjectBox } } if {$isnew} {$_class new_as $self $mess} else {$self reinit $mess} switch -- $class { floatatom {set class gatom} symbolatom {set class gatom} array {$self length= [lindex $mess 3]; $self name= [lindex $mess 2]} default {$self position= [lrange $mess 2 3]}} $self pdclass= $class } "#A" { #post "#A: $mess" $self array_set [lrange $mess 2 end] } "#V" { #post "#V: $mess" } default {if {$mess != ""} {error "what you say? �[lindex $mess 0]� in �$mess�"}} } } #proc pasting_count {self} { # global paste _ # if {$paste(count2) != $paste(count)} {incr paste(count2)} #} # split at message boundaries and atom boundaries, returning a list of lists of atoms. # spaces get temporary value \x01 # A_SEMI gets temporary value \x02 # backslash gets temporary value \x03 # A_COMMA is not handled yet proc pd_mess_split {s} { set s [regsub -all {\\\\} $s "\x03"] set s [regsub -all {(^|[^\\]);} $s "\\1\x02"] set s [regsub -all {(^|[^\\])[\s\n]+} $s "\\1\x01"] set s [regsub -all {^\n} $s "\x01"] ;# oops set s [regsub -all {\\([\\; \{\}])} $s "\\1\\2"] set s [regsub -all \x03 $s \\] set r {} foreach m [split $s \x02] { set m [regsub -all "\x01+" $m "\x01"] set m [regsub -all "^\x01" $m ""] set t [split $m \x01] lappend r $t } return $r } proc canonical_list {list} { set r {} foreach e $list {lappend r $e} return $r } proc pd_mess_split_want== {a b} { set b [canonical_list $b] set c [pd_mess_split $a] if {[string compare $c $b]} { puts "[VTred]string �$a�\nparses to �$c�\ninstead of �$b�[VTgrey]" } else { puts "[VTgreen]string �$a� OK[VTgrey]" } } if 0 { pd_mess_split_want== {foo;bar;baz;a\;;b\\;c\\\;;d\\\\;e} {foo bar baz {{a;}} {b\\} {{c\;}} {{d\\}} e} pd_mess_split_want== {foo\ bar} {{{foo bar}}} pd_mess_split_want== {foo \ bar\ foo\ bar foo} {{foo { } {bar foo bar} foo}} pd_mess_split_want== {\\ \\\\ \\\\\\ \ \\\ \\\\\ one} [list [list "\\" "\\\\" "\\\\\\" "\ \\\ \\\\\ one"]] pd_mess_split_want== "\n \n \n foo" foo pd_mess_split_want== "\\\x7b\\\x7b\\\x7b\\\x7b" [list [list "\x7b\x7b\x7b\x7b"]] pd_mess_split_want== "\\\x7d\\\x7d\\\x7d\\\x7d" [list [list "\x7d\x7d\x7d\x7d"]] exit } ############ rendering class_new MessageBox {TextBox} def MessageBox init {mess} { super $mess set @w 15 ;# this is useless? set @xs $@w set @ys $@w ;# this is a bug } def MessageBox draw_box {} { mset {x1 y1} [$self xy] set x2 [expr $x1+$@xs] set y2 [expr $y1+$@ys] set points [list $x1 $y1 [expr $x2+4] $y1 $x2 [expr $y1+4] $x2 [expr $y2-4] [expr $x2+4] $y2 $x1 $y2 $x2 $y2 $x1 $y2] if {[$self selected?]} {set frcol [$self look selectframe]} {set frcol [$self look frame3]} $self item BASE polygon $points -fill [$self look bg] -outline $frcol -width 1 [$@canvas widget] lower ${self}BASE ${self}TEXT [$@canvas widget] raise $self } def MessageBox draw {} { super $self draw_io } def MessageBox click {x y f target} { $self bang 1 netsend [list .$self bang] after 150 $self bang 0 } def MessageBox bang {flag} { if {$flag} {set color #ffff00} {set color [$self look bg]} [$@canvas widget] itemconfigure ${self}BASE -fill $color } # it was class_new AtomBox {View Box}, which is wrong because already Box<View # it shouldn't have mattered, but super doesn't support proper pruning yet #class_new AtomBox {Box} class_new AtomBox {Labelled TextBox} def AtomBox label_xy {} { mset {x1 y1} [$self xy] switch -- $@pos { 0 {list [expr {$x1-3}] [expr {$y1+2}]} 1 {list [expr {$x1+2}] [expr {$y1+2}]} 2 {list [expr {$x1-1}] [expr {$y1-1}]} 3 {list [expr {$x1-1}] [expr {$y1+3}]} } } def AtomBox label_anchor {} { switch -- $@pos { 0 {return ne} 1 {return nw} 2 {return sw} 3 {return nw} } } def AtomBox label_font {} {list Courier 10 bold} def AtomBox label_color {} {return -1} def AtomBox draw_box {} { $self update_size mset {x1 y1 x2 y2} [$self bbox] set points [list $x1 $y1 [expr $x2-4] $y1 $x2 [expr $y1+4] $x2 $y2 $x1 $y2] if {[$self selected?]} {set frcol [$self look selectframe]} {set frcol [$self look frame3]} $self item BASE polygon $points -fill [$self look bg] -outline $frcol [[$self get_canvas] widget] lower ${self}BASE ${self}TEXT $self draw_io } def AtomBox clear {var} {set @clear $var} def AtomBox clear= {} {return $@clear} def AtomBox filter_text {{for_edit 0}} { if {$for_edit} {return ""} if {[string length $@text] <= $@w} {return $@text} return [string range $@text 0 [expr $@w-1]] } def AtomBox update_size {} { set width [font measure [$self look font] 0] set ls [font metrics [$self look font] -linespace] set @xs [expr ($width*$@w)+3] set @ys [expr $ls+3] } class_new Comment {TextBox} def Comment draw_box {} { super mset {x1 y1} [$self xy] set x2 [expr $x1+$@xs] set y2 [expr $y1+$@ys] set xya [list $x1 $y1 $x2 $y2] set xyb [l+ [list $x2 $y1 $x1 $y1 $x1 $y2] [list -1 +1 +1 +1 +1 -1]] set xyc [l+ [list $x2 $y1 $x2 $y2 $x1 $y2] [list -1 +1 -1 -1 +1 -1]] if {[$@canvas editmode]} { if {[$self selected?]} {set frcol [$self look selectframe]} {set frcol [$self look frame3]} $self item BASE rectangle $xya -fill [$self look bg] -outline $frcol } else { $self item_delete BASE } #$self item BASE1 line $xyb -fill [$self look frame1] #$self item BASE2 line $xyc -fill [$self look frame2] if {[$@canvas editmode]} { [$@canvas widget] lower ${self}BASE ${self}TEXT #[$@canvas widget] raise ${self}BASE1 ${self}BASE #[$@canvas widget] raise ${self}BASE2 ${self}BASE } } class_new Display {Box} def Display height= {val} {set @height $val} def Display init {{mess {}}} { set font [$self look font] set fw [font measure $font 0] set @max_width 40; #in chars set @wrap [expr $fw*$@max_width]; #in pixels set @content {display} set @height 1 set @xs [expr [font measure [$self look font] 0]+3] set @ys [font metrics [$self look font] -linespace] set @textoffset [list 2 2] netsend [list .$self height] super $mess } def Display draw {} { super set font [$self look font] mset {x y} [$self xy] mset {xf yf} $@textoffset set fh [font metrics [$self look font] -linespace] set text [lindex $@content 0]; for {set i 1} {$i < $@height} {incr i} {set text ${text}\n[lindex $@content $i]} set h 0; set w 0 foreach line $@content { set tw [font measure $font $line] set h [expr int(ceil($tw/$@wrap.0)+$h)] set w [min [max $w $tw] $@wrap] } set h [max $h 1] $self item BASE rect [list $x $y [expr $x+$w+$xf+2] [expr $y+($@ys*$h)+$yf+1]] -fill [$self look bg] $self item TEXT text [l+ $@textoffset [$self xy]] -font $font -text $text -fill [$self look fg] -anchor nw -width $@wrap $self draw_io } def Display dis {text} { lappend @content $text if {[llength $@content] > $@height} {set @content [lrange $@content 1 end]} $self changed } class_new IEMGUI {} def IEMGUI text {} { return [$self class] } class_new BlueBox {Labelled IEMGUI Box} #class_new BlueBox {Box Labelled} def BlueBox draw_box {} { super set xya [$self bbox] mset {x1 y1 x2 y2} $xya set color [parse_color $@bcol] if {[$self selected?]} {set frcol [$self look selectframe]} {set frcol [$self look frame3]} $self item BASE rectangle $xya -fill $color -outline $frcol #below lines draws the 3d box edge #incr x1 +1; incr y1 +1; incr x2 -1; incr y2 -1 #$self item BASE2 line [list $x2 $y1 $x1 $y1 $x1 $y2] -fill #ffffff #$self item BASE3 line [list $x2 $y1 $x2 $y2 $x1 $y2] -fill [darker $color] $self draw_io } def IEMGUI popup_properties {} {IEMPropertiesDialogue new $self} class_new PropertiesDialogue {Dialogue} def PropertiesDialogue init {of} { super cancel apply ok set @of $of set f .$self checkbutton $f.auto_apply -text [say auto_apply] -anchor w -variable @auto_apply frame $f.buttonsep2 -height 2 -borderwidth 1 -relief sunken pack $f.auto_apply $f.buttonsep2 -side bottom -fill x bind $f <KeyPress-Return> "break";#so that Return don't call do_auto_apply after Dialogue ok #bind $f <KeyPress> [list $self do_auto_apply] ;# too wide: may cause Ok/Cancel to spit errors #bind $f <ButtonRelease> [list $self do_auto_apply] ;# too wide: may cause Ok/Cancel to spit errors $self non_resizable } class_new IEMPropertiesDialogue {PropertiesDialogue} def IEMGUI properties_apply {list {orient -1}} { set orig [list $self properties_apply] foreach var [lrange $::fields($@class) 5 end] {lappend orig $@$var} [$@canvas history] add $orig foreach v $list {switch -- $v {{} {set v "empty"}}; lappend props $v} netsend [concat [list .$self reload] $props] if {$orient >= 0} { netsend [list .$self orient $orient] } } def IEMPropertiesDialogue apply {} { set class $_($@of:class) set props {} foreach var [lrange $::fields($class) 5 end] { set v $@$var if {[regexp -nocase {^[bfl]col$} $var]} {set v [unparse_color $v]} lappend props $v } if {[[$@of class] <= Slider] || [[$@of class] <= Radio]} { $@of properties_apply $props $@orient } else { $@of properties_apply $props } } def IEMPropertiesDialogue init {of} { super $of set @class $_($of:class) wm title .$self "\[$@class\] [say popup_properties]" if {![info exists ::fields($@class)]} {set class obj} foreach var $::fields($@class) { set val $_($of:$var) switch -- $val { empty {set val ""}} if {[regexp -nocase {^([a-z])col$} $var]} {set val [parse_color $val]} set @$var $val } if {[[$of class] <= Slider] || [[$of class] <= Radio]} { set @orient $_($of:orient) $self add .$self [list orient choice -choices {horizontal vertical}] } foreach prop [lrange $::fields($@class) 5 end] { set d [concat [list $prop] [switch $prop { w {list integer -width 7} h {list integer -width 7} hold {list float -width 9} break {list float -width 9} min {list float -width 9} max {list float -width 9} is_log {list choice -choices {linear logarithmic}} isa {list choice -choices {no yes}} n {list integer -width 4} steady {list choice -choices {steady_no steady_yes}} snd {list entry -width 20} rcv {list entry -width 20} lab {list entry -width 20} ldx {list integer -width 5} ldy {list integer -width 5} fstyle {list choice -choices {Courier Helvetica Times}} fs {list fontsize -width 5} bcol {list color} fcol {list color} lcol {list color} val {continue} on {continue} change {list choice -choices {no yes}} nonzero {list float -width 9} log_height {list float -width 9} hh {continue} scale {list toggle} default {error "huh? ($prop)"} }]] $self add .$self $d } } def IEMPropertiesDialogue dropmenu_open {f name} {super $f} def IEMPropertiesDialogue dropmenu_set {frame var part val} { switch $var { orient {if {[$@of class] == "Slider"} {set tmp $@h; set @h $@w; set @w $tmp}} default {} } set tmp ${var}choices set textvar ${var}2 set @$textvar [say [lindex $@$tmp $val]] super $frame $var $part $val $self do_auto_apply } class_new CanvasPropertiesDialogue {PropertiesDialogue} def CanvasPropertiesDialogue init {of} { super $of set @canvas $of wm title .$self "[say canvas] [say popup_properties]" set @gop [$of gop] set @properties [list "gop" "xfrom" "xto" "yfrom" "yto" "width" "height" "xmargin" "ymargin"] set mess [$of get_mess] mset [list @xfrom @yfrom @xto @yto @width @height @xmargin @ymargin] $mess if {!$@width} {set @width 85}; if {!$@height} {set @height 60} $self add .$self [list gop toggle -command "$self gop_setting"] for {set i 1} {$i<[llength $@properties]} {incr i} { $self add .$self [list [lindex $@properties $i] integer -width 7] } $self gop_setting } def CanvasPropertiesDialogue gop_setting {} { set entries [lrange $@properties 1 end] foreach entry $entries { if {!$@gop} { .$self.$entry.entry configure -state disable } else { .$self.$entry.entry configure -state normal } } } def CanvasPropertiesDialogue apply {} { if {![$@canvas editmode]} {$@canvas editmode= 1} netsend [list .$@of coords $@xfrom $@yfrom $@xto $@yto $@width $@height $@gop $@xmargin $@ymargin] } proc gatom_escape {sym} { if {[string length $sym] == 0} {return "-"} if {[string equal -length 1 $sym "-"]} {return [string replace $sym 0 0 "--"]} return $sym } proc gatom_unescape {sym} { if {[string equal -length 1 $sym "-"]} {return [string replace $sym 0 0 ""]} return $sym } class_new BoxPropertiesDialogue {PropertiesDialogue} def Box popup_properties {} {BoxPropertiesDialogue new $self} def Box popup_clear_wires {} {[$self canvas] selection= $self; [$self canvas] clear_wires} def Box popup_remove_from_path {} {[$self canvas] selection= $self; [$self canvas] remove_obj_from_path} def Box popup_delete_from_path {} {[$self canvas] selection= $self; [$self canvas] delete_obj_from_path} def BoxPropertiesDialogue init {of} { super $of wm title .$self "Box Properties" pack [label .$self.huh -text "huh..."] pack [label .$self.huh2 -text "this is where some #V properties should go"] } class_new WirePropertiesDialogue {PropertiesDialogue} def Wire popup_properties {} {WirePropertiesDialogue new $self} def WirePropertiesDialogue init {of} { super $of wm title .$self "Wire Properties" pack [label .$self.huh -text "huh..."] pack [label .$self.huh2 -text "this is where some #V properties should go"] } class_new GAtomPropertiesDialogue {PropertiesDialogue} def AtomBox popup_properties {} {GAtomPropertiesDialogue new $self} # this is buggy due to miller's escapes vs iem's escapes. def GAtomPropertiesDialogue apply {} { netsend [list .$@of reload $@w $@min $@max $@pos [gatom_escape $@lab] [gatom_escape $@rcv] [gatom_escape $@snd]] } def GAtomPropertiesDialogue init {of} { super $of foreach var {w min max pos} {set @$var $_($of:$var)} foreach var {lab rcv snd} {set @$var [gatom_unescape $_($of:$var)]} wm title .$self "Atom" global properties $self add .$self \ {w integer -width 4} \ {min float -width 8} \ {max float -width 8} \ {lab symbol -width 20} \ {pos side } \ {snd symbol -width 20} \ {rcv symbol -width 20} #foreach name {w min max} {bind .$self.$name.entry <KeyPress-Return> "$self ok"} .$self.w.entry select from 0 .$self.w.entry select adjust end focus .$self.w.entry } class_new GraphPropertiesDialogue {Dialogue} def GraphPropertiesDialogue apply {} { netsend [list .$@of dialog $@x1 $@y1 $@x2 $@y2 $@xpix $@ypix] } def GraphPropertiesDialogue init {of} { super $of foreach var {x1 y1 x2 y2 xpix ypix} {set @$var $_($of:$var)} wm title .$self "Graph" pack [label .$self.label -text "GRAPH BOUNDS"] -side top global properties $self add .$self { {x1 integer -width 7} \ {x2 integer -width 7} \ {xpix entry -width 7} \ {y2 integer -width 7} \ {y1 integer -width 7} \ {ypix entry -width 7} } #.$self.xrangef.x2 select from 0 #.$self.xrangef.x2 select adjust end #focus .$self.xrangef.x2 } class_new ArrayPropertiesDialogue {Dialogue} def ArrayPropertiesDialogue apply {} { regsub {^\$} $@name "#" name netsend [list .$@apply arraydialog $name $@n $@saveit $@otherflag] } def ArrayPropertiesDialogue init {of} { super $of foreach var {name n saveit} {set @$var $_($of:$var)} set @otherflag 0 wm title $id "[say array] [say popup_properties]" $self add .$self {name entry} {n entry} pack [checkbutton .$self.saveme -text "save contents" -variable @saveit -anchor w] -side top if {$newone} { pack [frame .$self.radio] -side top foreach {i label} {0 "in new graph" 1 "in last graph"} { pack [radiobutton .$self.radio.radio$i -value $i -variable @otherflag -text $label] -side top -anchor w } } else { pack [checkbutton .$self.deleteme -text "delete me" -variable @otherflag -anchor w] -side top } if {$newone} {.$self.buttonframe.apply configure -state disabled} bind .$self.name.entry <KeyPress-Return> "$self ok" bind .$self.n.entry <KeyPress-Return> "$self ok" .$self.name.entry select from 0 .$self.name.entry select adjust end focus .$self.name.entry } class_new FloatBox {AtomBox} class_new SymbolBox {AtomBox} def AtomBox init {mess} { super $mess set @clickpos {} set width [font measure [$self look font] W] set height [font metrics [$self look font] -linespace] set @xs [expr ($width*$@w)+3] set @ys [expr $height+3] } def FloatBox init {mess} {super $mess; set @text 0;} def FloatBox calc {x y x1 y1} { #puts "$@min $@max" if {!$@min && !$@max} { set d [expr $@ovalue+($y1-$y)*$@rate] } else { set span [expr $@max-$@min] set l [expr $@max-$@min] set d [clip [expr $@ovalue+(($y1-$y)*$span/($l+0.0))*$@rate] $@min $@max] } return $d } def SymbolBox init {mess} {super $mess; set @text "symbol"} def AtomBox set {val} {set @text [format "%g" $val]; $self changed} def AtomBox setto {text} { [$@canvas widget] configure -cursor {} if { [string is double $text]} { set @text $text; #so that the text gets updated immediately netsend [list .$self float $text] #[$self get_canvas] selection-= $self } } def SymbolBox set {text} {set @text $text} def SymbolBox setto {text} { [$@canvas widget] configure -cursor {} if {![string is double $text]} {netsend [list .$self symbol $text]} } def FloatBox ftoa {} { set f $@val set is_exp 0 if {[string length $@buf]>0} {return $@buf} set buf [format %g $f] set bufsize [string length buf] if {$bufsize >= 5} { # exponential mode set is_exp [regexp -nocase e] } if {$bufsize > $@w} { # must shrink number if {$is_exp} { #... } { #... } } return $buf } def AtomBox click {x y f target} { set @clickx $x; set @clicky $y set canvas [$self get_canvas] set t [$canvas widget].${self}text set @ovalue [clip $@text $@min $@max] set @clickpos [list $x $y] set @mouse [list $x $y] $canvas focus= $self set @rate [expr $f&1 ? 0.01 : 1.00] } def AtomBox unclick {x y f target} { if {$x == $@clickx && $y == $@clicky} {$self edit} [$self get_canvas] focus= "" } def AtomBox motion {x y f target} { if {$@edit} {return} mset {clx cly} $@clickpos set @text [$self calc $x $y $clx $cly] netsend [list .$self float [expr {0+$@text}]] } def AtomBox log_ratio {} { set diff [expr $@is_log ? log($@max/$@min) : ($@max-$@min)] return [expr $diff / $@max] } def AtomBox key_incr {val1 val2} { set @text [expr $@text - $val2] netsend [list .$self float [expr {0+$@text}]] } def SymbolBox motion {x y f target} {} class_new NumBox {Labelled IEMGUI AtomBox} def NumBox init {mess} { super $mess set @clicking 0 set changed 0 set @buf "" set @text [clip 0 $@min $@max] } def NumBox calc {x y x1 y1} { set span [expr $@max-$@min] set l [expr $@is_log ? $@log_height : ($@max-$@min)] set d [expr {($y1-$y)*$span/($l+0.0)}] set d [expr $@is_log ? $@ovalue*exp($d*$@rate*[$self log_ratio]) : $@ovalue+$d*$@rate] set d [clip $d $@min $@max] return $d } def NumBox reinit {mess} { super $mess set @text $@val } def NumBox draw {} { super mset {x1 y1} [$self xy] set xs [expr 4+10*$@w] set ys $@h set x2 [expr $x1+$xs] set y2 [expr $y1+$ys] set c [[$self get_canvas] widget] set points [list $x1 $y1 [expr $x2-4] $y1 $x2 [expr $y1+4] $x2 $y2 $x1 $y2] set xt [expr $x1+$ys/2+2] set yt [expr $y1+$ys/2+1+$xs/34] set points2 [list $x1 $y1 [expr $x1+$ys/2] [expr $y1+$ys/2] $x1 $y2] set focused [$self == [$@canvas focus]] if {$focused} {set color4 #00ff00} {set color4 [$self look bg]} $self item BASE4 polygon $points2 -outline [$self look frame3] -fill $color4 $c raise ${self}BASE4 } def NumBox ftoa {} { set f $@text set is_exp 0 if {[string length $@buf]>0} {return $@buf} set buf [format %g $f] set bufsize [string length buf] if {$bufsize >= 5} { # exponential mode set is_exp [regexp -nocase e] } if {$bufsize > $@w} { # must shrink number if {$is_exp} { #... } { #... } } return $buf } def NumBox unfocus {} {set @buf ""; $self changed} class_new Radio {BlueBox} def Radio reinit {mess} { super $mess switch [lindex $mess 4] { hradio {set @orient 0} hdl {set @orient 0} vradio {set @orient 1} vdl {set @orient 1} default {set @orient 0} } } def Radio bbox {} { mset {x1 y1} [$self xy] set x2 [expr {$x1+$@w*($@orient ?1:$@n)}] set y2 [expr {$y1+$@w*($@orient ?$@n:1)}] list $x1 $y1 $x2 $y2 } def Radio draw {} { mset {x1 y1 x2 y2} [$self bbox] super $self item_delete BUT ;# would be cool if this didn't delete stuff that we're about to redraw. for {set i 0} {$i<$@n} {incr i} { #set coords [list [expr {$x1+3}] [expr {$y1+3}] [expr {$x1+$@w-3}] [expr {$y1+$@w-3}]] set coords [list $x1 $y1 [expr {$x1+$@w}] [expr {$y1+$@w}]] $self item [list BUT$i BUT] rectangle $coords -fill [parse_color $@bcol] -outline [parse_color $@fcol] if {$@orient} {set y1 [expr {$y1+$@w}]} {set x1 [expr {$x1+$@w}]} } $self set $@on } def Radio set {value} { set c [$self get_canvas] mset {x1 y1} [$self xy] set value [expr round($value)] if {$@orient} {set y1 [expr $y1+$@w*$value]} {set x1 [expr $x1+$@w*$value]} set coords [list [expr {$x1+3}] [expr {$y1+3}] [expr {$x1+$@w-2}] [expr {$y1+$@w-2}]] puts "coords=$coords" $self item [list CHECK BUT] rectangle $coords -fill [parse_color $@fcol] -width 0 } def Radio click {x y f target} { mset {x1 y1} [$self xy] set i [expr {int($@orient ?$y-$y1-2:$x-$x1-2)/$@w}] netsend [list .$self fout $i] } def Radio key_incr {val1 val2} {netsend [list .$self fout [expr {$@on-$val2}]]} # in sliders, @value is the kind of value that goes thru inlets and outlets # whereas @val is always measured in "centipixels" (unzoomed). class_new Slider {BlueBox} def Slider reinit {mess} { super $mess switch [lindex $mess 4] { hsl {set @orient 0} vsl {set @orient 1} } $self update_value } def Slider update_value {} { set span [expr {$@max-$@min}] set l [expr $@orient ?$@h:$@w] set @value [expr $@val*$span/($l-1)/100] #set t [expr $@val * [$self slider_ratio] * 0.01] #set @value [expr $@min*exp($t)] } def Slider init {mess} { super $mess set @oposition $@min $self update_value } def Slider bbox {} { mset {x1 y1} [$self xy] if {!$@orient} { list [expr {$x1-3}] $y1 [expr {$x1+$@w+2}] [expr {$y1+$@h}] } else { list $x1 [expr {$y1-2}] [expr {$x1+$@w}] [expr {$y1+$@h+3}] } } #the value/centipixel ratio def Slider slider_ratio {} { set diff [expr $@is_log ? log($@max/$@min) : ($@max-$@min)] return [expr $diff / ($@orient ? ($@h-1) : ($@w-1))] } def Slider draw_knob {} { mset {x1 y1} [$self xy] set l [expr $@orient ?$@h:$@w] set span [expr {$@max-$@min}] set scaled [expr {$@value*($l-1)/$span}] if {$@orient} { set y1 [expr $y1+2] set y [expr $y1+$@h-$scaled-2] set coords [list [expr {$x1+2}] [expr {$y-1}] [expr {$x1+$@w-2}] [expr {$y+1}]] } else { set x1 [expr $x1-1] set x [expr $x1+$scaled] set coords [list $x [expr {$y1+2}] [expr {$x+2}] [expr {$y1+$@h-2}]] } $self item KNOB rectangle $coords -outline red -fill [darker [$self look bg]] } def Slider draw {} { mset {x1 y1 x2 y2} [$self bbox] #if {$@orient} {set y1 [expr $y1-2]} {set x1 [expr $x1-2]} #if {$@orient} {set ys [expr $@h+5]} {set xs [expr $@w+5]} super $self draw_knob $self update_value } # not used def Slider draw_notches {} { if {$@orient} { set thick [clip [expr $xs/3] 1 5] set x3 [expr $x1+$xs-$thick/2-2] set eighth [expr round($ys/8-1)] set coords [list $x3 $y1 $x3 [expr $y1+$ys]] } else { set thick [clip [expr $ys/3] 1 5] set y3 [expr $y1+$ys-$thick/2-2] set eighth [expr $xs/8] set coords [list $x1 $y3 [expr $x1+$xs] $y3] } # there were supposed to be 7 notches... i don't remember what happened here. $@canvas item NOTCH $coords -dash [list 1 $eighth 1 $eighth] -width $thick -fill [darker [$self look bg]] } def Slider click {x y f target} { set canvas [$self get_canvas] mset {type id detail} [$canvas identify_target $x $y $f] if {$type == "label"} {return} $canvas focus= $self set @click_at [list $x $y] set @rate [expr $f&1 ? 0.01 : 1.00] if {!$@steady} { mset {x1 y1 x2 y2} [$self bbox] set t [expr [$self calc $x $y $x1 $y2]*$@rate] set @value [expr $@is_log ? [expr $@min*exp($t*[$self slider_ratio])] : $t] set @oposition $t netsend [list .$self float $@value] } else {set @oposition $@value} } def Slider unclick {x y f target} { ### keep focus if only clicked. do we want that feature? # if {[distance $@click_at [list $x $y]] == 0} {return} set canvas [$self get_canvas] $canvas focus= "" } def Slider motion {x y f target} { set canvas [$self get_canvas] set focused [$self == [$canvas focus]] if {!$focused} {return} mset {clx cly} $@click_at set d [$self calc $x $y $clx $cly] set t ($@oposition+$d*$@rate) set value [expr $@is_log ? [expr $@min*exp($t*[$self slider_ratio])] : $t] set out [clip $value $@min $@max] netsend [list .$self float $out] } def Slider key_incr {val1 val2} { set @value [expr {$@value-$val2}] netsend [list .$self float $@value] } def Slider calc {x y x1 y1} { set span [expr {$@max-$@min}] set l [expr {$@orient ?$@h:$@w}] set d [expr {($@orient ?$y1-$y:$x-$x1)*$span/($l+0.0)}] return $d } def Slider unfocus {} {$self draw} class_new Labelled {} def Labelled draw {} { super mset {lx ly} [$self label_xy] set label $@lab; switch -- $label {empty {set label ""} - {set label ""}} set lfont [$self label_font] set lcolor [parse_color [$self label_color]] if {$::leet} { set text [string map -nocase {a 4 e 3 t 7 s 5 i 1 o 0 g 9} $label] } else { set text $label } $self item LABEL text [list $lx $ly] -text $text -anchor [$self label_anchor] -font $lfont -fill $lcolor } def Labelled label_xy {} {mset {x1 y1} [$self xy]; list [expr {$x1+$@ldx}] [expr {$y1+$@ldy}]} def Labelled label_anchor {} {return w} def Labelled label_font {} {list [lindex {courier helvetica times} $@fstyle] $@fs bold} def Labelled label_color {} {return $@lcol} #-----------------------------------------------------------------------------------# class_new Bang {BlueBox} def Bang init {mess} { super $mess set @flash 0 set @count 0 } def Bang bbox {} { mset {x1 y1} [$self xy] list $x1 $y1 [expr {$x1+$@w}] [expr {$y1+$@w}] } def Bang draw {} { super mset {x1 y1 x2 y2} [$self bbox] set rect [list [expr {$x1+1}] [expr {$y1+1}] [expr {$x2-1}] [expr {$y2-1}]] if {$@flash} { #$self item BUT oval $rect -fill [parse_color $@fcol] set fcol [] set bcol [] $self item BUT oval $rect -fill $fcol after 100 [list $self item BUT oval $rect -fill $bcol] set @flash 0 } else { set colour [parse_color $@bcol] $self item BUT oval $rect -fill $colour -outline [$self look frame3] } } def Bang unclick {x y f target} {} def Bang click {x y f target} {netsend [list .$self bang]} def Bang bang {count} {set @count $count; set @flash 1} def Bang key_incr {val1 val2} {netsend [list .$self bang]} class_new Toggle {BlueBox} def Toggle bbox {} { mset {x1 y1} [$self xy] list $x1 $y1 [expr $x1+$@w] [expr $y1+$@w] } def Toggle draw {} { super mset {x1 y1 x2 y2} [$self bbox] set colour [parse_color $@bcol] set t [expr {int(($@w+29)/30)}] set fill $colour set x3 [expr {$x1+$t+2}]; set y3 [expr {$y1+$t+2}] set x4 [expr {$x2-$t-2}]; set y4 [expr {$y2-$t-2}] if {$@on} { set fill [parse_color $@fcol] } { set fill [parse_color $@bcol] } $self item X1 line [list $x3 $y3 [expr {$x4+1}] [expr {$y4+1}]] -width $t -fill $fill $self item X2 line [list $x3 $y4 [expr {$x4+1}] [expr {$y3-1}]] -width $t -fill $fill } def Toggle unclick {x y f target} {} def Toggle click {x y f target} { if {!$@on} {set @on 1} {set @on 0} netsend [list .$self float $@on] $self changed } class_new Vu {Labelled IEMGUI Box} set vu_col { 0 17 16 16 16 16 16 16 16 16 16 16 16 16 16 16 16 15 15 15 15 15 15 15 15 15 15 14 14 13 13 13 13 13 13 13 13 13 13 13 19 19 19 } def Vu init {mess} { super $mess set @value 0 set @peak 0 } def Vu bbox {} { mset {x1 y1} [$self xy] list $x1 $y1 [expr $x1+$@w] [expr $y1+$@h] } def Vu led_size {} { set n [expr $@h/40] if {$n < 2} {set n 2} return [expr $n-1] } def Vu draw {} { global vu_col mset {x1 y1 x2 y2} [$self bbox] set colour [parse_color $@bcol] super $self draw_io set led_size [$self led_size] set x3 [expr $x1+$@w/4] set x4 [expr $x2-$@w/4] $self item BASE rectangle [list $x1 $y1 $x2 $y2] -width 0 -fill $colour for {set i 1} {$i<=40} {incr i} { set y [expr $y1 + ($led_size+1)*(41-$i) - ($led_size+1)/2] $self item RMS${i} rectangle [list $x3 $y $x4 [expr $y+$led_size]] \ -fill [parse_color [lindex $vu_col $i]] -width 0 } #if {!$@zoom} {return} set lfont [list [lindex {courier helvetica times} $@fstyle] $@fs bold] set lcolor [parse_color $@lcol] set i 0 foreach level { <-99 -50 -30 -20 -12 -6 -2 -0dB +2 +6 >+12 } { set k1 [expr $led_size+1] set k2 41 set k3 [expr $k1/2] set k4 [expr $y1-$k3] set yyy [expr $k4 + $k1*($k2-4*$i)] $self item SCALE{$level} text [list [expr $x2+4] [expr $yyy+$k3-3]] \ -text $level -anchor w -font $lfont -fill $lcolor incr i } set y [expr $y1 + ($led_size+1)*(41-$@value) - ($led_size+1)/2] $self item MASK rectangle [list $x3 $y1 $x4 $y] -width 0 -fill $colour set c [lindex $vu_col [expr int($@peak)]] set y [expr $y1 + ($led_size+1)*(41-$@peak) - ($led_size+1)/2] $self item PEAK rectangle [list $x1 $y $x2 [expr $y+$led_size]] -fill [parse_color $c] -width 0 } def Vu rms= {rms } {set @value $rms; $self changed rms} def Vu peak= {peak} {set @peak $peak; $self changed peak} def Vu set {i j} { set @value $i set @peak $j $self changed } if {![catch { package require tkdnd dnd bindtarget . text/uri-list <Drop> {open_file %D} }]} { puts "warning: tkdnd package not found" } class_new Cnv {Labelled IEMGUI Box} def Cnv draw {} { mset {x1 y1} [$self xy] $self item BASE rectangle [list $x1 $y1 [expr {$x1+$@w+1}] [expr {$y1+$@h+1}]] -fill [parse_color $@bcol] -width 0 super } def Cnv bbox {} { mset {x1 y1} [$self xy] return [list $x1 $y1 [expr $x1+$@w] [expr $y1+$@h]] } class_new Array {Box} def Array init {mess} { super $mess set @name [lindex $mess 2] set @length 0 set @data {} set @draw 0 } def Array bbox {} { return {0 0 1 1} ;# huh? } def Array draw_name {} { mset {x_off y_off} [$@canvas xy] $self item TEXT text [lmap + [list $x_off $y_off] 2] \ -font [View_look $self font] -text $@name \ -fill [View_look $self fg] -anchor nw } def Array draw {} { $self draw_name mset {x_off y_off} [$@canvas xy] set m [$@canvas get_mess] mset {xfrom yto xto yfrom pixwidth pixheight} $m if {[winfo exists [$@canvas widget]]} { mset {c_width c_height} [$@canvas get_dimen] set width [expr $c_width / $@length] set i 0 foreach val $@data { if {!$val} {set val 0.0} set y [expr $c_height - (((double($val)+abs($yfrom))/($yto-$yfrom) * $c_height))] set x1 [expr $width * $i] set x2 [expr $x1 + $width] set line [list $x1 $y $x2 $y] $self item elem${i} line $line -fill [$@canvas look compfg] -width 2 -tags "$self ${self}elem${i}" #.$self.c raise ${self}elem${i} incr i } } else { set width [expr $pixwidth / $@length] set canvas [$self get_canvas] set i 0 foreach val $@data { if {!$val} {set val 0.0} #set val2 [lindex $@data [expr $i+1]] set y [expr ($pixheight - ((double($val)+abs($yfrom))/($yto-$yfrom) * $pixheight)) + $y_off] #set y2 [expr ($pixheight - ((double($val2)+abs($yfrom))/($yto-$yfrom) * $pixheight)) + $y_off] set x1 [expr ($width * $i) + $x_off] set x2 [expr $x1 + $width] set line [list $x1 $y $x2 $y] $self item ${self}ELEM${i} line $line -fill [$self look fg] -width 2 incr i } [$canvas widget] raise $self #set width [expr $pixwidth / [expr $@length-1]] #set canvas [$self get_canvas] #set i 0 #for {set i 0} {$i < [expr $@length-1]} {incr i} { # #if {!$val} {set val 0.0} # set val [lindex $@data [expr $i]] # set val2 [lindex $@data [expr $i+1]] # set y [expr ($pixheight - ((double($val)+abs($yfrom))/($yto-$yfrom) * $pixheight)) + $y_off] # set y2 [expr ($pixheight - ((double($val2)+abs($yfrom))/($yto-$yfrom) * $pixheight)) + $y_off] # set x1 [expr ($width * $i) + $x_off] # set x2 [expr $x1 + $width] # set line [list $x1 $y $x2 $y2] # $self item ${self}ELEM${i} line $line -fill [$self look fg] -width 0 #} } } def Array click {x y f target} { if {[winfo exists [$@canvas widget]]} {set canvas $@canvas} else {set canvas [$@canvas canvas]} $canvas focus= $self set @draw 1 } def Array unclick {x y f target} { if {[winfo exists [$@canvas widget]]} {set canvas $@canvas} else {set canvas [$@canvas canvas]} $canvas focus= "" set @draw 0 } def Array motion {x y f target} { if {!$@draw} return if {[winfo exists [$@canvas widget]]} { mset {c_width c_height} [$@canvas get_dimen] mset {xfrom yto xto yfrom pixwidth pixheight} [$@canvas get_mess] set width [expr $c_width / $@length] set i [format %d [expr int($x/$width)]] set x1 [expr $width * $i] set x2 [expr $x1 + $width] set line [list $x1 $y $x2 $y] set val [expr (($c_height-$y)/$c_height) * ($yto-$yfrom) + $yfrom] netsend [list .$self $i $val] } else { mset {xfrom yto xto yfrom pixwidth pixheight} [$@canvas get_mess] mset {x_off y_off} [$@canvas xy] set width [expr $pixwidth / $@length] set i [format %d [expr int(($x-$x_off)/$width)]] set val [expr (($pixheight-$y+$y_off)/$pixheight) * ($yto-$yfrom) + $yfrom] netsend [list .$self $i $val] } } def Array length= {val} {set @length [format %f $val]} def Array name= {val} {set @name $val} def Array array_set {data_list} { if {[llength $data_list] == $@length} { set @data {} for {set i 0} {$i < $@length} {incr i} { lappend @data [lindex $data_list $i] } } else { puts "error..." } } ############ evaluator class_new Listener {Thing} def Listener init {serf name command} { set @history [History new 20] set @command $command set @expanded 0 set @serf $serf set font $::look(View:font) frame $serf pack [frame $serf.1] -side left -fill y pack [frame $serf.1.1] -side bottom pack [button $serf.1.1.expander -image icon_plus -command "$self toggle_expand"] -side left pack [label $serf.1.1.label -width 11 -font $font -text "$name: "] -side left pack [entry $serf.entry -width 40 -font $font] -side left -fill x -expand yes pack $serf -fill x -expand no bind $serf.entry <Up> "$self scroll_history +1" bind $serf.entry <Down> "$self scroll_history -1" bind $serf.entry <Return> "$self eval" } def Listener toggle_expand {} { set @expanded [expr 1-$@expanded] if {$@expanded} {$self expand} {$self unexpand} } def Listener expand {} { set e $@serf.entry set text [$e get] destroy $e pack [text $e -width 40 -height 8] -side left -fill x -expand yes $e insert 0.0 $text $@serf.1.1.expander configure -image icon_minus bind $e <Alt-Return> "$self eval" } def Listener unexpand {} { set e $@serf.entry set text [$e get 0.0 end] regsub "\n$" $text "" text destroy $e pack [entry $e -width 40] -side left -fill x -expand yes $e insert 0 $text $@serf.1.1.expander configure -image icon_plus bind $e <Up> "$self up" bind $e <Down> "$self down" bind $e <Return> "$self eval" } def Listener replace {stuff} { $@serf.entry delete 0 end $@serf.entry insert 0 $stuff $@serf.entry icursor end } def Listener scroll_history {incr} { if {![$@history histi]} {$@history set_hist 0 [$self get_command]} $self replace [$@history traverse $incr] } def Listener append {v} { $@history prepend $v lappend @hist $v; set @histi [llength $@hist] } def Listener get_command {} { set e $@serf.entry if {$@expanded} { set l [$e get 0.0 end]; return $l } else { set l [$e get]; return $l } } def Listener eval {} { set e $@serf.entry $@history histi= 0 set l [$self get_command] $self append $l if {$@expanded} {$e delete 0.0 end} {$e delete 0 end} $@command $self $l } proc tcl_eval {self l} {post %s "tcl: $l"; post %s "returns: [uplevel [info level] $l]"} proc pd_eval {self l} {post %s "pd: $l"; netsend $l} proc canvas_eval {self l} {post %s "tcl: $l"; post %s "returns: [uplevel [info level] [join [list [$self canvas] $l]]]"} ############ button bar set butt { {ObjectBox Object {obj}} {MessageBox Message {msg}} {FloatBox Number {floatatom}} {SymbolBox Symbol {symbolatom}} {CommentBox Comment {text}} {bng bng {obj bng}} {tgl tgl {obj tgl}} {nbx nbx {obj nbx}} {vsl vsl {obj vsl}} {hsl hsl {obj hsl}} {vradio vradio {obj vradio}} {hradio hradio {obj hradio}} {vu vu {obj vu}} {cnv cnv {obj cnv}} {Graph graph {graph}} {Array array {menuarray 0}} } proc button_bar_add {x y} {lappend ::butt [list $x $y noload]} if {$tk} { set dir $cmdline(icons) foreach icon {mode_edit mode_run pd_32} {image create photo icon_$icon -file $dir/$icon.gif} foreach b $butt {mset {icon name cmd} $b; image create photo icon_$icon -file $dir/$icon.gif} } class_new ButtonBar {View} def ButtonBar init {canvas} { set @canvas $canvas set bb .$@canvas.bbar frame $bb pack [button $bb.edit -image icon_mode_edit -border 1 -command [list $@canvas editmodeswitch]] -side left foreach e $::butt { mset {icon name cmd} $e pack [button $bb._$name -image icon_$icon -border 1 -command "$@canvas new_object $cmd"] -side left balloon $bb._$name [say $name] } pack [entry $bb.name -font {helvetica -12} -width 8 -border 0] -side right pack [spinbox $bb.scale -width 5 -command "$canvas zooming %d" -state readonly] -side right $bb.scale set [format %d%% [expr int(100*[$@canvas zoom])]] $bb.name insert 0 $@canvas } def ButtonBar widget {} {return .$@canvas.bbar} proc obj_create {c flag} {} ############ crosshair class_new Crosshair {View} def Crosshair classtags {} {return {}} def Crosshair init {canvas} { super set @canvas $canvas $self data= 0 0 {none} } def Crosshair data= {x y target} { set @x $x set @y $y set @target $target } def Crosshair draw {} { mset {type id detail} $@target set x $@x; set y $@y if {[$@canvas look hairsnap]} { switch -regexp -- $type {^object|outlet|inlet$ {mset {x y x3 y3} [$id bbox]}} } mset {x1 y1 x2 y2} [$self display_area] set h1 [list $x1 $y $x2 $y] set v1 [list $x $y1 $x $y2] $self item VHAIR1 line $v1 -fill [$@canvas look crosshair] -width 1 -dash {4 4 4 4} $self item HHAIR1 line $h1 -fill [$@canvas look crosshair] -width 1 -dash {4 4 4 4} } #def Crosshair erase {} {$self item_delete VHAIR1; $self item_delete HHAIR1} class_new Sense {View} def Sense init {canvas} { super set @canvas $canvas $self data= 0 0 0 red } def Sense data= {x y range col} { set @x $x set @y $y set @range $range set @col $col } def Sense flash {x y sense col} { $self data= $x $y $sense $col $self draw after 500 $self erase } def Sense draw {} { set c [$@canvas widget] set x1 [expr $@x-$@range]; set y1 [expr $@y-$@range] set x2 [expr $@x+$@range]; set y2 [expr $@y+$@range] $self item SENSE oval [list $x1 $y1 $x2 $y2] -fill $@col -outline yellow } def View display_area {} { set c [$@canvas widget]; set z [$@canvas zoom] set edge 10 set x1 [expr {int([$c canvasx $edge]/$z)}] set y1 [expr {int([$c canvasy $edge]/$z)}] set x2 [expr {int(([$c canvasx [winfo width $c]]-$edge)/$z)}] set y2 [expr {int(([$c canvasy [winfo height $c]]-$edge)/$z)}] return [list $x1 $y1 $x2 $y2] } class_new Grid {View} def Grid init {canvas} { super set @canvas $canvas set c [$@canvas widget] set @width [winfo width $c] set @height [winfo height $c] set @size [$@canvas look grid_size] set @col [$@canvas look grid] set @gap 5 } def Grid classtags {} {return {}} def Grid update {h w} {set @width $w; set @height $h} def Grid size= {size} {set @size $size} def Canvas snap_grid {} {return [$self look snap_grid]} def Canvas snap_grid= {val} {set ::look(Canvas:snap_grid) $val} def Canvas snap_objs2grid {} { if {![$self editmode]} {return} foreach obj [$@objects values] { mset {x y} [$obj xy] set grid [$self look grid_size] set x [expr floor($x/$grid)*$grid] set y [expr floor($y/$grid)*$grid] $obj moveto $x $y } } def Grid draw {} { mset {x1 y1 x2 y2} [$self display_area] set c [$@canvas widget] set lowest [$@canvas lowest_item] $self draw_lines $x1 $x2 $y1 $y2 VL $self draw_lines $y1 $y2 $x1 $x2 HL if {$lowest != -1} {$c lower $self $lowest} } def Grid draw_lines {v1 v2 v3 v4 tag} { set s $@size; set g $@gap for {set i $v1} {$i < $v2} {incr i} { #if {$l%$g == 0} {set width 1;set dash [list 7 1]} {set width 1;set dash [list 1 4 1 4]} if {![expr {$i % int($s*$g)}]} {set w 1;set d [list 7 1]} {set w 1;set d [list 1 4 1 4]} if {![expr {$i % int($s)}]} { switch $tag {VL {set line [list $i $v3 $i $v4]} HL {set line [list $v3 $i $v4 $i]}} $self item ${tag}$i line $line -fill $@col -width $w -dash $d } } } def Canvas lowest_item {} { set c [$self widget] set all [$c find withtag foo] if {![llength $all]} {return -1} set lowest [lindex [$c gettags [lindex $all 0]] 0] return $lowest } #def Canvas grid_size {} {return [$self look grid_size]} def Canvas grid_size= {size} { set ::look(Canvas:grid_size) $size if {[$self editmode]} {$@grid size= $size; $@grid erase; after 0 $@grid draw} } ############ tooltips (only those that are drawn as canvas items) class_new Tooltip {View} def Tooltip init {canvas pos curpos text type iserror} { set @canvas $canvas set @pos $pos set @curpos $curpos set @text $text set @type $type set @iserror $iserror } def Tooltip iserror {} {return $@iserror} def Tooltip curpos {} {return $@curpos} def Tooltip text {} {return $@text} def Tooltip draw {} { set c [$@canvas widget] if {$@iserror} { set fg "#ffffff"; set bg "#dd0000" } else { set fg "#000000"; set bg "#ffffcc" } mset {x y} $@pos switch -- $@type { o {set ny [expr {$y+24}]} i {set ny [expr {$y-24}]} } $self item TEXT text [list [expr $x+12] $ny] -fill $fg -text $@text -anchor sw -width 300 mset {x1 y1 x2 y2} [l+ [$c bbox ${self}TEXT] [list -4 -4 +4 +4]] switch -- $@type { o {set coords [list $x1 $y1 [expr $x1+8] $y1 $x $y [expr $x1+16] $y1 $x2 $y1 $x2 $y2 $x1 $y2 $x1 $y1]} i {set coords [list $x1 $y1 $x2 $y1 $x2 $y2 [expr $x1+16] $y2 $x $y [expr $x1+8] $y2 $x1 $y2 $x1 $y1]} } $self item RECT polygon $coords -fill $bg -outline $fg $c lower ${self}RECT ${self}TEXT } # $c delete tooltip_bg tooltip_fg set tooltip "" def Canvas show_tooltip {x y text type {iserror 0}} { global tooltip if {$tooltip ne "" && [$tooltip text] eq $text} {return} if {$tooltip ne ""} {$tooltip delete} set tooltip [Tooltip new $self [list $x $y] $@curpos $text $type $iserror] $tooltip draw } ############ class browser # future use, maybe: #class_new ServerClassDict {Observable Thing} #def ServerClassDict init {} {} # Completion/Browser init can be cleaned up a bit more, do it later... class_new ClassBrowser {Dialogue} class_new Browser {ClassBrowser} def Browser init {name x y textbox} {super $name $x $y $textbox} class_new Completion {ClassBrowser} def Completion init {name x y textbox} {super $name $x $y $textbox} def Completion cancel {} { bind $@textbox <Key> "$@textself key_input %W %x %y %K %A 0" bind $@textbox <Control-Return> "$@textself key_input %W %x %y 10 %A 0" bind $@textbox <Return> "$@textself unedit" bind $@textbox <Tab> "$@textself key_input %W %x %y %K %A 0" focus $@textbox $self delete } def ClassBrowser delete {} {set @exist 0; super} def ClassBrowser init {name x y textbox} { set @name $name set @width 0 set @height 0 # so that in completion mode, it know which textbox to switch the focus to set @textbox $textbox netsend [list pd update-path] netsend [list pd update-class-list $self list_callback] } def ClassBrowser fill_box {s} { $@listbox delete 0 end foreach class [lsort $::class_list] { if {[string length $s]==0 || [string first $s $class]>=0} { set t "\[$class\]" if {[can_say $class]} {append t " [say $class]"} $@listbox insert end $t #if {[string length $t] > [string length $@width]} {set @width [string length $t]} if {[string length $t] > $@width} {set @width [string length $t]} } } set none [say no_matches] if {![$@listbox size]} {$@listbox insert 0 $none; set @width [string length $none]} $@listbox selection set 0 0 } def Completion fill_box {s} { super $s wm maxsize .$self [winfo reqwidth .$self.comp] [winfo reqheight .$self.comp] } def Browser fill_box {s} { super $s .$self.title configure -text [format [say how_many_object_classes] [$@listbox size] [llength $::class_list]] } proc search_for_externs {} { foreach dir $::pd_path { catch { #set xs [glob "$dir/*.pd*"] set xs [glob "$dir/*.pd_*"] foreach x $xs { set fn [lindex [file split $x] end] set fn [join [lrange [split $fn .] 0 end-1] .] lappend ::class_list $fn } } } } def ClassBrowser info {listbox} { set class [$self current_class] if {$class != ""} {netsend [list pd update-class-info $class $self info_callback]} } def Browser list_callback {} { search_for_externs set class_list [luniq [lsort $::class_list]] toplevel .$self set f .$self.cl pack [frame $f] -side top -fill both -expand yes pack [label .$self.title -text ""] -side top listbox $f.1 -width 50 -height 20 -yscrollcommand "$f.2 set" -activestyle none scrollbar $f.2 -command "$f.1 yview" text $f.3 -width 30 -height 20 -yscrollcommand "$f.4 set" scrollbar $f.4 -command "$f.3 yview" set @listbox $f.1 frame $f.5 button $f.5.help -text [say help] -command [list $self help] pack $f.5.help -side top pack $f.5 -side left -fill y -expand no pack $f.1 -side left -fill both -expand yes pack $f.2 -side left -fill y -expand no pack $f.3 -side left -fill both -expand yes pack $f.4 -side left -fill y -expand no set b .$self.butt frame $b pack [label $b.1 -text [say filter]] -side left pack [entry $b.2 -width 15] -side left pack [button $b.close -text [say close] -command "destroy .$self"] -side right pack $b -side bottom -fill x -expand no set @textbox $b.2 $self fill_box "" #bind $f.1 <Button-1> "after 1 \"$self info $f.1 \"" foreach w [list $f.1 $b.2] { bind $w <KeyPress> "after 1 \"$self key %K 0\"" bind $w <Shift-KeyPress> "after 1 \"$self key %K 1\"" bind $w <Return> [list $self help] } focus $@textbox } def Browser help {} { set f .$self.cl netsend [list pd help [$self current_class]] } def Completion list_callback {} { search_for_externs set class_list [luniq [lsort $::class_list]] toplevel .$self wm protocol .$self WM_DELETE_WINDOW "$self cancel" wm overrideredirect .$self 1 set canvas $@name set f .$self.comp set @listbox $f set @rootx [winfo rootx .$@name.c] set @rooty [winfo rooty .$@name.c] set @max [wm maxsize .$self] if {[regexp {(x[0-9a-z]{6,8})text$} $@textbox dummy textself]} {set @textself $textself} if {[$canvas look showcomp] <= 20} {set @height [$canvas look showcomp]} else {set @height 20} listbox $f -width $@width -height $@height -relief flat -activestyle dotbox -font $::look(View:font) \ -bg [$@textself look bg] -selectbackground [$@textself look fg] \ -fg [$@textself look fg] -selectforeground [$@textself look bg] $self adjust_box bind $f <Button-1> "after 1 \"$self complete\"" bind $f <Return> "after 1 \"$self complete\"" bind $f <KeyPress> "$self key %K 0" bind $f <Shift-KeyPress> "$self key %K 1" bind $@textbox <Tab> "$self key %K; break" bind $@textbox <KeyPress> "$self key %K " focus .$self.comp } def Completion adjust_box {} { mset {x1 y1 x2 y2} [lmap * [$@textself bbox] [$@name zoom]] set x1 [format %0.f $x1];set y1 [format %0.f $y1] set x2 [format %0.f $x2];set y2 [format %0.f $y2] $self fill_box [$@textbox get 1.0 1.end] set f .$self.comp $f configure -width $@width set box_width [winfo reqwidth $f] set box_height [winfo reqheight $f] pack $f -side left -expand yes .$self configure -width $box_width .$self configure -height $box_height #test the right edge of the screen, assuming the left edge has enough space if {[expr $x1+$@rootx+$box_width] < [lindex $@max 0]} { set box_x [expr $x1+$@rootx] } else { set box_x [expr $x2 - $box_width + $@rootx] } #test the lower edge of the screen, assuming the upper edge has enough space if {[expr $y2+$@rooty+$box_height] < [lindex $@max 1]} { set box_y [expr $y2 + 5 + $@rooty] } else { set box_y [expr $y1 - $box_height - 2 + $@rooty] } wm geometry .$self [winfo reqwidth .$self]x[winfo reqheight .$self]+$box_x+$box_y } def ClassBrowser current_class {} { set i [$@listbox curselection] if {$i == ""} {return {}} return [string range [lindex [$@listbox get $i] 0] 1 end-1] } def ClassBrowser complete {} { if {[regexp {x([0-9a-z]{6,8})text$} $@textbox obj]} { set cut [string first "text" $obj] set obj [string range $obj 0 [expr $cut -1]] } set class [$self current_class] $@textbox delete 1.0 1.end $@textbox insert 1.0 $class $obj unedit destroy .$self } def ClassBrowser key {key {shift 0}} { switch -regexp -- $key { Up|Down { if {[focus] != $@listbox} { focus $@listbox event generate $@listbox <KeyPress> -keysym $key } else { if {$self == "browser"} {$self info $@listbox} } } Escape {after 1 "$self cancel"} ;# doesn't really work Tab { focus $@listbox set next [$@listbox index active] incr next if {$next >= [$@listbox size]} {set next 0} $@listbox activate $next $@listbox selection clear 0 [expr [$@listbox size] - 1] $@listbox selection set $next $next #if {$next >= [expr $@height - 1]} {$@listbox yview scroll 1 units} $@listbox see $next if {$self == "browser"} {$self info $@listbox} } BackSpace { if {[focus] == $@listbox} {focus $@textbox} #classbrowser uses entry as input widget, where as completion is text widget... switch $self { browser {$self fill_box [$@textbox get]} completion {$self adjust_box; $@textself resize; $@textself changed} } } default { $self key_default $key } } } def Browser key_default {key} { if {[focus] == $@listbox} { if {[regexp {^[a-zA-Z0-9~/\._]{1}$} $key]} { .$self.butt.2 insert end $key $self fill_box [$@textbox get] } } else {$self fill_box [$@textbox get]} } def Completion key_default {key} { if {[focus] == $@listbox} { if {[regexp {^[a-zA-Z0-9~/\._]{1}$} $key]} { $@textbox insert 1.end $key $@textself after_key $@textbox $self adjust_box focus $@textbox } } if {[focus] == $@textbox & $key != "Tab"} { $self adjust_box $@textself resize #hum, no idea why i need after 1 for it to work... after 1 $@textself after_key $@textbox } } def ClassBrowser info_callback {class} { global class_info set f .browser.cl set class [$self current_class] $f.3 delete 0.0 end $f.3 insert end "class $class\n" foreach {k v} $class_info($class) {$f.3 insert end "$k=\"$v\"\n"} } def TextBox propose_completions {} { set c [$@canvas widget] set widget $c.${self}text set propose $c.${self}propose #$propose configure -state normal if {![info exists ::class_list]} { netsend [list pd update-class-list $self propose_completions] return } set r {} set c {} set n 0 set prev "" foreach class [luniq [lsort $::class_list]] { if {[string length $@text]==0 || [string first $@text $class]>=0} { if {[string compare [say $class] "{{$class}}"]} { lappend r "$class : [say $class]" } { lappend r $class } lappend c $class incr n } if {$n > 16} {lappend r ...; break} } set r [join $r "\n"] mset {x1 y1 x2 y2} [$self bbox] set @action [Completion new_as completion $@canvas $x1 $y1 $widget] } ############ properties_dialog ######### proc change_entry {self val} { set v [expr [$self get]+$val] $self delete 0 end $self insert 0 $v } class_new Dialogue {View} def Dialogue add_stuff {f name label} { frame $f # frame $f.label -width $@label_width -borderwidth 2 # pack [button $f.label.0 -image "icon_empty" -width $@label_width] -side left # place [message $f.label.1 -text $label -width $@label_width] -x 0 -y 0 # puts [$f.label.1 cget -height] pack [label $f.label -text $label -width [expr $@label_width/7] -wraplength $@label_width -anchor e] -side left balloon $f.label $name } def Dialogue add_side {f name label} { $self add_stuff $f $name $label frame $f.side -relief ridge -borderwidth 2 foreach {i side} {0 left 1 right 2 top 3 bottom} { radiobutton $f.side.$side -value $i -variable @$name -text $side } pack $f.side.left -side left -fill y pack $f.side.right -side right -fill y pack $f.side.top -side top pack $f.side.bottom -side bottom pack $f.side -side left } def Dialogue add_color {f name label} { $self add_stuff $f $name $label set v $@$name set text_color [complement $v] button $f.color -text $v -font {Courier 10} -width 10 -pady 2 -fg $text_color \ -command [list $self choose_col $f $name $v] -relief sunken -background $v -highlightbackground $v -activebackground $v button $f.preset -text [say "preset"] -pady 2 -font {Helvetica 8} \ -command [list $self color_popup $f $name 10] bind $f.preset <Return> "$self color_popup $f $name 10" pack $f.color $f.preset -side left } def Dialogue add_choice {f name label choices} { $self add_stuff $f $name $label menu $f.menu -tearoff 0 set i 0 foreach part $choices { $f.menu add command -label [say $part] -command [list $self dropmenu_set $f $name $part $i] incr i } set trim_name [string trimleft $name "-"] set _($self:${name}choices) $choices set choice $@$name if {[string is integer $choice]} {set choice [lindex $choices $choice]} label $f.butt -text [say $choice] -relief raised -width 20 balloon $f.butt "click to change setting" pack $f.label $f.butt -side left bind $f.butt <1> [list $self dropmenu_open $f $name] } def Dialogue add_key {f name label} { set text "" set n 0 foreach item $name { if {$n != 0} {append text " & " [say $item]} else {set text [say $item]} incr n } $self add_stuff $f $name $text #balloon $f.label $name foreach item $name { set v $_($self:$item) ;# bug in objtcl set item_lower [string tolower $item] entry $f.$item_lower -width 15 -textvariable @$item pack $f.$item_lower -side left } } def Dialogue add_folders {f name label} { $self add_stuff $f $name $label set v $_($self:$name) ;# bug in poetcl frame $f.a listbox $f.a.list -width 40 -height 8 -yscrollcommand "$f.a.yscroll set" \ -activestyle none -xscrollcommand "$f.a.xscroll set" foreach line $v {$f.a.list insert end $line} set @$name $f.a.list ;# save the listbox path at @$name instead scrollbar $f.a.yscroll -command "$f.a.list yview" scrollbar $f.a.xscroll -command "$f.a.list xview" -orient horizontal pack $f.a.xscroll -side bottom -fill x pack $f.a.list -side left -fill both -expand 1 pack $f.a.yscroll -side left -fill y pack $f.a -side left frame $f.b -borderwidth 0 foreach {cmd lab} {dir_add add listbox_remove remove listbox_up up listbox_down down} { pack [button $f.b.$cmd -command "$self $cmd $f.a.list" -text [say $lab] -width 6] -side top balloon $f.b.$cmd [say dir_$lab] } pack $f.b -side top } def Dialogue add_libraries {f name label} { $self add_stuff $f $name $label set v $_($self:$name) ;# bug in poetcl. is it still there? frame $f.a listbox $f.a.list -width 32 -height 16 -yscrollcommand "$f.a.yscroll set" \ -activestyle none -xscrollcommand "$f.a.xscroll set" #foreach line $@$name {$f.a.list insert end $line} foreach line $v {$f.a.list insert end $line} # save the listbox path at @$name instead set @$name $f.a.list pack [scrollbar $f.a.yscroll -command "$f.a.list yview"] -side right -fill y pack $f.a.list -side top -fill both -expand 1 pack [scrollbar $f.a.xscroll -command "$f.a.list xview" -orient horizontal] -side bottom -fill x pack $f.a -side left frame $f.b -borderwidth 0 pack [entry $f.b.entry -width 15 -borderwidth 5 -relief ridge] -side top bind $f.b.entry <Return> "$self lib_add $f.a.list" foreach {cmd lab} {lib_add add listbox_remove remove listbox_up up listbox_down down} { pack [button $f.b.$cmd -command "$self $cmd $f.a.list" -text [say $lab] -width 6] -side top #balloon $f.b.$cmd [say dir_$lab] } pack $f.b -side top } def Dialogue dir_add {listbox} { set dir [tk_chooseDirectory -initialdir ~ -title "Choose a folder" -parent .$self] if {$dir == ""} {return} $listbox insert end $dir $listbox yview end focus .$self } # doesn't work with toplevel widget proc upwidget {levels name} { set l [split $name .] return [join [lrange $l 0 end-$levels] .] } def Dialogue lib_add {f} { set f [upwidget 2 $f] set listbox $f.a.list set entry $f.b.entry set var [$entry get] if {$var != ""} {$listbox insert end $var} $listbox yview end $entry delete 0 end focus $entry } def Dialogue listbox_remove {listbox} { set sel [$listbox curselection] if {$sel == ""} {return} $listbox delete $sel $listbox selection set $sel } def Dialogue listbox_swap {listbox dir} { set sel [$listbox curselection] if {$sel == ""} {return} if {![inside [expr $sel+$dir] 0 [$listbox size]]} {return} set line [$listbox get $sel] $listbox delete $sel incr sel $dir $listbox insert $sel $line $listbox selection set $sel $listbox see $sel } def Dialogue add_devlist {f name label} { $self add_stuff $f $name $label menu $f.menu -tearoff 0 set i 0 set trim_name [string trimleft $name "-"] set part none ;# in case there are none foreach part $@$trim_name { $f.menu add command -label $part -command [list $self dropmenu_set $f $name $part $i] incr i } #label $f.butt -text [lindex $@$trim_name 0] -relief raised -width 20 label $f.butt -textvariable _($self:${trim_name}0) -relief raised -width 20 balloon $f.butt "click to change setting" pack $f.label $f.butt -side left bind $f.butt <1> [list $self dropmenu_open $f $name] } def Dialogue add_spins {f name label option} { $self add_stuff $f $name $label set i 0 set trim_name [string trimleft $name "-"] set n [llength $@$option] foreach part $@$trim_name { if {$i < $n} {set s "readonly"} else {set s "disabled"} set v "::_($self:$trim_name${i})" spinbox $f.$i -width 2 -command "$self spinning %d $v" -state $s -textvariable $v pack $f.$i -side left balloon $f.$i "Device [expr $i+1]" incr i } } def Dialogue spinning {mode v} { switch $mode { up {incr $v; puts " incr $v"} down {incr $v -1} } } def Dialogue listbox_up {listbox} {$self listbox_swap $listbox -1} def Dialogue listbox_down {listbox} {$self listbox_swap $listbox +1} def Dialogue add {w args} { foreach row $args { set name [lindex $row 0] set type [lindex $row 1] set options [lrange $row 2 end] set f $w.$name set label "[say $name]: " set k [lsearch $options -choices] if {$k>=0} { set choices [lindex $options [expr $k+1]] set options [lreplace $options $k [expr $k+1]] } #set v $@$name #set v $_($self:$name) ;# bug in poetcl switch -- $type { side {$self add_side $f $name $label} color {$self add_color $f $name $label} font {$self add_font $f $name $label $options} choice {$self add_choice $f $name $label $choices} key {set f $w.[string tolower [lindex $name 0]] $self add_key $f $name $label} folders {$self add_folders $f $name $label} libraries {$self add_libraries $f $name $label} devlist {$self add_devlist $f $name $label} spins {$self add_spins $f $name $label $options} section {label $f -text $label -bg "#0000aa" -fg "#ffff55" -font {helvetica -10 bold}} subsection {label $f -text $label -bg "#0000aa" -fg "#ffff55" -font {helvetica -10 bold}} toggle { $self add_stuff $f $name $label eval [concat [list checkbutton $f.toggle -variable @$name] $options] pack $f.toggle -side left } default { $self add_stuff $f $name $label set trim_name [string trimleft $name "-"] eval [concat [list entry $f.entry -textvariable _($self:$trim_name)] $options] pack $f.entry -side left bind $f.entry <Return> "$self ok" switch -regexp -- $type { integer|float|fontsize { frame $f.b -borderwidth 0 button $f.b.1 -image icon_wedge_up -command "change_entry $f.entry +1" button $f.b.2 -image icon_wedge_down -command "change_entry $f.entry -1" pack $f.b.1 $f.b.2 -side top pack $f.b -side left bind $f.entry <Button-4> "change_entry $f.entry +1" bind $f.entry <Button-5> "change_entry $f.entry -1" } entry {} default { label $f.type -text "($type)" -fg "#808080" pack $f.type -side right -anchor e } } } } pack $f -side top -fill x } } proc logvar {args} { set r {} foreach var $args { regsub {^_\(.*:(.*)\)$} $var {@\1} var2 lappend r "$var2=[uplevel 1 list \$$var]" } puts [join $r "; "] } def Dialogue spinbox_update {mode} {puts " $mode"} def Dialogue add_font {f name label class} { $self add_stuff $f $name $label set v $@$name label $f.font -text $v -font [lreplace $v 1 1 -10] -width [string length $v] -height 1 -pady 3 -fg black \ -relief sunken -bg white button $f.preset -text [say "edit"] -pady 2 -font {Helvetica 8} \ -command "FontDialogue new_as $name $class $f.font" pack $f.font $f.preset -side left } def Canvas fd {} {FontDialogue new_as view_font [$self look font] "View"} class_new FontDialogue {Dialogue} def FontDialogue init {class orig} { if {[winfo exists .$self]} {return} super cancel ok set f .$self set @class $class set @orig $orig bind all <KeyPress-F1> help set font $::look($@class:font) set @family [lindex $font 0] set @size [expr -[lindex $font 1]] set @bold [expr [lsearch $font bold ]>=0] set @italic [expr [lsearch $font italic]>=0] set @str $font pack [label $f.label -text [say font_family] -anchor w] -side top -fill x frame $f.list -bd 2 pack [listbox $f.list.box -relief sunken -yscrollcommand "$f.list.scroll set" -width 30] -side left -expand yes -fill both pack [scrollbar $f.list.scroll -relief sunken -command "$f.list.box yview" -takefocus 0] -side right -fill y bind $f.list.box <<ListboxSelect>> "$self font_update $f" foreach name [lsort [font families]] {$f.list.box insert end $name} set fontlist [$f.list.box get 0 end] set find [max 0 [lsearch $fontlist $@family]] $f.list.box selection set $find $find $f.list.box activate $find $f.list.box see $find bind $f.list.box <ButtonRelease-1> "$self font_update $f" bind $f.list.box <ButtonPress-1> "focus $f.list.box" pack $f.list -side left -expand yes -fill both #pack [ttk::separator $f.sep -orient vertical] -side left -fill y #pack [ttk::sizegrip $f.sep] -side left -fill y #ttk::panedwindow frame $f.var frame $f.var.size pack [label $f.var.size.label -text [say font_size]] -side left pack [spinbox $f.var.size.entry -relief sunken -textvariable fontsize -width 4 \ -command "$self font_changesize $f %d"] -side left bind $f.var.size.entry <KeyPress-Return> "$self font_update_size $f" $f.var.size.entry delete 0 end $f.var.size.entry insert 0 $@size frame $f.var.style pack [label $f.var.style.label -text [say font_style]] -side left set cmd [list $self font_update $f] pack [checkbutton $f.var.style.bold -text [say font_bold] -variable @bold -command $cmd] -side top pack [checkbutton $f.var.style.italic -text [say font_italic] -variable @italic -command $cmd] -side top pack $f.var.size -side left pack $f.var.style -side left -padx 20 frame $f.preview pack [label $f.preview.label -text [say font_preview]] -side left pack [canvas $f.preview.canvas -width 250 -height 50 -relief sunken -borderwidth 1] -side left -fill x $f.preview.canvas create text 4 4 -tags ${self}TEXT -anchor nw -text [say font_preview_2] -font $font pack $f.var -side top -fill x pack $f.preview -side top -pady 10 focus $f.list.box #$self non_resizable } def FontDialogue font_update {f} { global font set lb $f.list.box set @family [$lb get [$lb curselection]] set @str [list $@family [expr -$@size]] if {$@bold } {lappend @str bold } if {$@italic} {lappend @str italic} # logvar @str $f.preview.canvas itemconfigure ${self}TEXT -font $@str } def FontDialogue font_changesize {f mode} { switch $mode { up {set @size [expr $@size+1]} down {set @size [expr $@size-1]} } $f.var.size.entry delete 0 end $f.var.size.entry insert 0 $@size $self font_update $f } def FontDialogue font_style {f bold} { set @bold $bold $self font_update $f } def FontDialogue font_update_size {f} { set size [$f.var.size.entry get] if [regexp {^[0-9]+$} $size] {set @size $size} $self font_update $f } def FontDialogue apply {} { set ::look($@class:font) $@str $@orig configure -font [lreplace $@str 1 1 -10] -text $@str -width [string length $@str] } ############ .pdrc editor #Turns #rgb into 3 elem list of decimal vals. proc rgb2dec {c} { set c [string tolower $c] if {[regexp -nocase {^#([0-9a-f])([0-9a-f])([0-9a-f])$} $c x r g b]} { # double'ing the value make #9fc == #99ffcc scan "$r$r $g$g $b$b" "%x %x %x" r g b } else { if {![regexp {^#([0-9a-f]+)$} $c junk hex] || \ [set len [string length $hex]]>12 || $len%3 != 0} { if {[catch {winfo rgb . $c} rgb]} { return -code error "bad color value \"$c\"" } else { return $rgb } } set len [expr {$len/3}] scan $hex "%${len}x%${len}x%${len}x" r g b } return [list $r $g $b] } #Returns a complementary color proc complement {orig {grays 1}} { foreach {r g b} [rgb2dec $orig] {break} set R [expr {(~$r)%256}] set G [expr {(~$g)%256}] set B [expr {(~$b)%256}] if {$grays && abs($R-$r) < 32 && abs($G-$g) < 32 && abs($B-$b) < 32} { set R [expr {($r+128)%256}] set G [expr {($g+128)%256}] set B [expr {($b+128)%256}] } return [format "\#%02x%02x%02x" $R $G $B] } # this makes the tooltip proc balloon {w help} { bind $w <Any-Enter> "after 500 [list balloon:show %W [list $help]]" #bind $w <Any-Leave> "destroy %W.balloon; puts \"destroy balloon\" " bind $w <Any-Leave> "destroy %W.balloon" } proc balloon:show {w arg} { if {[eval winfo containing [winfo pointerxy .]]!=$w} {return} set top $w.balloon catch {destroy $top} toplevel $top -bd 1 -bg black wm overrideredirect $top 1 if {$::tcl_platform(platform) == "macintosh"} {unsupported1 style $top floating sideTitlebar} pack [message $top.txt -aspect 10000 -bg lightyellow -font fixed -text $arg] set wmx [expr [winfo rootx $w]+[winfo width $w]] set wmy [winfo rooty $w] wm geometry $top [winfo reqwidth $top.txt]x[winfo reqheight $top.txt]+$wmx+$wmy raise $top } def Dialogue ok {} {$self apply; $self cancel} def Dialogue cancel {} {$self delete} def Dialogue close {} {$self delete} def Dialogue apply {} {} def Dialogue delete {} {destroy .$self; super} def Dialogue erase {} {}; # so that it doesn't call View erase def Dialogue init {args} { super set f .$self set @label_width 160 ;# 20 toplevel $f frame $f.buttonsep -height 2 -borderwidth 1 -relief sunken frame $f.buttonframe set i 0 foreach a $args { if {[llength $args]<=1 || $i>0} { pack [label $f.buttonframe.$i -width 1] -side left -fill x -expand 1 } pack [button $f.buttonframe.$a -text [say $a] -command "$self $a"] -side left bind $f.buttonframe.$a <Return> "$self $a" incr i } pack $f.buttonframe -side bottom -fill x -pady 2m pack $f.buttonsep -side bottom -fill x wm protocol $f WM_DELETE_WINDOW "$self cancel" bind .$self <Tab> "$self traversal %K %W forward" bind .$self <Control-Tab> "$self traversal %K %W back" set @auto_apply 0 } def Dialogue do_auto_apply {} {if {$@auto_apply} {$self apply}} def Dialogue non_resizable {} {wm resizable .$self 0 0} def Dialogue traversal {k w direction} { switch $direction { forward {focus [tk_focusNext $w]} back {focus [tk_focusPrev $w]} } } def Dialogue dropmenu_open {frame} { set x [winfo rootx $frame.butt] set y [expr [winfo height $frame.butt] + [winfo rooty $frame.butt]] tk_popup $frame.menu $x $y } def Dialogue dropmenu_set {frame var part val} { #if {$say} {set text [say $part]} else {set text $part} set @$var $val $frame.butt configure -text [say $part] } def Dialogue color_popup_select {frame var color} { set @$var $color set col [format #%6.6x $color] if {$self == "ddrc"} {set @$var $col} ;#!@#$ fishy $frame.color configure -background $col -activebackground $col -highlightbackground $col \ -foreground [complement $col] -text $col destroy $frame.color.popup $self do_auto_apply } def Dialogue color_popup {frame var i} { set w $frame.color.popup if [winfo exists $w] {destroy $w} #menu $w -tearoff false toplevel $w -bg "#000000" wm overrideredirect $w 1 wm geometry $w +[expr [winfo rootx $frame.preset]]+[expr {[winfo rooty $frame.preset]+[winfo height $frame.preset]}] for {set i 0} {$i<3} {incr i} { pack [frame $w.$i -bd 0 -bg "#000000"] for {set j 0} {$j<10} {incr j} { set c [lindex $::preset_colors [expr {$i*10+$j}]] pack [frame $w.$i.$j -width 24 -height 24 -background "#$c" -relief raised] -side left bind $w.$i.$j <ButtonRelease> [list $self color_popup_select $frame $var [expr 0x$c]] } } } def Dialogue choose_col {frame var val} { set c 0xFFFFFF set color [tk_chooseColor -title $val -initialcolor $val] if {$color != ""} { $frame.color configure -text $color $self color_popup_select $frame $var [expr [string replace $color 0 0 "0x"]&0xFFFFFF] } } class_new PagedDialogue {Dialogue} def PagedDialogue init {args} { eval [concat [list super] $args] set @nb [ttk::notebook .$self.1] set @nbs $@nb pack $@nb -expand 1 -fill both $self non_resizable } # numbers in section are for the % of space taken by labels set pdrc_options { section {section_audio 50} integer -r devlist -audioindev|-soundindev devlist -audiooutdev|-soundoutdev spins {-inchannels audioindev} spins {-outchannels audiooutdev} integer -audiobuf|-soundbuf integer -blocksize integer -sleepgrain void -nodac void -noadc choice {audio_api_choice} void -32bit section {section_midi 50} void -nomidiin void -nomidiout devlist -midiindev devlist -midioutdev section {section_externals 20} libraries -lib section {section_paths 20} folders -path folders -helppath section {section_other 50} files -open void -verbose integer -d void -noloadbang string -send void -listdev void -realtime|-rt } proc pdtk_audio_dialog {indevlist indevs inchans outdevlist outdevs outchans sr dspblock advance multi longform} { pdrc audio_properties $indevlist $indevs $inchans $outdevlist $outdevs $outchans $sr $dspblock $advance $multi } class_new ServerPrefsDialogue {PagedDialogue} def ServerPrefsDialogue apply {} { set audio_props [$self audio_properties=?] #pd pd audio-dialog $audio_props netsend [list "pd" "audio-dialog" $audio_props] $self write } def ServerPrefsDialogue init_reverse_hash {} { foreach {type names} $::pdrc_options { set name [lindex $names 0] if {[info exists @$name]} { if {$name != "audio_api_choice"} {set @$name ""} } else {set @$name ""} foreach alias $names {set ::pdrc_options_h($alias) [list $type $name]} if {$name == "audio_api_choice"} { foreach alias [lrange $::pd_apilist2 1 end] {set ::pdrc_options_h($alias) [list $type $name]} } } } def ServerPrefsDialogue audio_properties {indevlist indevs inchans outdevlist outdevs outchans sr dspblock advance multi} { set @audioindev $indevlist set @audiooutdev $outdevlist # the following @audioindev* is used as -textvariable for devlist set @audioindev0 [lindex $@audioindev 0] set @audiooutdev0 [lindex $@audiooutdev 0] set @inchannels $inchans set @outchannels $outchans set @audiobuf $advance set @blocksize $dspblock set @usemulti $multi set @r $sr set @midiindev "midione" set @midioutdev "miditwo" # below are also used as -textvariable mset [list @inchannels0 @inchannels1 @inchannels2 @inchannels3] $@inchannels mset [list @outchannels0 @outchannels1 @outchannels2 @outchannels3] $@outchannels set @audio_api_choice2 [say [lindex $::pd_apilist2 $@audio_api_choice]] if {![winfo exists .$self.1.1]} {$self init_content} else {$self update_content} } def ServerPrefsDialogue audio_properties=? {} { set indev0 [lsearch $@audioindev $@audioindev0] set outdev0 [lsearch $@audiooutdev $@audiooutdev0] return [list $indev0 0 0 0 $@inchannels0 $@inchannels1 $@inchannels2 $@inchannels3 \ $outdev0 0 0 0 $@outchannels0 $@outchannels1 $@outchannels2 $@outchannels3 \ $@r $@blocksize $@audiobuf] } def ServerPrefsDialogue read_one {type name contents i} { switch -- $type { folders {incr i; lappend @$name [lindex $contents $i]} libraries {incr i; lappend @$name [lindex $contents $i]} files {incr i; lappend @$name [lindex $contents $i]} choice { if {$name == "audio_api_choice"} { if {$@$name == ""} {set @$name [lsearch $::pd_apilist2 [lindex $contents $i]]} } else {set @$name [lindex $contents $i]} } void { set @$name 1} default {incr i; set @$name [lindex $contents $i]} } incr i return $i } def ServerPrefsDialogue read {} { global pdrc_options pdrc_options_h cmdline set fd [open $cmdline(rcfilename) "RDONLY CREAT"] set contents {} foreach line [split [read $fd] "\n"] { if {[string index $line 0] != "#"} {lappend contents $line} } close $fd set contents [concat [join $contents " "]] ;# concat casts to list type (faster) (?) set i 0 # prevent Tk8.5 from showing grey checkmarks foreach name {-nodac -noadc -32bit -nomidiin -nomidiout -verbose -noloadbang -listdev -realtime} {set _($self:$name) 0} while {$i < [llength $contents]} { set op [lindex $contents $i] if {[string length $op]==0} {break} if {![info exists pdrc_options_h($op)]} {post "unknown option: %s" $op; incr i; continue} mset {type name} $pdrc_options_h($op) set name [lindex [split $name "|"] 0] set i [$self read_one $type $name $contents $i] } } def ServerPrefsDialogue write {} { set fd [open $::cmdline(rcfilename) w] #set fd stdout; puts "WOULD SAVE:" foreach {type names} $::pdrc_options { set name [lindex [split [lindex $names 0] "|"] 0] if {[info exists _($self:$name)]} {set v $_($self:$name)} ;# bug in objective.tcl ? switch $type { folders {foreach item [$v get 0 end] {puts $fd "$name $item"}} libraries {foreach item [$v get 0 end] {puts $fd "$name $item"}} #files {foreach item $v {puts $fd "$name $item"}} void {if {$v != ""} {if {$v} {puts $fd $name}}} choice { if {$name != "audio_api_choice"} {set vv [lindex $names [expr 1+$v]]} \ else {set vv [lindex $::pd_apilist2 $v] } if {$vv != "default"} {puts $fd $vv} } devlist {} default {if {[string length $v]} {puts $fd "$name $v"}} } } close $fd #puts "THE END" } #def ServerPrefsDialogue reset {} {} def ServerPrefsDialogue init_content {} { set f .$self.1 set section 0 set @label_width 200 ;# 24 foreach {type names} $::pdrc_options { set name [lindex [split [lindex $names 0] "|"] 0] switch $type { void { set type toggle }} switch $type { section { set @label_width [expr 6*[lindex $names 1]] ;# % of 600 px frame .$self.1.[incr section] $@nb add .$self.1.$section -text [say $name] } choice { if {$name == "audio_api_choice"} { set ops $::pd_apilist2 } else { set ops [lrange $names 1 end] } $self add $f.$section [list $name choice -choices $ops] } devlist {$self add $f.$section [list $name devlist] } spins {$self add $f.$section [list $name spins [lindex $names 1]] } default {$self add $f.$section [list $name $type]} } } } def ServerPrefsDialogue update_content {} {$self update_channels} def ServerPrefsDialogue update_channels {} { set indev_len [llength $@audioindev] set outdev_len [llength $@audiooutdev] set i 0 foreach chan $@inchannels { if {$i< $indev_len} {set s "readonly"} else {set s "disabled"} .$self.1.1.-inchannels.$i configure -state $s incr i } set i 0 foreach chan $@outchannels { if {$i<$outdev_len} {set s "readonly"} else {set s "disabled"} .$self.1.1.-outchannels.$i configure -state $s incr i } } def ServerPrefsDialogue init {} { netsend [list pd audio-properties] $self init_reverse_hash $self read super reset cancel apply ok # pd pd midi-properties } def ServerPrefsDialogue dropmenu_set {frame var part val} { set trim_part [string trimleft $part "-"] set trim_var [string trimleft $var "-"] if {$var == "audio_api_choice"} { foreach api $::pd_apilist { if {$trim_part == [string tolower [lindex $api 0]]} { netsend [list pd audio-setapi [lindex $api 1]] after 1 [netsend [list pd audio-properties]] } } } else { set ::_($self:${trim_var}0) $part } super $frame $var $part $val } #used by choice and devlist def ServerPrefsDialogue dropmenu_open {f name} { set trim_name [string trimleft $name "-"] if {$trim_name != "audio_api_choice"} { set i 0 set m $f.menu $m delete 0 end foreach part $@$trim_name { $m add command -label $part -command [list $self dropmenu_set $f $name $part $i] incr i } } super $f } #################### ClientPrefsDialogue set ddrc_options { section Client section_color subsection Client canvas_color color Canvas bgedit color Canvas bgrun color Canvas grid subsection Client object_color color View bg color View fg color View frame1 color View frame2 color View frame3 color Comment bg color Comment fg color Comment frame1 color Comment frame2 color Comment frame3 color View selectframe font View font subsection Client wire_color color Wire fg color Wire dspfg color Wire fg2 color FutureWire dash subsection Client others_color color Box inletfg color Box outletfg color SelRect rect font KeyboardDialogue font font Console font section Client keys subsection Client put key Canvas Object key Canvas Message key Canvas {Number nbx} key Canvas Symbol key Canvas Comment key Canvas bng key Canvas tgl key Canvas {vsl hsl} key Canvas {vradio hradio} key Canvas vu key Canvas cnv key Canvas Graph key Canvas Array subsection Client edit key Canvas {cut copy} key Canvas {undo redo} key Canvas {paste duplicate} key Canvas select_all key Canvas clear_selection key Canvas {reload redraw} key Canvas editmodeswitch key Canvas {insert_object chain_object} key Canvas {clear_wires auto_wire} key Canvas subpatcherize subsection Client general key Canvas Pdwindow key Canvas {new_file open_file} key Canvas {save save_as} key Client {server_prefs client_prefs} key Canvas {close quit} key Canvas {find find_again} key Canvas {audio_on audio_off} key Client {audio_settings midi_settings} key Client test_audio_and_midi key Canvas {load_meter latency_meter} key Canvas about subsection Canvas keynav key Canvas {key_nav_up key_nav_up_shift} key Canvas {key_nav_down key_nav_down_shift} key Canvas {key_nav_right key_nav_right_shift} key Canvas {key_nav_left key_nav_left_shift} key Canvas key_nav_ioselect section Client others toggle Canvas hairstate toggle Canvas hairsnap toggle Canvas gridstate integer Canvas grid_size toggle Canvas snap_grid toggle Canvas buttonbar toggle Canvas statusbar toggle Canvas menubar toggle Canvas scrollbar toggle View tooltip toggle Wire wirearrow integer Client console language View language language View language2 integer Canvas pointer_sense } class_new ClientPrefsDialogue {PagedDialogue} def ClientPrefsDialogue apply {} {$self write; $self do_apply} def ClientPrefsDialogue read {} {read_ddrc} def ClientPrefsDialogue do_apply {} { foreach canvas $::window_list { if {[$canvas class] == "Canvas"} { $canvas activate_menubar= [$canvas look menubar] $canvas activate_buttonbar= [$canvas look buttonbar] $canvas activate_statusbar= [$canvas look statusbar] $canvas activate_scrollbars= [$canvas look scrollbar] $canvas activate_grid= [$canvas look gridstate] $canvas redraw } } } def ClientPrefsDialogue write {} { global look key $self get_val set fd [open $::cmdline(ddrcfilename) w] foreach category {look key} { set class_list {} puts $fd "$category \{" foreach name [array names $category] { mset {class var} [split $name ":"] lappend class_list $class } set class_list [luniq [lsort $class_list]] foreach class $class_list { puts $fd " $class \{" foreach name [lsort [array names $category -glob $class:*]] { mset {class var} [split $name ":"] # the eval here annoys me a bit because of possible special chars -- matju puts $fd " $var [eval list \$${category}($class:$var)]" #puts " $var $category $class $var" } puts $fd " \}" } puts $fd "\}" } close $fd } #this retrieves the values set in the editor def ClientPrefsDialogue get_val {} { global ddrc_options look key accels set check_key {} foreach {type class name} $ddrc_options { switch -regexp -- $type { color { set str [string tolower $class$name] set look($class:$name) $@$str } key { foreach item $name { set new_key $@$item set old_key $key($class:$item) if {$key($class:$item) != $new_key} { if {[dict exists $accels $old_key]} { set cmd [dict get $accels $old_key] set accels [dict remove $accels $old_key] dict set accels $new_key $cmd } } if {[dict exists $check_key $new_key] && $new_key != ""} { error "$new_key already assigned" } else {dict set check_key $new_key key($item)} set key($class:$item) $new_key } } toggle {set look($class:$name) $@$name} integer {set look($class:$name) $@$name} choice|language { if {$@$name == "autolanguage"} {set l auto} {set l $@$name} set look($class:$name) $l } #font {set look(View:font) $@str} } } } def ClientPrefsDialogue reset {} { # this should reload defaults.ddrc ? } def ClientPrefsDialogue revert {} { # this should reload currently used settings ? } def ClientPrefsDialogue init {} { global look key super cancel apply ok #super cancel reset revert apply ok set f .$self.1 set section 0 set subsection 0 set @label_width 200 ;# 24 foreach {type class names} $::ddrc_options { set name [lindex [split $names |] 0] switch $type { void { set type toggle }} switch $type { section { incr section $@nb add [ttk::notebook $@nb.$section] -text [say $name] set which_section $f.$section set which_self $self set subsection 0 } subsection { set subself $self.1.$section .$subself add [frame .$subself.[incr subsection]] -text [say $name] set which_section .$subself.$subsection set which_self $subself } language { set @$name $look(View:$name) say autolanguage "[say auto] ([say [lindex [figure_out_language [guess_lang]] 1]])" $self add $which_section [list $name choice -choices [concat autolanguage $::langoptions]] } color { set str [string tolower $class$name] set @$str $look($class:$name) $self add $which_section [list $str $type] } key { foreach item $name {set @$item $key($class:$item)} $self add $which_section [list $name $type] } toggle { set @$name $look($class:$name) $self add $which_section [list $name $type] } font { set str [string tolower $class$name] set @$str $look($class:$name) $self add $which_section [list $str $type $class] } default { switch $name { console {set @$name $look(Client:console)} pointer_sense {set @$name $look(Canvas:pointer_sense)} grid_size {set @$name $look(Canvas:grid_size)} default {} } $self add $which_section [list $name $type] } } } } def ClientPrefsDialogue dropmenu_set {frame var part val} {set @$var $part; $frame.butt configure -text [say $part]} def ClientPrefsDialogue dropmenu_open {f name} {super $f} ############ find dialogue ########### class_new FindDialogue {Dialogue} def FindDialogue init {canvas} { super cancel find set @canvas $canvas set @break 0 set f .$self $self add $f [list "string" "entry"] focus .find.string.entry } def FindDialogue find {} {$self ok} def FindDialogue ok {} { $@canvas find_string= $@string $@canvas search super } ############ other stuff ######### def Client client_class_tree {} {ClientClassTreeDialogue new} class_new ClientClassTreeDialogue {Dialogue} proc* place_stuff {args} {} def ClientClassTreeDialogue make_row {w tree} { pack [frame $w] -fill x pack [frame $w.row] -side top -fill x pack [button $w.row.butt -image icon_minus] -side left pack [label $w.row.label -text [lindex $tree 0]] -side left -fill x pack [frame $w.dent -width 32] -side left set i 1 foreach node [lrange $tree 1 end] { $self make_row $w.$i $node incr i } } def ClientClassTreeDialogue init {} { super close pack [frame .$self.1 -width 600 -height 400] -fill y -expand y pack [frame .$self.1.1 -width 600 -height 400 -bg "#6688aa"] -side left -fill y -expand y # "$w.1.scroll set" # i'd like a scrollable frame pack [scrollbar .$self.1.scroll -command "ClientClassTreeDialogue_scroll $self"] -side left -fill y -expand y place [frame .$self.1.1.tree] -x 0 -y 0 set w .$self.1.1.tree.1 $self make_row $w [Thing get_hierarchy] after 100 "$self update_scrollbar" } def ClientClassTreeDialogue update_scrollbar {} { set w .$self.1.1 set zy [winfo height $w] set sy [winfo height $w.tree] set y1 [expr 0.0-[winfo y $w.tree]] set y2 [expr 0.0+$y1+$zy] .$self.1.scroll set [expr $y1/$sy] [expr $y2/$sy] } def ClientClassTreeDialogue scroll {args} { set w .$self.1.1 set zy [winfo height $w] set sy [winfo height $w.tree] switch [lindex $args 0] { moveto { set y [clip [expr (0.0-[lindex $args 1])*$sy] [expr $zy-$sy] 0] place .$self.1.1.tree -x 0 -y $y puts "args=[list $args] zy=$zy sy=$sy y=$y" } scroll { } } after 100 "$self update_scrollbar" } class_new AboutDialogue {Dialogue} def AboutDialogue init {} { super close wm title .$self "About DesireData" pack [label .$self.title -text $::pd_version -font {helvetica 18}] -side top pack [text .$self.text -yscrollcommand ".$self.scroll set" -width 72 -height 36] -side left -fill both -expand yes pack [scrollbar .$self.scroll -command ".$self.text yview"] -side right -fill y -expand yes #12345678901234567890123456789012345678901234567890123456789012345678901 <- 72 chars .$self.text insert 0.0 \ "DesireData is a free (libre) real-time computer programming language interpreter focused on realtime audio and video. You can get DesireData from http://desiredata.goto10.org/ DesireData and PureData work on Linux, MacOSX, Windows, and others. PureData is copyrighted, but is free for you to use for any reasonable purpose, according to the SIBSD license. DesireData's client section also is free, according to the GPL license. DesireData's server section is an adaptation of the PureData code and is also using the SIBSD license. (insert here: links to both licenses) Credits: DesireData server: Mathieu Bouchard DesireData client: Mathieu Bouchard & Chun Lee PureData: Miller Puckette feat. Thomas Musil, G�nther Geiger, Krzysztof Czaja, Iohannes Zm�lnig & others. Translations: Fran�ais (French): Patrice Colet Catal� (Catalan): N�ria Verges Espa�ol (Spanish): Mario Mora, Ramiro Cosentino Deutsch (German): Max Neupert, Georg Holzmann, Thomas Grill Norsk Bokm�l (Norwegian): Gisle Fr�ysland Portugu�s (Portuguese): Nuno Godinho Portugu�s do Brasil (Brazilian Portuguese): Carlos Paulino Italiano (Italian): Davide Morelli, Federico Ferri Euskara (Basque): Ibon Rodriguez Garcia Nihongo (Japanese): Kentaro Fukuchi Polski (Polish): Michal Seta Dansk (Danish): Steffen Leve Poulsen Zong wen (Chinese): Chun Lee Nederlands (Dutch): Tim Vets T�rk�e (Turkish): Koray Tahiroglu Russkij (Russian): Ilya Dmitrichenko Much more documentation and other resources at http://puredata.info/ The Pd mailing list archive at http://lists.puredata.info/pipermail/pd-list/ (insert here: link to \"reference documentation for Pd\", that is, chapter 1)" # this looks bad on OSX, iirc .$self.text configure -state disabled } set manager [Manager new] def Class post_hierarchy {{i 0}} { post %*s%s [expr $i*2] "" $self foreach sub $@subclasses {$sub post_hierarchy [expr $i+1]} } def Class get_hierarchy {} { set l [list $self] foreach sub $@subclasses {lappend l [$sub get_hierarchy]} return $l } # Thing post_hierarchy #---------------------------------------------------------------- class_new ClipboardDialogue {Dialogue} def ClipboardDialogue init {clipboard} { super close set @clipboard $clipboard wm title .$self "Clipboard" pack [text .$self.text -yscrollcommand ".$self.scroll set" -width 72] -side left -fill both -expand yes pack [scrollbar .$self.scroll -command ".$self.text yview"] -side right -fill y $@clipboard subscribe $self $self notice } def ClipboardDialogue notice {args} { .$self.text delete 0.0 end .$self.text insert 0.0 [$@clipboard value] } def ClipboardDialogue delete {} { $@clipboard unsubscribe $self super } #---------------------------------------------------------------- class_new ListDialogue {Dialogue} def ListDialogue init {history title} { super close set @history $history wm title .$self $title frame .$self.1 pack [listbox .$self.1.list -yscrollcommand ".$self.1.scroll set" -width 72 -height 20] -side left -fill both -expand yes pack [scrollbar .$self.1.scroll -command ".$self.1.list yview"] -side right -fill y pack .$self.1 $@history subscribe $self $self notice } def ListDialogue listbox {} {return .$self.1.list} def ListDialogue notice {args} { set w [$self listbox] $w delete 0 end foreach e [$@history list] {$w insert end $e} $w see end } def ListDialogue delete {} { $@history unsubscribe $self super } class_new EventHistoryDialogue {ListDialogue} def EventHistoryDialogue init {history} { super $history [say event_history_view] pack [checkbutton .$self.hide -text [say hide_key_release]] -fill x [$self listbox] configure -font {Mono -10} } #---------------------------------------------------------------- #class_new Splash {Thing} #def Splash init {} { # toplevel .$self # frame .$self.f # canvas .$self.f.canvas # image create photo .dd -format GIF -file desiredata.gif # .$self.f.canvas create image 0 0 -image .dd # pack .$self.f.canvas # pack .$self.f #} class_new KeyboardDialogue {Dialogue} set keyboard_layouts { { {9 " " 67 68 69 70 " " 71 72 73 74 " " 75 76 95 96} {49 10 11 12 13 14 15 16 17 18 19 20 21 22} {23 24 25 26 27 28 29 30 31 32 33 34 35 51} {66 38 39 40 41 42 43 44 45 46 47 48 36} {50 52 53 54 55 56 57 58 59 60 61 62} {37 115 64 65 113 116 117 109} } { {" " " " 98 " "} {100 " " " " 102} {" " " " 104 " "} {" "} {" " " " 4 " "} {1 2 3} {" " " " 5 " "} } } foreach {k v} { 9 5 22 5 23 4 51 4 66 5 36 7 50 8 62 8 37 4 115 4 64 4 65 24 113 4 116 4 117 4 109 4 98 2 100 2 102 2 104 2 1 2 2 2 3 2 4 2 5 2 } {set keyboard_width_of($k) $v} proc namekey {i args} {foreach name $args {set ::keyboard_text_of($i) $name; incr i}} namekey 9 Esc namekey 67 F1 F2 F3 F4 F5 F6 F7 F8 F9 F10 namekey 95 F11 F12 namekey 49 ` namekey 10 "1 !" "2 @" "3 #" "4 \$" "5 %" "6 ^" "7 &" "8 *" "9 (" "0 )" "- _" "= +" BkSp namekey 23 Tab Q W E R T Y U I O P "\{ \[" "\} \]" namekey 51 "\\ |" namekey 66 Caps namekey 38 A S D F G H J K L "\; :" "' \"" namekey 36 Return namekey 50 Shift namekey 52 Z X C V B N M ", <" ". >" "/ ?" Shift namekey 37 Ctrl namekey 115 Sup namekey 64 Alt Space namekey 113 AltGr namekey 116 Sup Menu namekey 109 Ctrl namekey 98 (up) namekey 100 (left) namekey 102 (right) namekey 104 (down) namekey 1 1 2 3 4 5 #mouse clicks def KeyboardDialogue init {history} { super close set @history $history set @fade [dict create] wm title .$self "Keyboard View" ;# say set i 0; set j 0 set @names {key misc} frame .$self.board set layouts {::keyboard_layout ::keyboard_layout2} set @keycount 0 foreach layout $::keyboard_layouts { $self pack_keys $layout [lindex $@names $i] [llength [lindex $::keyboard_layouts [expr $i-1]]] incr i } pack .$self.board $@history subscribe $self $self fade } def KeyboardDialogue pack_keys {keys name off} { set i $off frame .$self.board.$name foreach row $keys { frame .$self.board.$name.$i foreach key $row { if {$key==" "} { pack [label .$self.board.$name.$i.shim$@keycount -image icon_empty] -side left incr @keycount continue } set ::keyboard_row_of($key) $i if {[info exists ::keyboard_width_of($key)]} {set width $::keyboard_width_of($key)} else {set width 3} if {[info exists ::keyboard_text_of($key)]} {set text $::keyboard_text_of($key) } else {set text $key} if {[regexp {\((\w+)\)} $text foo bar]} { set font [$self look font] pack [label .$self.board.$name.$i.key$key -image icon_$bar -relief raise -border 4 \ -side left -bg "#dddddd" -width [expr $width*[font measure $font 0]] \ -height [font metrics $font -linespace]] } else { pack [label .$self.board.$name.$i.key$key -text " $text " -relief raise -border 4 \ -side left -bg "#dddddd" -width $width -font [$self look font]] } } pack .$self.board.$name.$i -fill x if {$i==0} {pack [label .$self.board.$name.shim -image icon_empty] -fill x -expand yes} incr i } switch $name { key {pack .$self.board.key -side left} misc {pack .$self.board.misc -side right} } } def KeyboardDialogue notice {origin add event} { mset {type W x y mod K k} $event if {![info exists ::keyboard_row_of($k)]} {puts "unknown key $k"; return} set i $::keyboard_row_of($k) if {$i<[llength [lindex $::keyboard_layouts 0]]} {set section "key"} else {set section "misc"} switch -regexp -- $type { ^KeyPress|ButtonPress$ { if { [dict exists $@fade $k]} {dict unset @fade $k} .$self.board.$section.$i.key$k configure -bg "#ff0000" } ^KeyRelease|ButtonRelease$ {if {![dict exists $@fade $k]} {dict set @fade $k 255}} } } def KeyboardDialogue fade {} { foreach {k v} $@fade { incr v -85 if {$v<0} {set v 0} set r [expr 221+$v*2/15] set g [expr 221-$v*13/15] set i $::keyboard_row_of($k) if {$i<[llength [lindex $::keyboard_layouts 0]]} {set section "key"} else {set section "misc"} .$self.board.$section.$i.key$k configure -bg [format #%02x%02x%02x $r $g $g] if {$v} {dict set @fade $k $v} {dict unset @fade $k} } set @after [after 100 "$self fade"] } def KeyboardDialogue delete {} { $@history unsubscribe $self after cancel $@after super } #---------------------------------------------------------------- # Deconstructors def Wire deconstruct {{selcanvas ""}} { # the selcanvas system could be abstracted out using an ObjectList such that # Canvas<ObjectList and $selection class == ObjectList if {$selcanvas == ""} { list #X connect \ [[$@canvas objects] search $@from] $@outlet \ [[$@canvas objects] search $@to] $@inlet } { list #X connect \ $::obj_index_sel($@canvas:$@from) $@outlet \ $::obj_index_sel($@canvas:$@to) $@inlet } } def MessageBox deconstruct {} {concat [list #X msg $@x1 $@y1] $@text} def FloatBox deconstruct {} {concat [list #X floatatom $@x1 $@y1] $@w $@min $@max $@pos $@lab $@snd $@rcv} def SymbolBox deconstruct {} {concat [list #X symbolatom $@x1 $@y1] $@w $@min $@max $@pos $@lab $@snd $@rcv} def Comment deconstruct {} {concat [list #X text $@x1 $@y1] $@text} def Box deconstruct {} { if {[array names ::fields -exact $@pdclass] == ""} { return [concat [list #X obj $@x1 $@y1] $@text] } { set r {} foreach field $::fields($@pdclass) {lappend r $_($self:$field)} return $r } } def View deconstruct_to {stream args} { $stream << [philtre [eval [concat [list $self deconstruct] $args]]] $stream << ";\n" } def Canvas deconstruct {} { return [concat [list #X restore $@x1 $@y1] $@text] } def Canvas deconstruct_to {stream args} { set r [concat [list #N canvas] $@canvas_pos $@canvas_size] if {$@subpatch || $@abs} {lappend r $@name $@mapped} else {lappend r $@fontsize} $stream << "[philtre $r];\n" foreach i [lsort -integer [$@objects keys]] {eval [concat [list [$@objects get $i] deconstruct_to $stream]]} foreach i [lsort -integer [ $@wires keys]] {eval [concat [list [ $@wires get $i] deconstruct_to $stream]]} $stream << [philtre [eval [concat [list $self deconstruct] $args]]] $stream << ";\n" } #---------------------------------------------------------------- # openpanel & savepanel proc pdtk_openpanel {target localdir} { if {$localdir == ""} {set localdir $::pd_opendir} set filename [tk_getOpenFile -parent $::current_window -initialdir $localdir] if {$filename != ""} { set directory [string range $filename 0 [expr [string last / $filename]-1]] set pd_opendir $directory netsend [list $target callback [enquote $filename]] } } proc pdtk_savepanel {target localdir} { if {$localdir == ""} { set filename [tk_getSaveFile -parent $::current_window] } else { set filename [tk_getSaveFile -parent $::current_window -initialdir $localdir] } if {$filename != ""} { netsend [list $target callback [enquote $filename]] } } #---------------------------------------------------------------- # To err is human. #proc bgerror {err} { # set info [error_dump] # tk_messageBox2 -message "$err: $info" -type ok #} class_new OopsDialogue {Dialogue} def OopsDialogue init {sig1 sig2 where} { super damn wm title .$self [say oops] pack [label .$self.head -text $sig2 -font {Helvetica -14 bold}] -side top pack [label .$self.note -text [say oops_text]] -side top pack [text .$self.text -yscrollcommand ".$self.scroll set" -width 108 -height 15] -side left -fill both -expand 1 pack [scrollbar .$self.scroll -command ".$self.text yview"] -side right -fill y .$self.text insert 0.0 $where } # Nous sommes donc en pr�sence d'un incendie. C'est normal... def OopsDialogue damn {} {$self ok} #---------------------------------------------------------------- set main [Client new] set window_list [list $main] def Canvas auto_test {} { $self editmode= 1 $self select_all $self selection_move +10 0 $self selection_move +10 0 $self selection_move +10 0 } #----------------------------------------------------------------- def Canvas visual_diff {} { if {$@blinky != ""} { .$self.c delete BLINKY after cancel $@blinky set @blinky "" return } set filename [$self name] set initialfile "" foreach suffix {gif jpg jpeg png} { set t [$self folder]/$filename.$suffix post %s $t if {[file exist $t]} {set initialfile $filename.$suffix; break} } set filename [tk_getOpenFile -parent $::current_window -defaultextension .pd \ -filetypes $::image_filetypes -initialdir [$self folder] -initialfile $initialfile] if {$filename == ""} {return} image create photo image_$self -file $filename $self blink_image } def Canvas blink_image {} { set @blinky [after 300 [list $self blink_image]] if {[llength [.$self.c gettags BLINKY]]} { .$self.c delete BLINKY } else { # there's something that causes the pd screenshot to be off by 1 pixel. i don't know what. .$self.c create image 0 -1 -image image_$self -tag BLINKY -anchor nw } } #----------------------------------------------------------------- proc widget_tree {w {indent 0}} { foreach element [winfo children $w] { puts [format "%*s%s" [expr 2*$indent] "" $element] widget_tree $element [expr 2+$indent] } } if 0 { def Canvas :-) {} { if {![info exists ::pd_path]} {netsend [list pd update-path]} if {![info exists ::class_list]} {return [netsend [list pd update-class-list $self :-)]]} search_for_externs set class_list [luniq [lsort $::class_list]] set n 0 post "there are [llength $::class_list] classes" foreach c $::class_list { netsend [list .$self obj [expr int(1050*rand())] [expr int(650*rand())] $c] incr n if {$n>1500} {return "stopped at $n"} } return "finished" } } def Canvas :-) {} { if {![info exists ::pd_path]} {netsend [list pd update-path]} if {![info exists ::class_list]} {return [netsend [list pd update-class-list $self :-)]]} search_for_externs set ::class_list [luniq [lsort $::class_list]] post "there are [llength $::class_list] classes" $self :-)2 1000 "" } def Canvas :-)2 {n meuh} { if {$n >= [llength $::class_list]} {return} set c [lindex $::class_list $n] set x [expr int(1050*rand())]; set y [expr int(650*rand())] set x [expr int($n/36)*16]; set y [expr ($n%36)*18] puts ":-) $c" netsend [list .$self obj $x $y $c] [list $self :-)2 [expr {$n+1}]] #if {$n>1500} {post "stopped at %d" $n} } proc pd {args} {post %s "what is 'proc pd' ?"}