diff options
Diffstat (limited to 'desiredata/src/desire.tk')
| -rw-r--r-- | desiredata/src/desire.tk | 8712 |
1 files changed, 0 insertions, 8712 deletions
diff --git a/desiredata/src/desire.tk b/desiredata/src/desire.tk deleted file mode 100644 index c4dac9d7..00000000 --- a/desiredata/src/desire.tk +++ /dev/null @@ -1,8712 +0,0 @@ -#!/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' ?"} |