#!/usr/bin/env wish set svnid {$Id$} #-----------------------------------------------------------------------------------# # # DesireData # Copyright (c) 2004 by Mathieu Bouchard # Copyright (c) 2005,2006,2007 by Mathieu Bouchard and Chun Lee # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 2 # of the License, or (at your option) any later version. # See file ../COPYING.desire-client.txt for further informations on licensing terms. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # Note that this is not under the same license as the rest of PureData. # Even the DesireData server-side modifications stay on the same license # as the rest of PureData. # #-----------------------------------------------------------------------------------# # this command rebuilds the package index: echo pkg_mkIndex . | tclsh set debug 0 ;# DON'T TOUCH THIS, make yourself a debug.tcl instead! if {$tcl_version < 8.5} {puts "Please upgrade to Tcl/Tk 8.5... Thank You.\n(your version is $tcl_version)"; exit 84} if {[catch {winfo children .}]} {set tk 0} {set tk 1} set argh0 [file normalize [file join [pwd] $argv0]] set auto_path [concat . \ [list [file join [file dirname [file dirname $argh0]] lib/pd/bin]] \ /usr/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/svn-pd/desiredata/src/profile_dd.tcl}]} {error_dump} if {[file exists debug.tcl]} {source debug.tcl} proc which {file} { global env foreach dir [split $::env(PATH) ":"] { if {[file exists $dir/$file]} {return $dir/$file} } return "" } #-----------------------------------------------------------------------------------# # some list processing functions and some math too # these could become another library like objective.tcl # if they become substantial enough # min finds the smallest of two values # max finds the biggest of two values # [clip $v $min $max] does [max $min [min $max $v]] proc min {x y} {expr {$x<$y?$x:$y}} proc max {x y} {expr {$x>$y?$x:$y}} proc clip {x min max} { if {$x<$min} {return $min} if {$x>$max} {return $max} return $x } # set several variables from elements of a list # WARNING: for @-variables, use [list @a @b @c] instead of {@a @b @c} proc mset {vars list} { uplevel 1 "foreach {$vars} {$list} {break}" } # add or subtract two lists proc l+ { al bl} {set r {}; foreach a $al b $bl {lappend r [expr {$a+$b}]}; return $r} proc l- { al bl} {set r {}; foreach a $al b $bl {lappend r [expr {$a-$b}]}; return $r} # halve a list proc l/2 { al } {set r {}; foreach a $al {lappend r [expr {$a/2 }]}; return $r} # like l+ or l- but for any infix supported by expr proc lzip {op al bl} { set r {} set e "\$a $op \$b" foreach a $al b $bl {lappend r [expr $e]} return $r } # do an operation between all elements of a list and a second argument proc lmap {op al b } { set r {} set e "\$a $op \$b" foreach a $al {lappend r [expr $e]} return $r } # sum and product of a list, like math's capital Sigma and capital Pi. proc lsum {al} {set r 0; foreach a $al {set r [expr {$r+$a}]}; return $r} proc lprod {al} {set r 1; foreach a $al {set r [expr {$r*$a}]}; return $r} # all elements from end to beginning proc lreverse {list} { set r {} for {set i [expr {[llength $list]-1}]} {$i>=0} {incr i -1} {lappend r [lindex $list $i]} return $r } # list substraction is like set substraction but order-preserving # this is the same algorithm as Ruby's - operation on Arrays proc lwithout {a b} { set r {} foreach x $b {set c($x) {}} foreach x $a {if {![info exists c($x)]} {lappend r $x}} return $r } proc lintersection {a b} { set r {} foreach x $b {set c($x) {}} foreach x $a {if {[info exists c($x)]} {lappend r $x}} return $r } # removes duplicates from a list, but it must be already sorted. proc luniq {a} { set last [lindex $a 0] set r [list $last] set i 0 foreach x $a { if {$i && [string compare $last $x]} {lappend r $x} incr i; set last $x } return $r } # one-dimensional intervals (left-closed, right-open); not much in use at the moment, not that they wouldn't deserve to! # (slightly buggy) proc inside {x x0 x1} {return [expr $x>=$x0 && $x<$x1]} proc overlap {y0 y1 x0 x1} {return [expr [inside $y0 $x0 $x1] || [inside $y1 $x0 $x1]]} proc distance {point1 point2} { set off [l- $point1 $point2] return [expr {sqrt([lsum [lzip * $off $off]])}] } proc rect_centre {rect} { mset {x1 y1 x2 y2} $rect return [list [expr {($x1+$x2)/2}] [expr {($y1+$y2)/2}]] } proc lmake {start end} {for {set i $start} {$i<=$end} {incr i} {lappend l $i}; return $l} #-----------------------------------------------------------------------------------# set callback_list {} proc append_callback {mode when def} { global callback_list dict set callback_list $mode $when $def } proc remove_callback {mode} { global callback_list set callback_list [dict remove $callback_list $mode] } proc modes_callback {self def {args}} { global callback_list set i 0 dict for {mode callbacks} $callback_list { foreach {when call} $callbacks { if {$def == $when} {eval $self $call $args; incr i} } } if {!$i} {return 0} else {return 1} } #-----------------------------------------------------------------------------------# # Observer pattern # there's no class for "observer". # it's anything that has def $myclass notice {args} {...} in which args indicate # attributes that have changed, or is an empty list if an unspecified number of # attributes (maybe all) have changed. class_new Observable {} def Observable init {args} { eval [concat [list super] $args] set @subscribers {} } def Observable subscribe {observer} { set i [lsearch $@subscribers $observer] if {$i<0} {lappend @subscribers $observer} } def Observable unsubscribe {observer} { set i [lsearch $@subscribers $observer] if {$i>=0} {set @subscribers [lreplace $@subscribers $i $i]} } if {$have_expand} { #def Observable changed {args} { # puts "Observable changed $self called from [info level [expr [info level]-2]]" # foreach x $@subscribers {$x notice $self {expand}$args]} #} def Observable changed {args} {foreach x $@subscribers {$x notice $self {expand}$args}} def Observable child_changed {origin args} {foreach x $@subscribers {$x notice $origin {expand}$args}} } else { def Observable changed {args} {foreach x $@subscribers {$x notice $self {*}$args}} def Observable child_changed {origin args} {foreach x $@subscribers {$x notice $origin {*}$args}} } def Observable subscribers {} {return $@subscribers} #-----------------------------------------------------------------------------------# set poolset(foo) bar array unset poolset foo class_new Manager {Thing} def Manager init {} { set @q {} $self call } def Manager call {} { 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 {} { if {![$self can_perform? [lindex $@undo_stack end]]} {error "Can't undo this!"} set backup $@undo_stack set @undo_stack $@redo_stack set @redo_stack {} #set err [catch {$self perform [lindex $backup end]}]; if {$err} {set err $::errorInfo} $self atomically [list atomic_undo] { $self perform [lindex $backup end] } set @redo_stack $@undo_stack set @undo_stack [lrange $backup 0 end-1] $self changed #if {$err} {post %s $err; error "undo: $err"} } def CommandHistory redo {} { if {![$self can_perform? [lindex $@undo_stack end]]} {error "Can't redo this!"} set backup $@redo_stack set @redo_stack {} set err [catch {$self perform [lindex $backup end]}]; if {$err} {set err $::errorInfo} $self atomically [list atomic_redo] { $self perform [lindex $backup end] } set @redo_stack [lrange $backup 0 end-1] $self changed #if {$err} {post %s $err; error "redo: $err"} } def CommandHistory can_perform? {action} { switch -- [lindex $action 0] { do {return 1} can't {return 0} default { foreach x [lrange $action 1 end] { if {![$self can_perform? $x]} {return 0} } return 1 } } } def CommandHistory perform {action} { switch -- [lindex $action 0] { do {eval [lindex $action 1]} can't {error "can't undo this!"} default {foreach x [lreverse [lindex $action 1]] {$self perform $x}} } } def CommandHistory atomically {what code} { set ubackup @undo_stack; set @undo_stack {} set rbackup @redo_stack; set @redo_stack {} uplevel 2 $code set atom $@undo_stack set @undo_stack $ubackup set @redo_stack $rbackup lappend @undo_stack [list $what $atom [lrange [info level -3] 1 end]] $self changed } def CommandHistory list {} { set r {} set hist [concat [$self undo_stack] [list "You Are Here"] [lreverse [$self redo_stack]]] set i 0 foreach e $hist {lappend r "$i: $e"; incr i} return $r } set command_history [CommandHistory new] #-----------------------------------------------------------------------------------# class_new History {Thing} def History init {size} { set @size $size set @hist {{}} set @histi -1 } def History histi= {val} {set @histi $val} def History histi {} {return $@histi} def History set_hist {idx stuff} {set @hist [lreplace $@hist $idx $idx $stuff]} def History prepend {stuff} { set @hist [linsert $@hist 1 $stuff] if {[llength $@hist] >= $@size} {set @hist [lrange $@hist 0 [expr $@size-1]]} } def History traverse {incr} { set @histi [expr $@histi + $incr] set mod [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 };" } set main [string toupper [info script] 0 0] set ::current_window . bind $main {set ::current_window %W} bind Toplevel {set ::current_window %W} proc tk_messageBox2 {args} {tk_messageBox -parent $::current_window {*}$args} # 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 "" #bind all "" bind all <> "" bind Text {} bind Text {} 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 "" if {$language == "C"} {set language en} proc localedir {x} {file join [file dirname [file dirname $::argh0]] lib/pd/bin/$x} if {[regexp {desire\.tk$} $argh0]} {source locale/index.tcl} {source [localedir locale/index.tcl]} set langentry [figure_out_language $language] set encoding [lindex $langentry 0] set langfile locale/[lindex $langentry 1].tcl if {[regexp {desire\.tk$} $argh0]} { if {$encoding != ""} {source -encoding $encoding $langfile} else {source $langfile} } else { if {$encoding != ""} {source -encoding $encoding [localedir $langfile]} else {source [localedir $langfile]} } if {[info exists ::cmdline(safemode)]} {read_client_prefs_from "defaults.ddrc"} if {[info exists ::cmdline(dzinc)]} {package require dzinc} #-----------------------------------------------------------------------------------# #!@#$ is this still valid? set look(Box:extrapix) [switch $::OS { osx {concat 2} default {concat 1}}] #font is defined as Thing for now, as the completion needs to get to these ones. #!@#$ View->??? #set look(View:tooltip) 1 #!@#$ View->TextBox ? #set look(View:minobjwidth) 21 #!@#$ View->ObjectBox #set look(View:fg) #000000 #set look(View:bg) #ffffff #set look(View:frame1) #99cccc #set look(View:frame2) #668888 #set look(View:frame3) #000000 #!@#$ 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 osx_scroll {axis diff} {$@c.1 yview scroll [expr -2-abs($diff)/$diff]} def Console init {c} { set @c $c frame $c text $c.1 -width 72 -height 20 -yscrollcommand "$c.2 set" -font [$self look font] scrollbar $c.2 -command "$c.1 yview" pack $c.1 -side left -fill both -expand yes pack $c.2 -side left -fill y -expand no pack $c -fill both -expand yes $c.2 set 0.0 1.0 switch $::OS {osx {bind $c.1 [list $self osx_scroll %D]}} set @lines 0 } def Console widget {} {return $@c} def Console post_string {x} { set oldpos [lindex [$@c.2 get] 1] $@c.1 insert end $x regsub -all "\n" $x "" y set n [expr [string length $x]-[string length $y]] incr @lines $n 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 . {$main ctrlkey %x %y %K %A 0} bind . {$main ctrlkey %x %y %K %A 1} switch $::OS { osx { bind . {$main ctrlkey %x %y %K %A 0} bind . {$main ctrlkey %x %y %K %A 1} } } # bind . {.debug.1 configure -text "widget = %W"} } # miller uses this nowadays (matju fished it in pd-cvs for 0.40). we don't use it for now. # remember to fix all quoting problems, which in the end may or may not involve the following proc. proc pdtk_unspace {x} { set y [string map {" " "_" ";" "" "," "" "{" "" "}" "" "\\" ""} $x] if {$y == ""} {set y "empty"} concat $y } proc pdtk_pd_meters {indb outdb inclip outclip} { foreach {z clip db} [list in $inclip $indb out $outclip $outdb] { .controls.$z.1.mtr coords m 0 0 $db 0 .controls.$z.1.clip configure -background [if {$clip==1} {concat red} {concat black}] } } proc pd_startup {version apilist midiapilist args} { set ::pd_version $version set ::pd_apilist $apilist set ::pd_midiapilist $midiapilist foreach api $apilist { lappend ::pd_apilist2 "-[string tolower [lindex $api 0]]" } set version [regsub "^DesireData " $::pd_version ""] post "DesireData server version $version" } def Client init_controls {} { menu .mbar pack [frame .controls] -side top -fill x foreach t {file window help} { .mbar add cascade -label [say $t] -menu [menu .mbar.$t -tearoff $::pd_tearoff] } .mbar.window configure -postcommand "$self fix_window_menu" foreach {z fill} {in #0060ff out #00ff60} { set f .controls.$z frame $f frame $f.1 -borderwidth 2 -relief groove canvas $f.1.mtr -width 100 -height 10 -bg #222222 $f.1.mtr create line [list 0 0 0 0] -width 24 -fill $fill -tags m canvas $f.1.clip -width 5 -height 10 -bg #222222 pack $f.1.mtr $f.1.clip -side left pack [label $f.2 -text [say $z]:] $f.1 -side left pack $f -side left -pady 0 -padx 0 } foreach {w x y z} { audiobutton audio ctrls_audio_on {netsend [list pd dsp $ctrls_audio_on]} meterbutton meters ctrls_meter_on {netsend [list pd meters $ctrls_meter_on]} } { pack [checkbutton .controls.$w -text [say $x] -variable $y -anchor w -command $z] -side left } button .controls.clear -text [say console_clear] -command {.log.1 delete 0.0 end} -padx 2 -pady 0 button .controls.dio -text [say io_errors] -command {netsend [list pd audiostatus]} -padx 2 -pady 0 pack .controls.clear .controls.dio -side right if {$::debug} { frame .debug pack [label .debug.1 -anchor w -text ""] -side left pack [entry .debug.3 -textvariable ::serial -width 5] -side right pack [label .debug.2 -text "obj.serial: " -justify right] -side right pack .debug -side bottom -fill x } if {$::cmdline(console)} {set ::console [Console new .log]} . configure -menu .mbar wm title . "DesireData" catch {wm iconphoto . icon_pd_32} regexp {\d\d\d\d-\d\d-\d\d} $::svnid date regsub -all "/" $date "." date regexp {desire.tk (\d+)} $::svnid blah revision set version "svn#$revision ($date)" set ::pd_version_client $version post "DesireData client version $version" post "Using Tcl %s and Tk %s" $::tcl_patchLevel $::tk_patchLevel } proc pdtk_pd_dsp {value} { global ctrls_audio_on set ctrls_audio_on $value } proc pdtk_pd_dio {red} { .controls.dio configure -background red -activebackground [if {$red==1} {list red} {list lightgrey}] } ############### set up global variables ################################ set pd_opendir [pwd] ############### set up socket ########################################## set sock {} set sock_lobby {} proc poll_sock {} { global sock sock_lobby cmdline if {[llength $sock]==0} {return} while {1} { set cmd [gets $sock] if {[eof $sock]} { if {!$cmdline(gdb)} { tk_messageBox2 -message "connection ended by server.\n(crash? try: desire -gdb)" -type ok } set sock {} return } if {[fblocked $sock]} {break} if {$::debug} {if {[string first pdtk_post $cmd]!=0} {puts "[VTmagenta]-> $cmd[VTgrey]"}} append sock_lobby "\n$cmd" if {[catch {eval $sock_lobby}]} { switch -regexp -- $::errorInfo { "^missing close-brace" { #puts "waiting for the end of: [string range $sock_lobby 0 40]" continue }} error_dump } set sock_lobby {} } flush $sock after 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" "*"} } catch {tk_getOpenFile -load-once} ;#only works with tcltk 8.5 catch { set ::tk::dialog::file::showHiddenBtn 1 set ::tk::dialog::file::showHiddenVar 0 } def Client open_file {} { global pd_opendir patch_filetypes set filename [tk_getOpenFile -parent $::current_window -defaultextension .pd -filetypes $patch_filetypes -initialdir $pd_opendir] if {$filename != ""} {$self open_file_really $filename} } def Client open_file_really {filename} { set i [string last / $filename] set folder [string range $filename 0 [expr $i-1]] set ::pd_opendir $folder set basename [string range $filename [expr $i+1] end] if {[string last .pd $filename] >= 0} { netsend [list pd open [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 {netsend $send_textvar; after 50 {destroy .sendpanel}} focus $e } def Client quit {} { set answer [tk_messageBox2 -message "Do you really wish to quit?" -type yesno -icon question] switch -- $answer {yes {netsend [list pd quit]; exit}} } def Client abort_server {} { set answer [tk_messageBox2 -message "Do you really wish to abort?" -type yesno -icon question] switch -- $answer {yes {exec kill -ABRT $::server_pid}} } def Client server_prefs {} {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= 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]] } append item [correct_splat { if {![llength [$c gettags $ss]]} { $c create $type $coords -tags $tags {*}$args } { $c itemconfigure $ss {*}$args $c coords $ss {*}$coords } }] def View item {suffixes type coords args} $item def View item_delete {{suffix all}} { if {$@canvas == ""} {return} set c [$@canvas widget] if {![winfo exists $c]} { set canvas [$@canvas get_canvas] if {$canvas == ""} {return} set c [[$@canvas get_canvas] widget] if {![winfo exists $c]} {return} } switch -- $suffix { all {$c delete $self} default {$c delete $self$suffix}} } def View draw {} {} def View delete {} {$self erase; super} def View erase {} {$self item_delete} def View selected? {} {return $@selected?} def View selected?= {x} {set @selected? $x; $self changed} ;# this is for use by the Selection class only def View edit? {} {if {[info exists @edit]} {return $@edit} else {return 0}} def View select {state} { set ostate [$self selected?] set @selected? $state if {$state!=$ostate} {$self changed} } # give topleft point of an object in the canvas it's rendered in. # this includes GOP and excludes zoom. # inheritance problem: this doesn't work for Wire, which doesn't store its positions def View xy {} { if {$@canvas == ""} {return [list $@x1 $@y1]} set type [$@canvas type] if {$type == "gopabs" || $type == "gopsub"} { mset {xmargin ymargin} [$@canvas margin] mset {x y} [$@canvas xy] set x1 [expr {($@x1-$xmargin)+$x}] set y1 [expr {($@y1-$ymargin)+$y}] #if $self's gop is opened if {[regexp {^.x[0-9a-f]{6,8}.c} [focus] f]} { if {$f == ".$@canvas.c"} {set x1 $@x1; set y1 $@y1} } #if {[focus] != "." && [focus] == ".$@canvas.c"} {set x1 $@x1; set y1 $@y1} return [list $x1 $y1] } return [list $@x1 $@y1] } def View canvas {} {return $@canvas} def View canvas= {c} { set @canvas $c # should "subscribe" call "changed"? (or pretend to?) $self subscribe $c $self changed $self outside_of_the_box } def View visible {} {if {[info exists @inside_box]} {return $@inside_box} {return -1}} # this returns the canvas actually exists/drawn # see also def Canvas get_canvas def View get_canvas {} { set canvas $@canvas if {$canvas == ""} {return ""} #while {![$canvas havewindow]} {set canvas [$canvas canvas]} while {![winfo exists [$canvas widget]]} {set canvas [$canvas canvas]} return $canvas } # this will return the top level gop if gop is nested def View get_parent_gop {canvas} { set obj $self while {$canvas != [$obj canvas]} {set obj [$obj canvas]} return $obj } def View outside_of_the_box {} { if {$@canvas eq ""} {return} # always hide these things if {[$self class] == "Wire"} {set @inside_box 0; return} if {[$self class] == "ObjectBox"} {set @inside_box 0; return} if {[$self class] == "MessageBox"} {set @inside_box 0; return} if {[$self class] == "Comment"} {set @inside_box 0; return} if {[$self class] == "Array"} {$@canvas visibles+= $self; set @inside_box 1; return} set x1 $@x1; set y1 $@y1 if {[$@canvas gop]} { set mess [$@canvas get_mess] set pixwidth [lindex $mess 4] set pixheight [lindex $mess 5] if {[llength $mess] == 6} { set xmargin 0; set ymargin 0 } else { set xmargin [lindex $mess 6]; set ymargin [lindex $mess 7] } if {$x1 < $pixwidth +$xmargin && $x1 > $xmargin && \ $y1 < $pixheight+$ymargin && $y1 > $ymargin} { set @inside_box 1 $@canvas visibles+= $self } else { set @inside_box 0 $@canvas visibles-= $self } } else {set @inside_box 1} } def View draw_maybe {} { if {$@canvas == "" && [winfo exists .$self.c]} {$self draw; return} if {[$self class] == "Canvas" && $@canvas == ""} {return} if {$@inside_box} { #if {[$@canvas mapped] && ![$@canvas abs] && [$self gop_check]} {$self draw} if {[$@canvas mapped] && [$self gop_check]} {$self draw} } else { # for drawing opened gop if {[winfo exists .$@canvas.c]} {$self draw} } } #this checks if $self can be seen, ie nested gop. def View gop_check {} { set canvases $@canvas while {[lindex $canvases end] != ""} {lappend canvases [[lindex $canvases end] canvas]} set canvases [lreplace $canvases end-1 end]; # all canvases foreach canvas $canvases { # if a canvas is not a gop and its window does not exists if {![$canvas gop] && ![winfo exists [$canvas widget]]} {return 0; break} } return 1 } #-----------------------------------------------------------------------------------# class_new Canvas {Menuable ObjectBox} def Canvas close {} { after cancel $@motion_after_id if {$@subpatch} { #can't wait till @mapped get updated thru proc change if {$@gop} {foreach x [$@objects values] {$x outside_of_the_box}} $self save_geometry $self copy_times= 0 netsend [list .$self vis 0] #netsend [list .$self close] return } if {$@gop} { foreach x [$@objects values] {$x outside_of_the_box} netsend [list .$self close] return } switch [tk_messageBox2 -message [say save_changes?] -icon question -type yesnocancel -default cancel] { yes {$self save; netsend [list .$self close]} no { netsend [list .$self close]} cancel {} } } def Canvas save_geometry {} { set geometry [wm geometry .$self] set cw [winfo width [$self widget]]; set ch [winfo height [$self widget]] foreach {size x y} [split $geometry "+"] {mset {w h} [split $size "x"]; set x1 $x; set y1 $y} set x2 [expr $x1+$cw]; set y2 [expr $y1+$ch] netsend [list .$self bounds $x1 $y1 $x2 $y2] } def Canvas save {} { if {$@subpatch} {return [$@canvas save]} $self checkgeometry set c [$self widget] if {![regexp {^Untitled-[0-9]} $@name]} { $self save_geometry netsend [list .$self savetofile $@name $@folder] } else { $self save_as } } def Canvas save_as {} { $self checkgeometry set filename [tk_getSaveFile -parent $::current_window -filetypes $::patch_filetypes] if {$filename != ""} { set @file [string range $filename [expr [string last / $filename]+1] end] set @folder [string range $filename 0 [expr [string last / $filename]-1]] $self save_geometry puts "save $@file dir to $@folder" netsend [list .$self savetofile $@file $@folder] } } def Canvas print {} { set filename [tk_getSaveFile -parent $::current_window -initialfile pd.ps -defaultextension .ps -filetypes { {{postscript} {.ps}} }] if {$filename != ""} {[$self widget] postscript -file $filename} } def Canvas quit {} {$::main quit} def Canvas abort_server {} {$::main abort_server} proc wonder {} {tk_messageBox2 -message [say ask_cool] -type yesno -icon question} def Canvas eval% {code} { mset {x y} $@curpos regsub -all %X $code $x code regsub -all %Y $code $y code super $code } def Client documentation {} { set filename [tk_getOpenFile -parent $::current_window -defaultextension .pd -filetypes { {{documentation} {.pd .txt .htm}} } -initialdir $::docdir] if {$filename != ""} { if {[string first .txt $filename] >= 0} { menu_opentext $filename } elseif {[string first .htm $filename] >= 0} { menu_openhtml $filename } else { set i [string last / $filename] set help_directory [string range $filename 0 [expr $i-1]] set basename [string range $filename [expr $i+1] end] netsend [list pd open [enquote $basename] [enquote $help_directory]] } } } def Canvas new_file {} {$::main new_file} def Canvas open_file {} {$::main open_file} def Canvas send_message {} {$::main send_message} def Client test_audio_and_midi {} {menu_doc_open doc/7.stuff/tools testtone.pd } def Client load_meter {} {menu_doc_open doc/7.stuff/tools load-meter.pd} def Client latency_meter {} {menu_doc_open doc/7.stuff/tools latency.pd } def Client about {} {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