diff options
Diffstat (limited to 'desiredata/src/desire.tk')
-rw-r--r-- | desiredata/src/desire.tk | 9019 |
1 files changed, 9019 insertions, 0 deletions
diff --git a/desiredata/src/desire.tk b/desiredata/src/desire.tk new file mode 100644 index 00000000..70f3d052 --- /dev/null +++ b/desiredata/src/desire.tk @@ -0,0 +1,9019 @@ +#!/usr/bin/env wish +set cvsid {$Id: desire.tk,v 1.1.2.600.2.419 2007-10-27 00:22:27 matju Exp $} +#-----------------------------------------------------------------------------------# +# +# 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 {[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/lib/tcllib1.7 \ + /usr/lib/tclx8.4 \ + $auto_path] + +package require poe +if {$tk} {package require bgerror} + +catch {package require Tclx} +#if {[catch {source /home/matju/src/pd-desiredata/pd/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! +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 {eval [concat [list $x notice $self] $args]}} + def Observable child_changed {origin args} {foreach x $@subscribers {eval [concat [list $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 {} { + global poolset + #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 50 "$self call" +} + +def Manager notice {origin args} { + global poolset + 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 {} { + global errorInfo + 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 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 {} { + global errorInfo + 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 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 [lindex $action 1] {$self perform $x}} + } +} + +def CommandHistory atomically {what code} { + global errorInfo + 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 [expr ([llength $@hist]<[expr $@size+1]) ?[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 };" + } + # it's unfortunate but we seem to have to turn off global bindings + # for Text objects to get control-s and control-t to do what we want for + # "text" dialogs below. Also we have to get rid of tab's changing the focus. + bind all <Key-Tab> "" + #bind all <Key-Shift-Tab> "" + bind all <<PrevWindow>> "" + bind Text <Control-t> {} + bind Text <Control-s> {} + 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 +} + +set preset_colors2 { + fcfcfc a0a0a0 404040 fce0e0 fce0c0 fcfcc8 d8fcd8 d8fcfc dce4fc f8d8fc + e0e0e0 7c7c7c 202020 fc2828 fcac44 e8e828 14e814 28f4f4 3c50fc f430f0 + bcbcbc 606060 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 "" +set langoptions { + english francais deutsch catala espanol portugues italiano bokmal + euskara polski dansk chinese nihongo brasiliano turkce nederlands + russkij + +} +#lappend langoptions {chinese} +#lappend langoptions {esperanto} +set langfile locale/[switch -regexp -- $language { + ^(en|english|C)$ {list english} + ^(fr|francais)$ {list francais} + ^(de|deutsch)$ {list deutsch} + ^(ca|catala)$ {list catala} + ^(es|espanol)$ {list espanol} + ^(pt|portugues)$ {list portugues} + ^(it|italiano)$ {list italiano} + ^(nb|norsk|bokmal)$ {list bokmal} + ^(ch|chinese)$ {set encoding utf-8; list chinese} + ^(eu|euskara)$ {list euskara} + ^(eo|esperanto)$ {set encoding utf-8; list esperanto} + ^(pl|polski)$ {set encoding utf-8; list polski} + ^(dk|dansk)$ {list dansk} + ^(ja|japanese|nihongo)$ {list nihongo} + ^(br|brasiliano)$ {list brasiliano} + ^(tr|turkce)$ {set encoding utf-8; list turkce} + ^(nl|nederlands)$ {list nederlands} + ^(ru|russkij)$ {set encoding utf-8; list russkij} + default {error "huh??? unknown language (locale)"} +}].tcl + +proc localedir {x} {file join [file dirname [file dirname $::argh0]] lib/pd/bin/$x} +if {[regexp {desire\.tk$} $argh0]} { + source locale/index.tcl + if {$encoding != ""} {source -encoding $encoding $langfile} else {source $langfile} +} else { + source [localedir locale/index.tcl] + 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 + +#!@#$ this is supposed to be BlueBox! +#set look(Slider:bg) #ccebff + +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 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> {$c.1 yview scroll [expr -2-abs(%D)/%D] units} + }} + 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 + while {$@lines >= $::cmdline(console)} { + $@c.1 delete 1.0 2.0 + incr @lines -1 + } + 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} + regexp {\d\d\d\d/\d\d/\d\d} $::cvsid version + regsub -all "/" $version "." version + set ::pd_version_client $version + post "DesireData client version $version with 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_messageBox -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}]} { + global errorCode errorInfo + 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 50 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]" + } + OopsDialog 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 "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" "*"} +} + +#only works with tcltk 8.5 +catch {tk_getOpenFile -load-once} +if {$tcl_version>=8.5} { + 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 -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 [enquote $basename] [enquote $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_messageBox -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_messageBox -message "Do you really wish to abort?" -type yesno -icon question] + switch -- $answer {yes {exec kill -ABRT $::server_pid}} +} + +def Client server_prefs {} {ServerPrefsDialog new_as pdrc} +def Client client_prefs {} {ClientPrefsDialog 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 tags {} + foreach s $suffixes {lappend tags "$self$s"} + set ss [lindex $tags 0] + lappend tags $self + set tags [concat $tags [$self classtags]] +} +if {$have_expand} { + append item { + if {![llength [$c gettags $ss]]} { + $c create $type $coords -tags $tags {expand}$args + } { + $c itemconfigure $ss {expand}$args + $c coords $ss {expand}$coords + } + } +} else { + append item { + if {![llength [$c gettags $ss]]} { + eval [concat [list $c create $type $coords -tags $tags] $args] + } { + eval [concat [list $c itemconfigure $ss] $args] + eval [concat [list $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_messageBox -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 -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 -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_messageBox -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 -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 {} {AboutDialog 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 {} { KeyboardDialog new $::event_history} +def Client clipboard_view {} { ClipboardDialog new $::clipboard} +def Client command_history_view {} { ListDialog new $::command_history [say command_history_view]} +def Client event_history_view {} {EventHistoryDialog 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 + +} + +# 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 ""} + + } + catch {wm iconphoto $win icon_pd} + 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 \[expr -abs(%D)/%D\] + $self bind <Shift-MouseWheel> scroll x \[expr -abs(%D)/%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 dropper {} {$self new_object obj dropper} +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} + $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 dropper 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 {} {CanvasPropertiesDialog new $self} + +def Canvas gop_target {id} { + while {[$id canvas] != $self} {set id [$id canvas]}; return $id +} + +#-----------------------------------------------------------------------------------# +class_new Macro_Rect {View} + +def Macro_Rect init {} {super; $self data= 0 0 0 0 blue} + +def Macro_Rect data= {x1 y1 x2 y2 col} { + set @x1 $x1; set @y1 $y1 + set @x2 $x2; set @y2 $y2 + set @col $col +} + +def Macro_Rect flash {x1 y1 x2 y2 col} { + $self data= $x1 $y1 $x2 $y2 $col + $self draw + after 500 $self erase +} + +def Macro_Rect 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 [Macro_Rect 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 + $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 + #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 [dex $@objects $i]] $last] ;# bork bork bork + $@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 {} { + 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 $stack { + 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} {set val [expr $val-1]} + return [list "outlet" $id $val] + } + if {$y< $y1+2 && $ins} { + set val [expr int(($x-$x1)* $ins/($x2-$x1))] + if {$val == $ins} {set val [expr $val-1]} + return [list "inlet" $id $val] + } + return [list "object" $id] + } + #puts "skipped a $class" + } +} + +def Canvas identify_closestio {x y f} { + 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] + set ios {} + set objs {} + foreach tag $stack { + 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 tags [$c gettags [lindex [$c find overlapping [expr $x-2] [expr $y-2] [expr $x+2] [expr $y+2]] end]] + 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)]] + $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 + return + } 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 {} { + global clipboard obj_index_sel + 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 k port} { + set obj [$@objects get $k] + 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 $k $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 totall 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} else {if {![$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 + +proc color_* {c1 c2} { + scan $c1 #%02x%02x%02x r g b + scan $c2 #%02x%02x%02x R G B + return [format #%02x%02x%02x [expr ($r*$R)>>8] [expr ($g*$G)>>8] [expr ($b*$B)>>8]] +} + +# 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 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] + } { + global preset_colors2 + return #[lindex $preset_colors2 $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(dropper) [eval list $fields1 w isa $fields2] +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 dropper Dropper +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 {TextBox} +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 xyb [list [expr $x2-1] [expr $y1+1] [expr $x1+1] [expr $y1+1] [expr $x1+1] [expr $y2-1]] + set xyc [list [expr $x2-1] [expr $y1+1] [expr $x2-1] [expr $y2-1] [expr $x1+1] [expr $y2-1]] + set color [color_* [$self look bg] [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 + #$self item BASE2 line $xyb -fill #ffffff + #$self item BASE3 line $xyc -fill [darker $color] + $self draw_io +} + +def IEMGUI popup_properties {} {IEMPropertiesDialog new $self} + +class_new PropertiesDialog {Dialog} + +def PropertiesDialog 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 Dialog ok + bind $f <KeyPress> [list $self do_auto_apply] + bind $f <ButtonRelease> [list $self do_auto_apply] + set @auto_apply 0 + $self none_resizable +} + +def PropertiesDialog do_auto_apply {} { + if {$@auto_apply} {$self apply} +} + +class_new IEMPropertiesDialog {PropertiesDialog} + +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 IEMPropertiesDialog 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 IEMPropertiesDialog 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 IEMPropertiesDialog dropmenu_open {f name} {super $f} +def IEMPropertiesDialog 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 CanvasPropertiesDialog {PropertiesDialog} + +def CanvasPropertiesDialog 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 CanvasPropertiesDialog 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 CanvasPropertiesDialog 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 BoxPropertiesDialog {PropertiesDialog} +def Box popup_properties {} {BoxPropertiesDialog 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 BoxPropertiesDialog 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 WirePropertiesDialog {PropertiesDialog} +def Wire popup_properties {} {WirePropertiesDialog new $self} +def WirePropertiesDialog 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 GAtomPropertiesDialog {PropertiesDialog} + +def AtomBox popup_properties {} {GAtomPropertiesDialog new $self} + +# this is buggy due to miller's escapes vs iem's escapes. +def GAtomPropertiesDialog apply {} { + netsend [list .$@of reload $@w $@min $@max $@pos [gatom_escape $@lab] [gatom_escape $@rcv] [gatom_escape $@snd]] +} + +def GAtomPropertiesDialog 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 entry -width 4} \ + {min entry -width 8} \ + {max entry -width 8} \ + {lab entry -width 20} \ + {pos side} \ + {snd entry -width 20} \ + {rcv entry -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 GraphPropertiesDialog {Dialog} + +def GraphPropertiesDialog apply {} { + netsend [list .$@of dialog $@x1 $@y1 $@x2 $@y2 $@xpix $@ypix] +} + +def GraphPropertiesDialog 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 entry -width 7} \ + {x2 entry -width 7} \ + {xpix entry -width 7} \ + {y2 entry -width 7} \ + {y1 entry -width 7} \ + {ypix entry -width 7} + } + #.$self.xrangef.x2 select from 0 + #.$self.xrangef.x2 select adjust end + #focus .$self.xrangef.x2 +} + +class_new ArrayPropertiesDialog {Dialog} + +def ArrayPropertiesDialog apply {} { + regsub {^\$} $@name "#" name + netsend [list .$@apply arraydialog $name $@n $@saveit $@otherflag] +} + +def ArrayPropertiesDialog 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 != 0} { + 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 + for {set i 0} {$i<$@n} {incr i} { + $self item [list BUT$i BUT] rectangle \ + [list [expr $x1+3] [expr $y1+3] [expr $x1+$@w-3] [expr $y1+$@w-3]] \ + -fill #ffffff -outline #000000 + if {$@orient} {set y1 [expr $y1+$@w]} {set x1 [expr $x1+$@w]} + } + $self set $@on +} + +def Radio set {value} { + set c [$self get_canvas] + [$c widget] itemconfigure ${self}BUT -fill #ffffff + [$c widget] itemconfigure ${self}BUT$value -fill #000000 +} + +def Radio click {x y f target} { + mset {x1 y1} [$self xy] + set i [expr {($@orient ?$y-$y1:$x-$x1)/$@w}] + netsend [list .$self fout $i] +} + +def Radio key_incr {val1 val2} { + netsend [list .$self fout [expr $@on - $val2]] +} + +class_new Slider {BlueBox} + +# in sliders, @value is the kind of value that goes thru inlets and outlets +# whereas @val is always measured in "centipixels" (unzoomed). +def Slider reinit {mess} { + super $mess + set @knob_thick 4 + 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 $x1 $y1 [expr $x1+$@w+$@knob_thick] [expr $y1+$@h] + } else { + list $x1 [expr $y1-$@knob_thick] [expr $x1+$@w] [expr $y1+$@h] + } +} + +#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 x2 y2} [$self bbox] + set l [expr $@orient ?$@h:$@w] + set span [expr {$@max-$@min}] + set color [$self look bg] + set scaled [expr {$@value*($l-1)/$span}] + set thick [expr $@knob_thick/2] + if {$@orient} { + set y1 [expr $y1+$@knob_thick] + set y [expr $y1+$@h-$scaled-2] + set coords [list [expr $x1+2] $y [expr $x1+$@w-2] [expr $y-2]] + } else { + set x2 [expr $x1-$@knob_thick] + set x [expr $x1+$scaled] + set coords [list $x [expr $y1+$thick] [expr $x+2] [expr $y1+$@h-$thick]] + } + $self item KNOB rectangle $coords -outline red -fill [darker $color] +} + +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 {} { + global leet + super + mset {x1 y1} [$self xy] + set lx [expr $x1+$@ldx] + set ly [expr $y1+$@ldy] + set label $@lab; switch -- $label { empty { set label "" }} + set lfont [list [lindex {courier helvetica times} $@fstyle] $@fs bold] + set lcolor [parse_color $@lcol] + 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 w -font $lfont -fill $lcolor +} +#-----------------------------------------------------------------------------------# +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] + if {$@flash} { + set rect [list [expr $x1+2] [expr $y1+2] [expr $x2-2] [expr $y2-2]] + #$self item BUT oval $rect -fill [color_* [$self look bg] [parse_color $@fcol]] + set fcol [color_* [$self look bg] [parse_color $@fcol]] + set bcol [color_* [$self look bg] [parse_color $@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] + set rect [list [expr $x1+2] [expr $y1+2] [expr $x2-2] [expr $y2-2]] + $self item BUT oval $rect -fill [color_* [$self look bg] $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 [color_* [$self look bg] $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 [color_* [$self look bg] [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 {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 [color_* [$self look bg] $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 [color_* [$self look bg] $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 +} + +catch { + package require tkdnd + dnd bindtarget . text/uri-list <Drop> {open_file %D} +} + +class_new Dropper {View} + +# somewhat broken... +def Dropper draw {} { + set c [$@canvas widget] + set isnew [expr [llength [$c gettags ${self}BASE]] == 0] + mset {x1 y1} [$self xy] + set xs $@w + set colour [parse_color $@fcol] + set lcolour [parse_color $@lcol] + super + if {$isnew} { + canvas $c.${self}DROP -width $xs -height $xs -bg $colour \ + -highlightbackground $lcolour -highlightcolor $colour + $c create window [expr $x1+7] [expr $y1-2] -window $c.${self}DROP -anchor nw -tags $c.${self}window + if {[catch { + dnd bindtarget $c.${self}DROP text/uri-list <Drop> "pd \"x[list ${self}] symbol \[ enquote %D \] ;\"" + }]} { + post "dropper: dnd not installed" + } + } { + $c coords $@canvas.${self}window [expr $x1 + 7] [expr $y1 - 2] + $c.${self}DROP configure -width $xs -height $xs -bg $colour \ + -highlightbackground $lcolour -highlightcolor $colour + } +} + +def Dropper erase {} {destroy $@canvas.${self}DROP; super} + +class_new Cnv {Labelled IEMGUI Box} + +def Cnv draw {} { + mset {x1 y1} [$self xy] + $self item BASE rectangle [list $x1 $y1 [expr $x1+$@w] [expr $y1+$@h]] -fill [parse_color $@bcol] + 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 + 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 -text "$name: " -font {Courier 10}] -side left + pack [entry $serf.entry -width 40 -font $::look(View: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}} +} +# {dropper dropper {pd %W dropper 0}} + +proc button_bar_add {x y} { + global butt + lappend butt [list $x $y noload] +} + +if {$tk} { + set dir $cmdline(icons) + foreach icon {mode_edit mode_run pd} {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 w + 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 + +class_new ServerClassDict {Observable Thing} +def ServerClassDict init {} { + +} + +# Completion/Browser init can be cleaned up a bit more, do it later... +class_new ClassBrowser {Dialog} +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} { + global class_list + $@listbox delete 0 end + foreach class $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]] +} + +def ClassBrowser search_for_externs {} { + global pd_path class_list + foreach dir $pd_path { + catch { + 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 {} { + $self 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 {} { + $self 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 Dialog {View} + +def Dialog 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 Dialog 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 Dialog 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 "#ffffff" -activebackground [darker $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 Dialog 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 Dialog 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 Dialog 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 Dialog add_libraries {f name label} { + $self add_stuff $f $name $label + set v $_($self:$name) ;# bug in objtcl + 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 + 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 + entry $f.b.entry -width 15 -borderwidth 5 -relief ridge + bind $f.b.entry <Return> "$self lib_add $f.a.list" + pack $f.b.entry -side top + + 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 Dialog 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 Dialog 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 Dialog listbox_remove {listbox} { + set sel [$listbox curselection] + if {$sel == ""} {return} + $listbox delete $sel + $listbox selection set $sel +} + +def Dialog 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 Dialog 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 Dialog add_spins {f name label option} { + global _ + $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 Dialog spinning {mode v} { + switch $mode { + up {incr $v; puts " incr $v"} + down {incr $v -1} + } +} + +def Dialog listbox_up {listbox} {$self listbox_swap $listbox -1} +def Dialog listbox_down {listbox} {$self listbox_swap $listbox +1} + +def Dialog 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 Dialog spinbox_update {mode} {puts " $mode"} + +def Dialog 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 "FontDialog new_as $name $class $f.font" + pack $f.font $f.preset -side left +} + +class_new FontDialog {Dialog} + +def Canvas fd {} {FontDialog new_as view_font [$self look font] "View"} + +def FontDialog 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 + logvar @family @size @bold @italic + 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"] -side left + 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 [lsearch $fontlist $@family] + if {$find < 0} {set find 0} + $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" + + 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.list -side left + pack $f.var -side top -fill x + pack $f.preview -side top -pady 10 + focus $f.list.box + $self none_resizable +} + +def FontDialog 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 FontDialog 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 FontDialog font_style {f bold} { + set @bold $bold + $self font_update $f +} + +def FontDialog font_update_size {f} { + set size [$f.var.size.entry get] + if [regexp {^[0-9]+$} $size] {set @size $size} + $self font_update $f +} + +def FontDialog 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 Dialog ok {} {$self apply; $self cancel} +def Dialog cancel {} {if {[info exists @nbs]} {foreach x $@nbs {$x delete}}; after 1 [list $self delete]} +def Dialog close {} {$self delete} +def Dialog apply {} {} +def Dialog delete {} {destroy .$self; super} +def Dialog erase {} {}; # so that it doesn't call View erase + +def Dialog 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" +} + +def Dialog none_resizable {} {wm resizable .$self 0 0} + +def Dialog traversal {k w direction} { + switch $direction { + forward {focus [tk_focusNext $w]} + back {focus [tk_focusPrev $w]} + } +} + +def Dialog 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 Dialog 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 Dialog color_popup_select {frame var color} { + set @$var $color + set col [format #%6.6x $color] + if {$self == "ddrc"} {set @$var $col} + $frame.color configure -background $col -foreground [complement $col] -text $col + if {$self != "ddrc"} {$self do_auto_apply} + #$self do_auto_apply +} + +def Dialog color_popup {frame var i} { + set w $frame.color.popup + if [winfo exists $w] {destroy $w} + menu $w -tearoff false + global preset_colors + for {set i 0} {$i<[llength $preset_colors]} {incr i} { + set c [lindex $preset_colors $i] + $w add command -label " " -background "#$c" -activebackground "#$c" \ + -command [list $self color_popup_select $frame $var [expr 0x$c]] + } + tk_popup $w [expr [winfo rootx $frame.color]] [expr [winfo rooty $frame.color]] +} + +def Dialog 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 PagedDialog {Dialog} +class_new Notebook {Thing} + +def PagedDialog init {args} { + eval [concat [list super] $args] + set @nb [Notebook new_as $self.1] + set @nbs $@nb + pack .$@nb -expand 1 -fill both + $self none_resizable +} +def Notebook delete {} {super} +def Notebook init {{width 590} {height 350}} { + set f .$self + frame $f + pack [frame $f.bar] -fill x + pack [frame $f.main -borderwidth 1 -relief raised -width $width -height $height] -fill both -expand yes +} + +def Notebook page_select {i} { + set f .$self + catch { + $f.bar.$@section configure -relief raised + place forget $f.main.$@section + pack $f.bar.$@section -pady {4 4} + } + set @section $i + place $f.main.$@section -x 0 -y 0 ;# -width [winfo width $f.main] -height [winfo height $f.main] + $f.bar.$@section configure -relief sunken + pack $f.bar.$@section -pady {8 0} +} + +def Notebook add_section {section text} { + set f .$self + frame $f.main.$section + pack [button $f.bar.$section -text $text -command [list $self page_select $section]] -side left -pady {4 4} + bind $f.bar.$section <Return> "$self page_select $section" +} + +# 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 ServerPrefsDialog {PagedDialog} + +def ServerPrefsDialog apply {} { + set audio_props [$self audio_properties=?] + #pd pd audio-dialog $audio_props + netsend [list "pd" "audio-dialog" $audio_props] + $self write +} + +def ServerPrefsDialog init_reverse_hash {} { + global pdrc_options pdrc_options_h pd_apilist2 + 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 ServerPrefsDialog 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.main.1]} { + $self init_content + } else { + $self update_content + } +} + +def ServerPrefsDialog 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 ServerPrefsDialog 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 ServerPrefsDialog 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 ServerPrefsDialog 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]] + if {$vv != "default"} {puts $fd $vv} + } 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 ServerPrefsDialog reset {} { +} + +def ServerPrefsDialog init_content {} { + global pdrc_options + 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 + $@nb add_section [incr section] [say $name] + } + choice { + if {$name == "audio_api_choice"} { + set ops $::pd_apilist2 + } else { + set ops [lrange $names 1 end] + } + $self add $f.main.$section [list $name choice -choices $ops] + } + devlist {$self add $f.main.$section [list $name devlist] } + spins {$self add $f.main.$section [list $name spins [lindex $names 1]] } + default {$self add $f.main.$section [list $name $type]} + } + } + $@nb page_select 1 +} + +def ServerPrefsDialog update_content {} { + $self update_channels +} + +def ServerPrefsDialog 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.main.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.main.1.-outchannels.$i configure -state $s + incr i + } +} + +def ServerPrefsDialog init {} { + netsend [list pd audio-properties] + $self init_reverse_hash + $self read + super reset cancel apply ok + # pd pd midi-properties +} + +def ServerPrefsDialog 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 ServerPrefsDialog 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 +} + +#################### ClientPrefsDialog +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 KeyboardDialog 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 + choice View language + integer Canvas pointer_sense +} + +class_new ClientPrefsDialog {PagedDialog} +def ClientPrefsDialog apply {} {$self write; $self do_apply} +def ClientPrefsDialog read {} {read_ddrc} + +def ClientPrefsDialog 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 ClientPrefsDialog 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 ClientPrefsDialog get_val {} { + global ddrc_options look key accels + set check_key {} + foreach {type class name} $ddrc_options { + switch $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 {set look($class:$name) $@$name} + #font {set look(View:font) $@str} + } + } +} + +def ClientPrefsDialog reset {} { + # this should reload defaults.ddrc ? +} + +def ClientPrefsDialog revert {} { + # this should reload currently used settings ? +} + +def ClientPrefsDialog init {} { + global ddrc_options look key + #do we need to read .ddrc each time the pref editor is opened? + #$self read + 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 { + $@nb add_section [incr section] [say $name] + set which_section $f.main.$section + set which_self $self + set subsection 0 + } + subsection { + set subself $self.1.main.$section.subsections + if {!$subsection} { + lappend @nbs [Notebook new_as $subself 590 300] + pack .$subself + } + $subself add_section [incr subsection] [say $name] + $subself page_select 1 + set which_section .$subself.main.$subsection + set which_self $subself + } + choice { + set @$name $look(View:language) + $self add $which_section [list $name $type -choices $::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] + } + } + } + $@nb page_select 1 +} + +def ClientPrefsDialog dropmenu_set {frame var part val} { + set @$var $part + # set _($self:${var}2) [say $part] + $frame.butt configure -text [say $part] +} + +def ClientPrefsDialog dropmenu_open {f name} { + super $f +} + +############ find dialog ########### + +class_new FindDialog {Dialog} + +def FindDialog 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 FindDialog find {} {$self ok} +def FindDialog ok {} { + $@canvas find_string= $@string + $@canvas search + super +} +############ other stuff ######### + +def Client client_class_tree {} {ClientClassTreeDialog new} +class_new ClientClassTreeDialog {Dialog} + +proc* place_stuff {args} {} + +def ClientClassTreeDialog 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 ClientClassTreeDialog 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 "ClientClassTreeDialog_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 ClientClassTreeDialog 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 ClientClassTreeDialog 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 AboutDialog {Dialog} + +def AboutDialog 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 + 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 ClipboardDialog {Dialog} + +def ClipboardDialog 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 ClipboardDialog notice {args} { + .$self.text delete 0.0 end + .$self.text insert 0.0 [$@clipboard value] +} + +def ClipboardDialog delete {} { + $@clipboard unsubscribe $self + super +} + +#---------------------------------------------------------------- +class_new ListDialog {Dialog} + +def ListDialog 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 ListDialog listbox {} {return .$self.1.list} + +def ListDialog notice {args} { + set w [$self listbox] + $w delete 0 end + foreach e [$@history list] {$w insert end $e} + $w see end +} + +def ListDialog delete {} { + $@history unsubscribe $self + super +} + +class_new EventHistoryDialog {ListDialog} + +def EventHistoryDialog 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 KeyboardDialog {Dialog} + +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 KeyboardDialog 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 KeyboardDialog 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 -bg \ + "#dddddd" -width [expr $width*[font measure $font 0]] \ + -height [font metrics $font -linespace]] -side left + } else { + pack [label .$self.board.$name.$i.key$key -text " $text " -relief raise -border 4 \ + -bg "#dddddd" -width $width -font [$self look font]] -side left + } + } + 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 KeyboardDialog 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 KeyboardDialog 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 KeyboardDialog 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 -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] + } else { + set filename [tk_getSaveFile -initialdir $localdir] + } + if {$filename != ""} { + netsend [list $target callback [enquote $filename]] + } +} + +#---------------------------------------------------------------- +# To err is human. + +#proc bgerror {err} { +# global errorInfo +# set info [error_dump] +# tk_messageBox -message "$err: $info" -type ok +#} + +class_new OopsDialog {Dialog} + +def OopsDialog init {sig1 sig2 where} { + super damn + wm title .$self "Oops..." + pack [label .$self.head -text $sig2 -font {Helvetica -14 bold}] -side top + pack [label .$self.note -text "This program has performed a silly operation and has been shut down."] -side top + pack [text .$self.text -yscrollcommand ".$self.scroll set" -width 72 -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 OopsDialog damn {} {$self ok} + +#---------------------------------------------------------------- + +if {$tk} { + set main [Client new] + set window_list [list $main] +} else { + set cmdline(console) 0 + #foreach dir $auto_path { + # set file $dir/libtclreadline[info sharedlibextension] + # puts "trying $file" + # if {![catch {load $file}]} {puts "found tclreadline !"} + #} + package require tclreadline + proc ::tclreadline::prompt1 {} {return "desire> "} + ::tclreadline::Loop + #while {1} { + # #set line [::tclreadline::readline read] + # puts -nonewline "desire> " + # flush stdout + # set line [gets stdin] + # if {[catch {puts [eval $line]}]} { + # puts "error: $::errorInfo" + # } + #} + #vwait foo +} + +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 != ""} { + after cancel $@blinky + return + } + #regsub {\.pd} [$self name] {} filename + 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 -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 {} { + if {[llength [.$self.c gettags BLINKY]]} { + .$self.c delete BLINKY + } else { + .$self.c create image 0 0 -image image_$self -tag BLINKY -anchor nw + } + set @blinky [after 500 [list $self blink_image]] +} + +#----------------------------------------------------------------- + +#lappend ::auto_path /usr/local/lib/graphviz +catch {package require Tcldot} +def Canvas graphviz_sort {} { + error "this code has to be rewritten to use the new containers" + set nodes {} + set gwidth 0; set gh 0 + #toplevel .graph -height 600 -width 800 + #set c [canvas .graph.c -height 600 -width 800] + #pack $c + set g [dotnew digraph] + $g setnodeattribute style filled color white + foreach child $@children { + lappend nodes [$g addnode $child label "[$child text]" shape "record" height "0.1"] + lappend nodes $child + } + puts "$nodes" + foreach wire $@wires { + mset {from outlet to inlet} [$wire report] + set n1 [lindex $nodes [expr [lsearch $nodes $from]-1]] + set n2 [lindex $nodes [expr [lsearch $nodes $to]-1]] + $n1 addedge $n2 + } + #$g layout + ;# see what render produces + #if {$debug} {puts [$g render]} + #eval [$g render] + set f {} + set fd [open graph.txt w] + $g write $fd plain + close $fd + + set fd [open graph.txt r] + set contents [read $fd] + close $fd + exec rm graph.txt + mset {x1 y1 x2 y2} [[$self widget] bbox all] + set width [expr $x2 - $x1] + set height [expr $y2 - $y1] + foreach line [split $contents "\n"] { + switch [lindex $line 0] { + graph {set gw [lindex $line 2]; set gh [lindex $line 3]} + node { + set w [expr $width/$gw] + set h [expr $height/$gh] + set id [lindex $line 1] + set x [lindex $line 2]; set y [lindex $line 3] + $id moveto [expr $x*$w] [expr ($gh-$y)*$h] + } + edge {break} + } + } +} + + |