From 8dbec761cf858ea65900c8a094599857208d8c3a Mon Sep 17 00:00:00 2001 From: "N.N." Date: Tue, 5 Jan 2010 22:49:36 +0000 Subject: svn path=/trunk/; revision=12907 --- desiredata/src/desire.tk | 8712 ---------------------------------------------- 1 file changed, 8712 deletions(-) delete mode 100644 desiredata/src/desire.tk (limited to 'desiredata/src/desire.tk') diff --git a/desiredata/src/desire.tk b/desiredata/src/desire.tk deleted file mode 100644 index c4dac9d7..00000000 --- a/desiredata/src/desire.tk +++ /dev/null @@ -1,8712 +0,0 @@ -#!/usr/bin/env wish -set svnid {$Id$} -#-----------------------------------------------------------------------------------# -# -# DesireData -# Copyright (c) 2004 by Mathieu Bouchard -# Copyright (c) 2005,2006,2007 by Mathieu Bouchard and Chun Lee -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. - -# See file ../COPYING.desire-client.txt for further informations on licensing terms. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# Note that this is not under the same license as the rest of PureData. -# Even the DesireData server-side modifications stay on the same license -# as the rest of PureData. -# -#-----------------------------------------------------------------------------------# - -# this command rebuilds the package index: echo pkg_mkIndex . | tclsh - -set debug 0 ;# DON'T TOUCH THIS, make yourself a debug.tcl instead! - -if {$tcl_version < 8.5} {puts "Please upgrade to Tcl/Tk 8.5... Thank You.\n(your version is $tcl_version)"; exit 84} - -if {[catch {winfo children .}]} {set tk 0} {set tk 1} - -set argh0 [file normalize [file join [pwd] $argv0]] -set auto_path [concat . \ - [list [file join [file dirname [file dirname $argh0]] lib/pd/bin]] \ - /usr/share/tcltk/tcllib1.10/profiler \ - /usr/lib/tclx8.4 \ - $auto_path] - -package require poe -if {$tk} {package require bgerror} - -catch {package require Tclx} -#if {[catch {source /home/matju/src/svn-pd/desiredata/src/profile_dd.tcl}]} {error_dump} -if {[file exists debug.tcl]} {source debug.tcl} - -proc which {file} { - global env - foreach dir [split $::env(PATH) ":"] { - if {[file exists $dir/$file]} {return $dir/$file} - } - return "" -} - -#-----------------------------------------------------------------------------------# -# some list processing functions and some math too -# these could become another library like objective.tcl -# if they become substantial enough - -# min finds the smallest of two values -# max finds the biggest of two values -# [clip $v $min $max] does [max $min [min $max $v]] -proc min {x y} {expr {$x<$y?$x:$y}} -proc max {x y} {expr {$x>$y?$x:$y}} -proc clip {x min max} { - if {$x<$min} {return $min} - if {$x>$max} {return $max} - return $x -} - -# set several variables from elements of a list -# WARNING: for @-variables, use [list @a @b @c] instead of {@a @b @c} -proc mset {vars list} { - uplevel 1 "foreach {$vars} {$list} {break}" -} - -# add or subtract two lists -proc l+ { al bl} {set r {}; foreach a $al b $bl {lappend r [expr {$a+$b}]}; return $r} -proc l- { al bl} {set r {}; foreach a $al b $bl {lappend r [expr {$a-$b}]}; return $r} -# halve a list -proc l/2 { al } {set r {}; foreach a $al {lappend r [expr {$a/2 }]}; return $r} - -# like l+ or l- but for any infix supported by expr -proc lzip {op al bl} { - set r {} - set e "\$a $op \$b" - foreach a $al b $bl {lappend r [expr $e]} - return $r -} - -# do an operation between all elements of a list and a second argument -proc lmap {op al b } { - set r {} - set e "\$a $op \$b" - foreach a $al {lappend r [expr $e]} - return $r -} - -# sum and product of a list, like math's capital Sigma and capital Pi. -proc lsum {al} {set r 0; foreach a $al {set r [expr {$r+$a}]}; return $r} -proc lprod {al} {set r 1; foreach a $al {set r [expr {$r*$a}]}; return $r} - -# all elements from end to beginning -proc lreverse {list} { - set r {} - for {set i [expr {[llength $list]-1}]} {$i>=0} {incr i -1} {lappend r [lindex $list $i]} - return $r -} - -# list substraction is like set substraction but order-preserving -# this is the same algorithm as Ruby's - operation on Arrays -proc lwithout {a b} { - set r {} - foreach x $b {set c($x) {}} - foreach x $a {if {![info exists c($x)]} {lappend r $x}} - return $r -} - -proc lintersection {a b} { - set r {} - foreach x $b {set c($x) {}} - foreach x $a {if {[info exists c($x)]} {lappend r $x}} - return $r -} - -# removes duplicates from a list, but it must be already sorted. -proc luniq {a} { - set last [lindex $a 0] - set r [list $last] - set i 0 - foreach x $a { - if {$i && [string compare $last $x]} {lappend r $x} - incr i; set last $x - } - return $r -} - -# one-dimensional intervals (left-closed, right-open); not much in use at the moment, not that they wouldn't deserve to! -# (slightly buggy) -proc inside {x x0 x1} {return [expr {$x>=$x0 && $x<$x1}]} -proc overlap {y0 y1 x0 x1} {return [expr {[inside $y0 $x0 $x1] || [inside $y1 $x0 $x1]}]} - -proc distance {point1 point2} { - set off [l- $point1 $point2] - return [expr {sqrt([lsum [lzip * $off $off]])}] -} - -proc rect_centre {rect} { - mset {x1 y1 x2 y2} $rect - return [list [expr {($x1+$x2)/2}] [expr {($y1+$y2)/2}]] -} - -proc lmake {start end} {for {set i $start} {$i<=$end} {incr i} {lappend l $i}; return $l} -#-----------------------------------------------------------------------------------# -set callback_list {} - -proc append_callback {mode when def} { - global callback_list - dict set callback_list $mode $when $def -} - -proc remove_callback {mode} { - global callback_list - set callback_list [dict remove $callback_list $mode] -} - -proc modes_callback {self def {args}} { - global callback_list - set i 0 - dict for {mode callbacks} $callback_list { - foreach {when call} $callbacks { - if {$def == $when} {eval $self $call $args; incr i} - } - } - if {!$i} {return 0} else {return 1} -} - -#-----------------------------------------------------------------------------------# -# Observer pattern -# there's no class for "observer". -# it's anything that has def $myclass notice {args} {...} in which args indicate -# attributes that have changed, or is an empty list if an unspecified number of -# attributes (maybe all) have changed. - -class_new Observable {} -def Observable init {args} { - eval [concat [list super] $args] - set @subscribers {} -} -def Observable subscribe {observer} { - set i [lsearch $@subscribers $observer] - if {$i<0} {lappend @subscribers $observer} -} -def Observable unsubscribe {observer} { - set i [lsearch $@subscribers $observer] - if {$i>=0} {set @subscribers [lreplace $@subscribers $i $i]} -} - -if {$have_expand} { - #def Observable changed {args} { - # puts "Observable changed $self called from [info level [expr [info level]-2]]" - # foreach x $@subscribers {$x notice $self {expand}$args]} - #} - def Observable changed {args} {foreach x $@subscribers {$x notice $self {expand}$args}} - def Observable child_changed {origin args} {foreach x $@subscribers {$x notice $origin {expand}$args}} -} else { - def Observable changed {args} {foreach x $@subscribers {$x notice $self {*}$args}} - def Observable child_changed {origin args} {foreach x $@subscribers {$x notice $origin {*}$args}} -} -def Observable subscribers {} {return $@subscribers} - -#-----------------------------------------------------------------------------------# -set poolset(foo) bar -array unset poolset foo - -class_new Manager {Thing} - -def Manager init {} { - set @q {} - $self call -} - -def Manager call {} { - #if {[llength $@q]} {post "client queue %d" [llength $@q]} - for {set i 0} {$i < [llength $@q]} {incr i} { - set o [lindex $@q $i] - unset ::poolset($o) - if {[info exists _($o:_class)]} { - if {[catch {$o draw_maybe}]} {puts [error_dump]} - } else { - puts " tries to draw ZOMBIE $o" - } - if {$i == [expr {[llength $@q]-1}]} {set @q {}} - } - after 25 [list $self call] -} - -def Manager notice {origin args} { - if {[info exists ::poolset($origin)]} { - # post %s "def Manager notice: double dirty" - # nothing for now - } { - set ::poolset($origin) {-1} - lappend @q $origin - } - #post "Manager notice: queue length is now %d" [llength $@q] -} - -set serial 0 -proc serial {n obj} { - if {$n >= $::serial} {error "object creation serial number is in the future"} - eval [concat $::replyset($n) [list $obj]] - array unset ::replyset $n -} - -proc philtre {atoms} { - set r {} - foreach atom $atoms {lappend r [regsub -all {([;,\\ ])} $atom {\\\1}]} - return [join $r] -} - -# you pass the 2nd argument if and only if the message creates an object (or pretends to). -# this happens with #N canvas, and those methods of #X: -# obj, msg, floatatom, symbolatom, text, connect, text_setto, array. -# this does NOT happen with #X coords/restore/pop. -proc netsend {message {callback ""}} { - #if {$message == ""} {error "empty message... surely a mistake"} - if {$::sock == ""} {error "connection to server needed for doing this"} - if {$callback != ""} { - set ::replyset($::serial) $callback - set message [concat [lrange $message 0 0] [list with_reply $::serial] [lrange $message 1 end]] - incr ::serial - } - set text "[philtre $message];" - if {$::debug} {puts "[VTcyan]<- $text[VTgrey]"} - puts $::sock $text -} - -#-----------------------------------------------------------------------------------# -# This is not a real Hash, just the same interface as a Ruby/Python/Perl Hash... or quite like Tcl arrays themselves -class_new Hash {Thing} - -def Hash init {args} { super; foreach {k v} $args {$self set $k $v}} -def Hash reinit {args} {$self clear; foreach {k v} $args {$self set $k $v}} -def Hash set {k v} {set ::hash($self:$k) $v} -def Hash exists {k} {info exists ::hash($self:$k)} -def Hash get {k} {set ::hash($self:$k)} -def Hash size {} {llength [$self keys]} -def Hash unset {k} {unset ::hash($self:$k)} -def Hash list {} {set r {}; foreach k [$self keys] {lappend r $k [$self get $k]}; return $r} -def Hash keys {} { - set r {} - set n [string length $self:] - foreach k [array names ::hash $self:*] {lappend r [string range $k $n end]} - return $r -} -def Hash values {} { - set r {} - foreach k [array names ::hash $self:*] {lappend r $::hash($k)} - return $r -} -def Hash clear {} {foreach k [$self keys] {$self unset $k}} -def Hash delete {} {$self clear; super} - -def Hash search {v} { - foreach k [$self keys] {if {[$self get $k] == $v} {return $k}} - return -1 ;# this is not correct as -1 could be a Hash key, though not in its current context of use... -} - -if 0 { - set h [Hash new foo bar 1 2 3 4] - $h set hello world - puts keys=[$h keys] - puts values=[$h values] - puts list=[$h list] - $h unset foo - puts list=[$h list] - $h clear - puts list=[$h list] - foreach i {1 2 3 4} {puts "exists $i : [$h exists $i]"} -} - -class_new Selection {Hash} -def Selection set {k v} {super $k $v; $v selected?= 1} -def Selection unset {k} { - #set v [$self get $k]; puts "$v ::: [$v class]" - if {[$self exists $k]} {[$self get $k] selected?= 0} - super $k -} -#-----------------------------------------------------------------------------------# -# abstract class: subclass must def {value value= <<} -class_new Clipboard {Observable Thing} -def Clipboard init {{value ""}} {super; $self value= $value; set @copy_count 0} - -# uses system clipboard -class_new Clipboard1 {Clipboard} -def Clipboard1 value= {value} {clipboard clear; clipboard append $value; $self changed} -def Clipboard1 << {value} { clipboard append $value; $self changed} -def Clipboard1 value {} {clipboard get} - -# uses string buffer (not system clipboard) -class_new Clipboard2 {Clipboard} -def Clipboard2 value= {value} {set @value $value; $self changed} -def Clipboard2 << {value} {append @value $value; $self changed} -def Clipboard2 value {} {return $@value} - -if {$tk} { - set clipboard [Clipboard1 new] -} else { - set clipboard [Clipboard2 new] -} - -#-----------------------------------------------------------------------------------# -class_new EventHistory {Observable Thing} - -def EventHistory init {} {super; set @list {}} -def EventHistory add {e} {lappend @list $e; $self changed add $e} -def EventHistory list {{formatted 1}} { - if {!$formatted} {return $@list} - set r {} - foreach event $@list { - mset {type W x y mod K k} $event - lappend r [format "%-13s %9s %4d %4d %4d %4d %s" $type $K $k $x $y $mod $W] - } - return $r -} -set ::event_history [EventHistory new] - -#-----------------------------------------------------------------------------------# -class_new CommandHistory {Observable Thing} - -def CommandHistory init {} { - super - set @undo_stack {} - set @redo_stack {} -} - -def CommandHistory can_undo? {} {return [expr {[llength @undo_stack] > 0}]} -def CommandHistory can_redo? {} {return [expr {[llength @redo_stack] > 0}]} -def CommandHistory next_undo_name {} {return stuff} -def CommandHistory next_redo_name {} {return stuff} -def CommandHistory undo_stack {} {return $@undo_stack} -def CommandHistory redo_stack {} {return $@redo_stack} - -# overload this if you want to control how many levels -# of undo may be kept. -# keep in mind that undo information is kept hierarchically. -def CommandHistory add {message} { - lappend @undo_stack [list do $message [lrange [info level -3] 1 end]] - set @redo_stack {} - $self changed -} - -def CommandHistory can't {} { - lappend @undo_stack [list can't {} [lrange [info level -3] 1 end]] - set @redo_stack {} - $self changed -} - -# runs the restore procedure for the last item in the root undo queue. -def CommandHistory undo {} { - if {![$self can_perform? [lindex $@undo_stack end]]} {error "Can't undo this!"} - set backup $@undo_stack - set @undo_stack $@redo_stack - set @redo_stack {} - #set err [catch {$self perform [lindex $backup end]}]; if {$err} {set err $::errorInfo} - $self atomically [list atomic_undo] { - $self perform [lindex $backup end] - } - set @redo_stack $@undo_stack - set @undo_stack [lrange $backup 0 end-1] - $self changed - #if {$err} {post %s $err; error "undo: $err"} -} - -def CommandHistory redo {} { - if {![$self can_perform? [lindex $@undo_stack end]]} {error "Can't redo this!"} - set backup $@redo_stack - set @redo_stack {} - set err [catch {$self perform [lindex $backup end]}]; if {$err} {set err $::errorInfo} - $self atomically [list atomic_redo] { - $self perform [lindex $backup end] - } - set @redo_stack [lrange $backup 0 end-1] - $self changed - #if {$err} {post %s $err; error "redo: $err"} -} - -def CommandHistory can_perform? {action} { - switch -- [lindex $action 0] { - do {return 1} - can't {return 0} - default { - foreach x [lrange $action 1 end] { - if {![$self can_perform? $x]} {return 0} - } - return 1 - } - } -} - -def CommandHistory perform {action} { - switch -- [lindex $action 0] { - do {eval [lindex $action 1]} - can't {error "can't undo this!"} - default {foreach x [lreverse [lindex $action 1]] {$self perform $x}} - } -} - -def CommandHistory atomically {what code} { - set ubackup @undo_stack; set @undo_stack {} - set rbackup @redo_stack; set @redo_stack {} - uplevel 2 $code - set atom $@undo_stack - set @undo_stack $ubackup - set @redo_stack $rbackup - lappend @undo_stack [list $what $atom [lrange [info level -3] 1 end]] - $self changed -} - -def CommandHistory list {} { - set r {} - set hist [concat [$self undo_stack] [list "You Are Here"] [lreverse [$self redo_stack]]] - set i 0 - foreach e $hist {lappend r "$i: $e"; incr i} - return $r -} - -set command_history [CommandHistory new] - -#-----------------------------------------------------------------------------------# -class_new History {Thing} - -def History init {size} { - set @size $size - set @hist {{}} - set @histi -1 -} - -def History histi= {val} {set @histi $val} -def History histi {} {return $@histi} - -def History set_hist {idx stuff} {set @hist [lreplace $@hist $idx $idx $stuff]} - -def History prepend {stuff} { - set @hist [linsert $@hist 1 $stuff] - if {[llength $@hist] >= $@size} {set @hist [lrange $@hist 0 [expr {$@size-1}]]} -} - -def History traverse {incr} { - set @histi [expr {$@histi + $incr}] - set mod [min [llength $@hist] [expr {$@size+1}]] - if {$@histi >=$mod} {set @histi [expr $@histi%$mod]} - if {$@histi < 0} {set @histi [expr ($@histi+$mod)%$mod]} - return [lindex $@hist $@histi] -} - -History new_as obj_hist 5 -#-----------------------------------------------------------------------------------# -# this is the beginning of the more application-dependent part. - -switch $tcl_platform(os) { - Darwin {set OS osx} - default {set OS $tcl_platform(platform)} -} - -if {$tk} { - option add *foreground #000000 - option add *font {Helvetica -12} - foreach tkclass {Menu Button Checkbutton Radiobutton Entry Text Spinbox Scrollbar Canvas} { - option add *$tkclass*borderWidth 1 - option add *$tkclass*activeBorderWidth 1 - } - foreach tkclass {CheckButton RadioButton} { - option add *$tkclass*selectColor #dd3000 - } - foreach tkclass {Entry Text} { - option add *$tkclass*background #b0c4d8 - option add *$tkclass*selectBackground #6088b0 - } - option add *__tk__messagebox*Canvas*borderWidth 0 - foreach tkclass {Listbox} { - option add *$tkclass*background #c4d8b0 - option add *$tkclass*selectBackground #88b060 - } - foreach tkclass {Label} { - #option add *$tkclass*background #909090 - } - # very small icons: - foreach {name w h values} { - icon_empty 7 7 "0,0,0,0,0,0,0" - icon_plus 7 7 "8,8,8,127,8,8,8" - icon_minus 7 7 "0,0,0,127,0,0,0" - icon_close 7 7 "99,119,62,28,62,119,99" - icon_wedge_up 7 5 "8,28,62,127,0" - icon_wedge_down 7 5 "0,127,62,28,8" - icon_up 7 7 "8,28,62,127,28,28,28" - icon_down 7 7 "28,28,28,127,62,28,8" - icon_right 7 7 "8,24,63,127,63,24,8" - icon_left 7 7 "8,12,126,127,126,12,8" - } { - image create bitmap $name -data "#define z_width $w\n#define z_height $h - static unsigned char z_bits[] = { $values };" - } - - - set main [. cget -class] - set ::current_window . - bind $main {set ::current_window %W} - bind Toplevel {set ::current_window %W} - proc tk_messageBox2 {args} {tk_messageBox -parent $::current_window {*}$args} - - # Also we have to get rid of tab's changing the focus. - bind all "" - #bind all "" - bind all <> "" - set mods {{} 0 Shift- 1 Control- 4 Shift-Control- 5 Alt- 8 Shift-Alt- 9 Control-Alt- 12 Shift-Control-Alt- 13} - foreach type {KeyPress KeyRelease} { - foreach {subtype mod} $mods { - bind all <$subtype$type> "$::event_history add \[list $type %W %x %y $mod %K %k\]" - } - } - foreach type {ButtonPress ButtonRelease} { - foreach {subtype mod} $mods { - bind all <$subtype$type> "$::event_history add \[list $type %W %x %y $mod %b %b\]" - } - } -} - -proc modekey {k mode} { - set s "" - if {$mode&1} {append s Shift-} - if {$mode&4} {append s Control-} - if {$mode&8} {append s Alt-} - if {[regexp {[0-9]} $k]} {set k Key-$k} - return $s$k -} - -proc modeclick {k mode event} { - set s "" - if {$mode&1} {append s Shift-} - if {$mode&4} {append s Control-} - if {$mode&8} {append s Alt-} - if {[regexp {[0-9]} $k]} {set k $event-$k} - return $s$k -} - -# there are two palettes of 30 colours used in Pd -# when placed in a 3*10 grid, the difference is that -# the left corner of 3*3 (the greys) are transposed (matrixwise) -# here is the one used in the swatch color selector: -set preset_colors { - fcfcfc e0e0e0 bcbcbc fce0e0 fce0c0 fcfcc8 d8fcd8 d8fcfc dce4fc f8d8fc - a0a0a0 7c7c7c 606060 fc2828 fcac44 e8e828 14e814 28f4f4 3c50fc f430f0 - 404040 202020 000000 8c0808 583000 782814 285014 004450 001488 580050 -} - -switch $::OS { - osx {set pd_tearoff 0} - default {set pd_tearoff 1} -} - -proc guess_lang {} { - set lang C - if {[info exist ::env(LC_ALL)]} {set lang $::env(LC_ALL)} - if {[info exist ::env(LANG)]} {set lang $::env(LANG)} - set lang [lindex [split $lang {[_.]}] 0] - return $lang -} - -#temporary -set leet 0 - -proc say {k args} { - global text - if {[llength $args]} { - set text($k) [lindex $args 0] - } else { - if {[info exist text($k)]} { - if {$::leet} { - return [string map -nocase {a 4 e 3 t 7 s 5 i 1 o 0 g 9} $text($k)] - } else { - return $text($k) - } - } else {return "{{$k}}"} - } -} - -proc can_say {k args} { - return [info exist ::text($k)] -} - -proc say_namespace {k code} {uplevel 1 $code} -proc say_category {text} {} - -switch -- [lindex [file split $argh0] end] { - desire.tk {set cmdline(server) [file join [file dirname $argh0] pd]} - default {set cmdline(server) [file join [file dirname [file dirname $argh0]] bin/pd]} -} - -set cmdline(rcfilename) ~/.pdrc -set cmdline(ddrcfilename) ~/.ddrc -set cmdline(console) 1000 -if {[file exists ../icons/mode_edit.gif]} { - set cmdline(icons) ../icons -} else { - set cmdline(icons) [file join [file dirname [file dirname $argh0]] lib/pd/icons] -} - -#-----------------------------------------------------------------------------------# -set accels {} -proc read_client_prefs_from {filename} { - global cmdline look key accels - set ::accels {} - puts "reading from $filename" - set fd [open $filename] - set contents [read $fd] - close $fd - foreach {category category_data} $contents { - foreach {class class_data} $category_data { - foreach {var val} $class_data {set ${category}($class:$var) $val} - } - } - foreach k [array names key] { - if {[llength $key($k)]} { - if {![dict exists $accels $key($k)]} { - dict set accels $key($k) $k - } else { - dict lappend accels $key($k) $k - } - } - } -} -proc read_ddrc {} { ;# load defaults then load .ddrc - if {[file exists "defaults.ddrc"]} { - read_client_prefs_from "defaults.ddrc" - } else { - read_client_prefs_from [file join [file dirname [file dirname $::argh0]] "lib/pd/bin/defaults.ddrc"] - } - if {[file exists $::cmdline(ddrcfilename)]} { - read_client_prefs_from $::cmdline(ddrcfilename) - } -} -read_ddrc - -#-----------------------------------------------------------------------------------# - -set cmdline(port) 0 -set cmdline(gdb) 0 -set cmdline(gdbconsole) 1 -set cmdline(valgrind) 0 -if {$look(View:language) eq "auto"} { - set language [guess_lang] -} else { - set language $look(View:language) -} - -set files_to_open {} - -proc cmdline_help {} { - puts "DesireData commandline options: - -serverargs (for future use) - -server select the executable for the pd server - -gdb run pd server through gdb - -manualgdb run gdb in the terminal - -valgrind run pd server through valgrind - -novalgrind ... or don't - -safemode run desiredata with all default settings - -dzinc use zinc emulation" -} - -for {set i 0} {$i < $argc} {incr i} { - global cmdline files_to_open - set o [lindex $argv $i] - switch -regexp -- $o { - ^-port\$ {incr i; set cmdline(port) [lindex $argv $i]} - ^-serverargs\$ {error "not supported yet"} - ^-server\$ {incr i; set cmdline(server) [lindex $argv $i]} - ^-gdb\$ {set cmdline(gdb) 1} - ^-manualgdb\$ {set cmdline(gdbconsole) 0} - ^-valgrind\$ {set cmdline(valgrind) 1} - ^-novalgrind\$ {set cmdline(valgrind) 0} - ^-safemode\$ {set cmdline(safemode) 1} - ^-dzinc\$ {set cmdline(dzinc) 1} - ^(-h|-help|--help)\$ {cmdline_help; exit 1} - ^- {puts "ERROR: command line argument: unknown $o"} - default {lappend files_to_open [lindex $argv $i]} - } -} - -#set cmdline(server) \"$cmdline(server)\" -set encoding "" -if {$language == "C"} {set language en} -proc localedir {x} {file join [file dirname [file dirname $::argh0]] lib/pd/bin/$x} -if {[regexp {desire\.tk$} $argh0]} {source locale/index.tcl} {source [localedir locale/index.tcl]} -puts "locale/index.tcl vs [localedir locale/index.tcl]" -set langentry [figure_out_language $language] -set encoding [lindex $langentry 0] -set langfile locale/[lindex $langentry 1].tcl -if {[regexp {desire\.tk$} $argh0]} { - if {$encoding != ""} {source -encoding $encoding $langfile} else {source $langfile} -} else { - if {$encoding != ""} {source -encoding $encoding [localedir $langfile]} else {source [localedir $langfile]} -} - -if {[info exists ::cmdline(safemode)]} {read_client_prefs_from "defaults.ddrc"} -if {[info exists ::cmdline(dzinc)]} {package require dzinc} - -#-----------------------------------------------------------------------------------# - -#!@#$ is this still valid? -set look(Box:extrapix) [switch $::OS { - osx {concat 2} - default {concat 1}}] - -#font is defined as Thing for now, as the completion needs to get to these ones. - -#!@#$ View->??? -#set look(View:tooltip) 1 - -#!@#$ View->TextBox ? -#set look(View:minobjwidth) 21 - -#!@#$ View->ObjectBox -#set look(View:fg) #000000 -#set look(View:bg) #ffffff -#set look(View:frame1) #99cccc -#set look(View:frame2) #668888 -#set look(View:frame3) #000000 - -set zoom(canned) [list 25 33 50 75 100 125 150 200 250 300 400] -set scale_amount 1.1 -################## set up main window ######################### - -class_new Console {View} - -def Console osx_scroll {axis diff} {$@c.1 yview scroll [expr {-2-abs($diff)/$diff}]} - -def Console init {c} { - set @c $c - frame $c - text $c.1 -width 72 -height 20 -yscrollcommand "$c.2 set" -font [$self look font] - scrollbar $c.2 -command "$c.1 yview" - pack $c.1 -side left -fill both -expand yes - pack $c.2 -side left -fill y -expand no - pack $c -fill both -expand yes - $c.2 set 0.0 1.0 - switch $::OS {osx {bind $c.1 [list $self osx_scroll %D]}} - set @lines 0 -} - -def Console widget {} {return $@c} - -def Console post_string {x} { - set oldpos [lindex [$@c.2 get] 1] - $@c.1 insert end $x - regsub -all "\n" $x "" y - set n [expr {[string length $x]-[string length $y]}] - incr @lines $n - set max $::cmdline(console) - if {$@lines >= $max} {$@c.1 delete 1.0 [expr {$@lines-$max+1}].0; set @lines $max} - if {$oldpos > 0.9999} {$@c.1 see end} -} - -#class_new Client {Menuable View} -class_new Client {Menuable Thing} - -set ctrls_audio_on 0 -set ctrls_meter_on 0 - -def Client window {} {return .} - -def Client init_binds {} { - bind . {$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} - if {[regexp {\d\d\d\d-\d\d-\d\d} $::svnid date]} { - regsub -all "/" $date "." date - regexp {desire.tk (\d+)} $::svnid blah revision - set version "svn#$revision ($date)" - } {set version "(unknown svn version)"} - set ::pd_version_client $version - post "DesireData client version %s" $version - post "Running from %s" [info script] - post "Using Tcl %s and Tk %s" $::tcl_patchLevel $::tk_patchLevel -} - -proc pdtk_pd_dsp {value} { - global ctrls_audio_on - set ctrls_audio_on $value -} - -proc pdtk_pd_dio {red} { - .controls.dio configure -background red -activebackground [if {$red==1} {list red} {list lightgrey}] -} - -############### set up global variables ################################ - -set pd_opendir [pwd] - -############### set up socket ########################################## -set sock {} -set sock_lobby {} - -proc poll_sock {} { - global sock sock_lobby cmdline - if {[llength $sock]==0} {return} - while {1} { - set cmd [gets $sock] - if {[eof $sock]} { - if {!$cmdline(gdb)} { - tk_messageBox2 -message "connection ended by server.\n(crash? try: desire -gdb)" -type ok - } - set sock {} - return - } - if {[fblocked $sock]} {break} - if {$::debug} {if {[string first pdtk_post $cmd]!=0} {puts "[VTmagenta]-> $cmd[VTgrey]"}} - append sock_lobby "\n$cmd" - if {[catch {eval $sock_lobby}]} { - switch -regexp -- $::errorInfo { "^missing close-brace" { - #puts "waiting for the end of: [string range $sock_lobby 0 40]" - continue - }} - error_dump - } - set sock_lobby {} - } - flush $sock - after 25 poll_sock -} - -set server_pid 0 -proc poll_gdb {} { - global gdb - while {1} { - set line [gets $gdb] - if {$line=="" || [fblocked $gdb]} {break} ;# which way should i check for no input? - if {[eof $gdb]} {return} - regsub {^\(gdb\) ?} $line {} line - if {[regexp {^\[Thread debug} $line]} {continue} - if {[regexp {^\[New Thread.*LWP (\d+)} $line dummy pid]} { - if {!$::server_pid} { - set ::server_pid $pid - post "server pid=$pid" - continue - } - } - if {[regexp {^Reading symbols from} $line]} {continue} - if {[regexp {^Using host libthread_db} $line]} {continue} - if {[regexp {^Starting program:} $line]} {continue} - if {[regexp {^Program received signal (\w+), (.*)\.} $line bogus sig1 sig2]} { - set where "" - # can anyone figure out why a long backtrace won't be slurped in this case? - set timeout [expr {[clock seconds]+2}] - #fconfigure $gdb -blocking 1 -buffering none - while {![eof $gdb] && [clock seconds] < $timeout} { - set line [gets $gdb] - if {$line eq ""} {continue} ;# busy-wait - regsub {^\(gdb\) ?} $line {} line - append where "$line\n" - #puts "where size = [string length $where]" - } - OopsDialogue new $sig1 $sig2 $where - } - post "\[gdb\] %s" $line - } - after 100 poll_gdb -} - -proc pd_connect {} { - global sock - if {[catch {set sock [socket 127.0.0.1 13666]}]} { - post "can't connect... wait a second" - after 1000 pd_connect - return - } - post "Connected to server" - fconfigure $sock -blocking 0 -buffering line - netsend [list pd init] - poll_sock - foreach f $::files_to_open { - set ff [file split [file normalize $f]] - set ffl [llength $ff] - set file [lindex $ff [expr $ffl-1]] - set dir [join [lrange $ff 0 [expr $ffl-2]] [file separator]] - netsend [join [list pd open $file $dir]] - } -} - -set server_port 13666 -after 1000 pd_connect - -after 0 { - if {$cmdline(port)} { - set server_port $cmdline(port) - # and then do nothing... - } elseif {$cmdline(valgrind)} { - #exec valgrind --tool=memcheck $cmdline(server) -guiport $server_port & - exec valgrind --tool=memcheck --gen-suppressions=all --suppressions=valgrind3.supp $cmdline(server) -guiport $server_port & - } else { - if {$cmdline(gdb)} { - if {$cmdline(console) && $cmdline(gdbconsole)} { - set gdb [open "| gdb --quiet 2&>1" w+] - fconfigure $gdb -blocking 0 -buffering none - puts $gdb "file \"$cmdline(server)\"" ;# bad quoting, sorry - puts $gdb "set width 242" - puts $gdb "run -guiport $server_port" - puts $gdb "where" - puts $gdb "quit" - flush $gdb - after 0 poll_gdb - } else { - exec gdb --args $cmdline(server) -guiport $server_port & - #exec gdb --tui --args $cmdline(server) -guiport $server_port & - } - } else { - exec $cmdline(server) -guiport $server_port & - } - } -} - -################ utility functions ######################### - -proc enquote {x} { - set foo [string map {"," "" ";" "" "\"" ""} $x] - return [string map {" " "\\ " "{" "" "}" ""} $foo] -} - -proc pdtk_watchdog {} {netsend [list pd ping]; after 2000 {pdtk_watchdog}} - -proc accel_munge {acc} { - switch $::OS { - osx { - set tmp [string toupper [string map {Ctrl Meta} $acc] end] - if [string is upper [string index $acc end]] { - return Shift+$tmp - } else { - return $tmp - } - } - default {return $acc} - } -} - -# a menuable must be a View -# and it must have a window so that the Menuable methods work -# it could be renamed to Windowed -class_new Menuable {} -def Menuable init {args} { - eval [concat [list super] $args] - set @accel {} - set @menubar .$self.m -} - -# this doesn't have to do with menus, only with toplevel windows. -def Menuable raise {} { - set w [$self window] - set w $w.c - raise $w - focus -force $w -} - -set untitled_number 1 -set untitled_folder [pwd] - -# just a dummy proc -proc none {args} {} - -def Client new_file {} { - global untitled_number untitled_folder - netsend [list pd filename Untitled-$untitled_number $untitled_folder] - netsend [list #N canvas] - netsend [list #X pop 1] - incr untitled_number -} - - -set patch_filetypes { - {"pd files" ".pd"} - {"max files" ".pat"} - {"all files" "*"} -} - -set image_filetypes { - {"image files" ".gif .png"} - {"gif files" ".gif"} - {"png files" ".png"} - {"all files" "*"} -} - -catch {tk_getOpenFile -load-once} ;#only works with tcltk 8.5 -catch { - set ::tk::dialog::file::showHiddenBtn 1 - set ::tk::dialog::file::showHiddenVar 0 -} - -def Client open_file {} { - global pd_opendir patch_filetypes - set filename [tk_getOpenFile -parent $::current_window -defaultextension .pd -filetypes $patch_filetypes -initialdir $pd_opendir] - if {$filename != ""} {$self open_file_really $filename} -} - -def Client open_file_really {filename} { - set i [string last / $filename] - set folder [string range $filename 0 [expr $i-1]] - set ::pd_opendir $folder - set basename [string range $filename [expr $i+1] end] - if {[string last .pd $filename] >= 0} { - netsend [list pd open $basename $folder] - } -} - -def Client send_message {} { - toplevel .sendpanel - set e .sendpanel.entry - pack [entry $e -textvariable send_textvar] -side bottom -fill both -ipadx 100 - $e select from 0 - $e select adjust end - bind $e {netsend $send_textvar; after 50 {destroy .sendpanel}} - focus $e -} - -def Client quit {} { - set answer [tk_messageBox2 -message "Do you really wish to quit?" -type yesno -icon question] - switch -- $answer {yes {netsend [list pd quit]; exit}} -} - -def Client abort_server {} { - set answer [tk_messageBox2 -message "Do you really wish to abort?" -type yesno -icon question] - switch -- $answer {yes {exec kill -ABRT $::server_pid}} -} - -def Client server_prefs {} {ServerPrefsDialogue new_as pdrc} -def Client client_prefs {} {ClientPrefsDialogue new_as ddrc} - -proc menu_pop_pd {} {raise .} - -def Menuable populate_menu {menu list} { - global key - if {[string index $menu 0] != "."} {set menu $@menubar.$menu} - foreach name $list { - if {$name == ""} {$menu add separator; continue} - set k "" - if {[info exists key($@_class:$name)]} { - if {[string length $key($@_class:$name)]} {set k $key($@_class:$name)} - } - $menu add command -label [say $name] -command "$self $name" -accelerator [accel_munge $k] - } -} - -def Client init_menus {} { - #removed paths after send_message - $self populate_menu file { - new_file open_file {} - server_prefs client_prefs send_message {} - audio_on audio_off {} - abort_server quit} - $self populate_menu help { - about documentation class_browser do_what_i_mean {} - test_audio_and_midi load_meter latency_meter {} - clipboard_view command_history_view event_history_view keyboard_view client_class_tree} -} - -def Client init {} { - super - set @menubar .mbar - $self init_controls - $self init_binds - $self init_menus - # it's necessary to raise the window on OSX - switch $::OS { osx {raise .; wm iconify .; after 100 {wm deiconify .}}} - after 0 { - Listener new .tcl [say "tcl_console"] tcl_eval - Listener new .pd [say "pd_console"] pd_eval - } - #wm geometry .[$self keyboard_view] -0+0 - #wm geometry .[$self event_history_view] -0-0 -} - -proc post {args} { - set s "[eval [linsert $args 0 format]]\n" - # set s "[info level -1]: $s" - if {$::cmdline(console)} {$::console post_string $s} else {puts stderr $s} -} -proc pdtk_post {s} { - if {$::cmdline(console)} {$::console post_string $s} else {puts stderr $s} -} - -def Menuable eval% {code} { - regsub -all %W $code $self code - uplevel [info level] $code -} - -def Menuable getkey {k} { - global accels - if {[dict exists $accels $k]} { - set vars [dict get $accels $k] - foreach var $vars { - #mset {class key} [split [dict get $accels $k] ":"] - mset {class key} [split $var ":"] - #if {$class != $@_class} {return ""} else {return $key} - if {$class == $@_class} {return $key} - } - } -} - -def Menuable ctrlkey {x y key iso shift} { - set key [if {$shift} {string toupper $key} {string tolower $key}] - set key "Ctrl+$key" - set cmd [$self getkey $key] - if {![string length $cmd]} { - switch [$self class]:$key { - #explicitly listed here to do nothing - Client:Ctrl+c {} - Client:Ctrl+v {} - default {post "unknown key $key"} - } - } else {$self eval% "%W $cmd"} -} - -def Menuable altkey {x y key iso shift} { - set key [if {$shift} {string toupper $key} {string tolower $key}] - set key "Alt+$key" - set cmd [$self getkey $key] - if {[string length $cmd]} {$self eval% "%W $cmd"} else {post "unknown key $key"} -} - -#-----------------------------------------------------------------------------------# -set pd_apilist "{ALSA 1}" -set pd_apilist2 "default" - -#-----------------------------------------------------------------------------------# -#fixme: actually, is it ok that View= 0} { - incr find - set w [lindex $args $find] - lset args $find [format %.0f [expr {$w*$zoom}]] - } - set find [lsearch $args "-font"] - if {$find >= 0} { - incr find - set fs [lindex [lindex $args $find] 1] - lset args $find 1 [format %.0f [expr {$fs*$zoom}]] - } - #set find [lsearch $args "-fill"] - #if {$find >= 0} { - # incr find - # set fill [lindex $args $find] - # lset args $find [randomise_color $fill] - #} - set tags {} - foreach s $suffixes {lappend tags "$self$s"} - set ss [lindex $tags 0] - lappend tags $self - set tags [concat $tags [$self classtags]] -} -append item [correct_splat { - if {![llength [$c gettags $ss]]} { - $c create $type $coords -tags $tags {*}$args - } { - $c itemconfigure $ss {*}$args - $c coords $ss {*}$coords - } -}] -def View item {suffixes type coords args} $item - -def View item_delete {{suffix all}} { - if {$@canvas == ""} {return} - set c [$@canvas widget] - if {![winfo exists $c]} { - set canvas [$@canvas get_canvas] - if {$canvas == ""} {return} - set c [[$@canvas get_canvas] widget] - if {![winfo exists $c]} {return} - } - switch -- $suffix { - all {$c delete $self} - default {$c delete $self$suffix}} -} - -def View draw {} {} - -def View delete {} {$self erase; super} -def View erase {} {$self item_delete} -def View selected? {} {return $@selected?} -def View selected?= {x} {set @selected? $x; $self changed} ;# this is for use by the Selection class only -def View edit? {} {if {[info exists @edit]} {return $@edit} else {return 0}} -def View select {state} { - set ostate [$self selected?] - set @selected? $state - if {$state!=$ostate} {$self changed} -} - -# give topleft point of an object in the canvas it's rendered in. -# this includes GOP and excludes zoom. -# inheritance problem: this doesn't work for Wire, which doesn't store its positions -def View xy {} { - if {$@canvas == ""} {return [list $@x1 $@y1]} - set type [$@canvas type] - if {$type == "gopabs" || $type == "gopsub"} { - mset {xmargin ymargin} [$@canvas margin] - mset {x y} [$@canvas xy] - set x1 [expr {($@x1-$xmargin)+$x}] - set y1 [expr {($@y1-$ymargin)+$y}] - #if $self's gop is opened - if {[regexp {^.x[0-9a-f]{6,8}.c} [focus] f]} { - if {$f == ".$@canvas.c"} {set x1 $@x1; set y1 $@y1} - } - #if {[focus] != "." && [focus] == ".$@canvas.c"} {set x1 $@x1; set y1 $@y1} - return [list $x1 $y1] - } - return [list $@x1 $@y1] -} - -def View canvas {} {return $@canvas} -def View canvas= {c} { - set @canvas $c - # should "subscribe" call "changed"? (or pretend to?) - $self subscribe $c - $self changed - $self outside_of_the_box -} - -def View visible {} {if {[info exists @inside_box]} {return $@inside_box} {return -1}} - -# this returns the canvas actually exists/drawn -# see also def Canvas get_canvas -def View get_canvas {} { - set canvas $@canvas - if {$canvas == ""} {return ""} - #while {![$canvas havewindow]} {set canvas [$canvas canvas]} - while {![winfo exists [$canvas widget]]} {set canvas [$canvas canvas]} - return $canvas -} -# this will return the top level gop if gop is nested -def View get_parent_gop {canvas} { - set obj $self - while {$canvas != [$obj canvas]} {set obj [$obj canvas]} - return $obj -} - -def View outside_of_the_box {} { - if {$@canvas eq ""} {return} - # always hide these things - if {[$self class] == "Wire"} {set @inside_box 0; return} - if {[$self class] == "ObjectBox"} {set @inside_box 0; return} - if {[$self class] == "MessageBox"} {set @inside_box 0; return} - if {[$self class] == "Comment"} {set @inside_box 0; return} - if {[$self class] == "Array"} {$@canvas visibles+= $self; set @inside_box 1; return} - set x1 $@x1; set y1 $@y1 - if {[$@canvas gop]} { - set mess [$@canvas get_mess] - set pixwidth [lindex $mess 4] - set pixheight [lindex $mess 5] - if {[llength $mess] == 6} { - set xmargin 0; set ymargin 0 - } else { - set xmargin [lindex $mess 6]; set ymargin [lindex $mess 7] - } - if {$x1 < $pixwidth +$xmargin && $x1 > $xmargin && \ - $y1 < $pixheight+$ymargin && $y1 > $ymargin} { - set @inside_box 1 - $@canvas visibles+= $self - } else { - set @inside_box 0 - $@canvas visibles-= $self - } - } else {set @inside_box 1} -} - -def View draw_maybe {} { - if {$@canvas == "" && [winfo exists .$self.c]} {$self draw; return} - if {[$self class] == "Canvas" && $@canvas == ""} {return} - if {$@inside_box} { - #if {[$@canvas mapped] && ![$@canvas abs] && [$self gop_check]} {$self draw} - if {[$@canvas mapped] && [$self gop_check]} {$self draw} - } else { - # for drawing opened gop - if {[winfo exists .$@canvas.c]} {$self draw} - } -} -#this checks if $self can be seen, ie nested gop. -def View gop_check {} { - set canvases $@canvas - while {[lindex $canvases end] != ""} {lappend canvases [[lindex $canvases end] canvas]} - set canvases [lreplace $canvases end-1 end]; # all canvases - foreach canvas $canvases { - # if a canvas is not a gop and its window does not exists - if {![$canvas gop] && ![winfo exists [$canvas widget]]} {return 0; break} - } - return 1 -} - -#-----------------------------------------------------------------------------------# - -class_new Canvas {Menuable ObjectBox} - -def Canvas close {} { - after cancel $@motion_after_id - if {$@subpatch} { - #can't wait till @mapped get updated thru proc change - if {$@gop} {foreach x [$@objects values] {$x outside_of_the_box}} - $self save_geometry - $self copy_times= 0 - netsend [list .$self vis 0] - #netsend [list .$self close] - return - } - if {$@gop} { - foreach x [$@objects values] {$x outside_of_the_box} - netsend [list .$self close] - return - } - switch [tk_messageBox2 -message [say save_changes?] -icon question -type yesnocancel -default cancel] { - yes {$self save; netsend [list .$self close]} - no { netsend [list .$self close]} - cancel {} - } -} - -def Canvas save_geometry {} { - set geometry [wm geometry .$self] - set cw [winfo width [$self widget]]; set ch [winfo height [$self widget]] - foreach {size x y} [split $geometry "+"] {mset {w h} [split $size "x"]; set x1 $x; set y1 $y} - set x2 [expr $x1+$cw]; set y2 [expr $y1+$ch] - netsend [list .$self bounds $x1 $y1 $x2 $y2] -} - -def Canvas save {} { - if {$@subpatch} {return [$@canvas save]} - $self checkgeometry - set c [$self widget] - if {![regexp {^Untitled-[0-9]} $@name]} { - $self save_geometry - netsend [list .$self savetofile $@name $@folder] - } else { - $self save_as - } -} - -def Canvas save_as {} { - $self checkgeometry - set filename [tk_getSaveFile -parent $::current_window -filetypes $::patch_filetypes] - if {$filename != ""} { - set @file [string range $filename [expr [string last / $filename]+1] end] - set @folder [string range $filename 0 [expr [string last / $filename]-1]] - $self save_geometry - puts "save $@file dir to $@folder" - netsend [list .$self savetofile $@file $@folder] - } -} - -def Canvas print {} { - set filename [tk_getSaveFile -parent $::current_window -initialfile pd.ps -defaultextension .ps -filetypes { {{postscript} {.ps}} }] - if {$filename != ""} {[$self widget] postscript -file $filename} -} -def Canvas quit {} {$::main quit} -def Canvas abort_server {} {$::main abort_server} - -proc wonder {} {tk_messageBox2 -message [say ask_cool] -type yesno -icon question} - -def Canvas eval% {code} { - mset {x y} $@curpos - regsub -all %X $code $x code - regsub -all %Y $code $y code - super $code -} - -def Client documentation {} { - set filename [tk_getOpenFile -parent $::current_window -defaultextension .pd -filetypes { {{documentation} {.pd .txt .htm}} } -initialdir $::docdir] - if {$filename != ""} { - if {[string first .txt $filename] >= 0} { - menu_opentext $filename - } elseif {[string first .htm $filename] >= 0} { - menu_openhtml $filename - } else { - set i [string last / $filename] - set help_directory [string range $filename 0 [expr $i-1]] - set basename [string range $filename [expr $i+1] end] - netsend [list pd open [enquote $basename] [enquote $help_directory]] - } - } -} - -def Canvas new_file {} {$::main new_file} -def Canvas open_file {} {$::main open_file} -def Canvas send_message {} {$::main send_message} -def Client test_audio_and_midi {} {menu_doc_open doc/7.stuff/tools testtone.pd } -def Client load_meter {} {menu_doc_open doc/7.stuff/tools load-meter.pd} -def Client latency_meter {} {menu_doc_open doc/7.stuff/tools latency.pd } -def Client about {} {AboutDialogue new} -def Client class_browser {} {Browser new_as browser browser 0 0 ""} -def Client audio_on {} {netsend [list pd dsp 1]} -def Client audio_off {} {netsend [list pd dsp 0]} -def Client keyboard_view {} { KeyboardDialogue new $::event_history} -def Client clipboard_view {} { ClipboardDialogue new $::clipboard} -def Client command_history_view {} { ListDialogue new $::command_history [say command_history_view]} -def Client event_history_view {} {EventHistoryDialogue new $::event_history} -def Client do_what_i_mean {} {wonder} - -set pd_prefix [file dirname [file dirname [which pd]]] -set pd_guidir ${pd_prefix}/lib/pd -set doc_number 1 -set updir [file dirname [file dirname $argh0]] -if {[file exists $updir/lib/pd/doc]} { - set docdir $updir/lib/pd/doc -} else { - set docdir $updir/doc -} - -proc menu_opentext {filename} { - set w [format ".help%d" $::doc_number] - toplevel $w - wm title $w $filename - frame $w.1 - frame $w.2 - pack [text $w.1.text -relief raised -bd 2 -yscrollcommand "$w.1.scroll set"] -side left -fill both -expand 1 - pack [scrollbar $w.1.scroll -command "$w.1.text yview"] -side right -fill y - pack [button $w.2.close -text [say close] -command "destroy $w"] -side right - pack $w.2 -side bottom -fill x -expand 0 - pack $w.1 -side bottom -fill both -expand 1 - set f [open $filename] - while {![eof $f]} { - set bigstring [read $f 1000] - regsub -all PD_BASEDIR $bigstring $::pd_guidir bigstring - regsub -all PD_VERSION $bigstring $::pd_version bigstring - $w.1.text insert end $bigstring - } - $w.1.text configure -state disabled - close $f - incr ::doc_number - return $w -} - -proc menu_doc_open {subdir basename} { - set dirname $::pd_guidir/$subdir - if {[string first .txt $basename] >= 0} { - return [menu_opentext $dirname/$basename] - } else { - netsend [list pd open $basename $dirname] - } -} - -#-----------------------------------------------------------------------------------# -def Canvas editmode {} {return $@editmode} -def Canvas editmode= {mode} { - if {$mode == $@editmode} {return} - if {!$mode} {$self deselect_all} - $self redraw ;# why this??? - set @editmode $mode; $self changed editmode -# catch {.$self.bbar.edit configure -image icon_mode_$mode} - if {$@mapped} { - if {$mode} {set im icon_mode_edit} else {set im icon_mode_run} - [$self window].bbar.edit configure -image $im - if {[$self look hairstate] && !$@editmode} {$@crosshair erase} - if {[$self look gridstate]} { - if {$@editmode} {$@grid draw} else {$@grid erase} - } - } - # comment's look depends on the value of @editmode - foreach child [$@objects values] {if {[[$child class] <= Comment]} {$child changed}} - #!@#$ should update the checkbox in the editmenu -} - -def Canvas editmodeswitch {} {$self editmode= [expr !$@editmode]} - -def Canvas window {} { - #if {$@gop && $@canvas != ""} {return [$@canvas window]} - return .$self -} -def Canvas widget {} {return .$self.c} -def View cwidget {} {return .[$self get_canvas].c} - -#-----------------------------------------------------------------------------------# - -def Canvas atomically {proc} {$@history atomically $proc} -def Canvas undo {} {$@history undo} -def Canvas redo {} {$@history redo} - -def Canvas init {mess} { - set @mapped 0 - set @gop 0 - set @goprect "" - set @abs 0 - set @name "" - set @folder "???" - set @file "" - super {#X obj 666 666 pd} ;# bogus - $self reinit $mess - set @zoom 1.0 ;# must be a float, not int - set @action none - set @objects [Hash new]; set @objectsel [Selection new]; set @visibles {} - set @wires [Hash new]; set @wiresel [Selection new] - - set @focus "" - set @curpos {30 30} - set @bbox {0 0 100 100} - set @dehighlight {} -# if {$@mapped} {$self init_window} ;#!@#$ @mapped can't possibly be 1 at this point - set @history $::command_history - $self subscribe $::manager - $self changed - #$self canvas= $self ;#!@#$ EEVIL - set @coords 0 - set @jump 0 - set @keynav_iocount 0 ;# the io select count - set @keynav_port 0 ;# which in/outlet is selected - set @keynav 0 ;# the list of objects that has io selected - set @keynav_iosel 0 ;# last object that is io selected - set @keynav_iosel_o {} ;# list of objects that has outlet selected - set @keynav_iosel_i {} ;# list of objects that has inlet selected - set @iosel_deselect 0 ;# if selected should be deselected by clicking at empty space - set @keynav_current 0 - set @keynav_last_obj 0 - set @keynav_last_wire 0 - set @keynav_tab_sel "wire" - set @keynav_shift 0 - set @copy_count 0 - set @findbar "" - set @find_string "" - set @iohilite {-1 0 0 0 0} - set @keyprefix 0 - set @coords {0 0 1 1} ;# default #X coords line - set @pixsize {0 0} - set @margin {0 0} - set @macro_q {} - set @macro_delay 200 - set @blinky "" - set @editmode 0 - set @show_id 0 - set @motion_queue {} -} - -def Canvas reinit {mess} { - switch -- [lindex $mess 0] { - "#N" { - # those four are not to be confused with other @variables of similar names. - set @canvas_pos [lrange $mess 2 3] - set @canvas_size [lrange $mess 4 5] - set args [lrange $mess 6 end] - switch [llength $args] { - 1 { - set @subpatch 0 - mset [list @fontsize] $args - set @name "" - set @mapped 1 - } - 2 { - set @subpatch 1 - mset [list @name @mapped] $args - set @fontsize "what?" - } - default {error "wrong number of arguments (expecting 5 or 6, got [expr 4+[llength $args]])"} - } - } - "#X" { - switch -- [lindex $mess 1] { - obj {} - restore { - set @x1 [lindex $mess 2] - set @y1 [lindex $mess 3] - set args [lrange $mess 4 end] - $self text= [lrange $mess 4 end] - if {!$@subpatch && [llength $args] != 0} {set @abs 1} - if {$@mapped && !$@gop} { - #if {!$@subpatch && $@text != ""} {set @abs 1; return} - #if {![winfo exists .$self.c]} {$self init_window} - } - } - coords { - set @coords [lrange $mess 2 5] - set @pixsize [lrange $mess 6 7] - switch [llength $mess] { - 8 {set @gop 0} - 9 {set @gop [lindex $mess 8]} - 11 { - set @gop [lindex $mess 8] - set @margin [lrange $mess 9 10] - } - default {error "what???"} - } - if {$@gop} {set @mapped 1} - } - } - } - "" {return} - default {error "huh? mess=$mess"} - } -} - -# doesn't this look like Canvas deconstruct ? -def Canvas get_mess {} { - return [concat $@coords $@pixsize $@margin] -} - - -def Canvas margin {} {return $@margin} -def Canvas gop {} {return $@gop} -def Canvas hidtext {} {return $@hidetext} -def Canvas abs {} {return $@abs} -#def Canvas abs {} {if {!$@subpatch} {return 1} else {return 0}} -def Canvas subpatch {} {return $@subpatch} -def Canvas get_dimen {} {return $@canvas_size} - -def Canvas gop_rect {} { - mset {pxs pys} $@pixsize - mset {mx my} $@margin - set rect [list $mx $my [expr $mx+$pxs] [expr $my+$pys]] - if {$@goprect == ""} { - set @goprect [GopRect new $self $rect] - } elseif {!$@editmode} {$@goprect delete; set @goprect ""; return} - $@goprect draw - -} - -rename toplevel toplevel_orig -proc toplevel {name args} { - eval [concat [list toplevel_orig $name] $args] - catch {wm iconphoto $name icon_pd_32} -} - -# should be called once and only from init -def Canvas init_window {} { - lappend ::window_list $self - set win .$self - set c [$self widget] - if {$::tcl_platform(platform) == "macintosh"} { - toplevel $win -menu $win.m - } else { - if {[$self look menubar]} {toplevel $win -menu $win.m} else {toplevel $win -menu ""} - } - set @menubar $win.m - $self init_menus - # turn buttonbar on/off - set @buttonbar [ButtonBar new $self] - if {[$self look buttonbar]} {pack [$@buttonbar widget] -side top -fill x -expand no} - set @statusbar [StatusBar new $self] - # turn statusbar on/off - if {[$self look statusbar]} {pack [$@statusbar widget] -side bottom -fill x} - set w [expr [lindex $@canvas_size 0]-4];# dd canvas is 4 pixel out with pd canvas? - set h [expr [lindex $@canvas_size 1]-4] - pack [canvas $c -width $w -height $h -background white] -side left -expand 1 -fill both - set @yscroll $win.yscroll; set @xscroll $win.xscroll - $self init_scrollbars - wm minsize $win 1 1 - wm geometry $win +[lindex $@canvas_pos 0]+[lindex $@canvas_pos 1] - wm protocol $win WM_DELETE_WINDOW "$self close" - focus $c - $self new_binds - $self update_title - $self motion_update - set @runcommand [Runcommand new .$self "command" canvas_eval] - set @crosshair [Crosshair new $self] - set @active [Active new $self] - set @sense [Sense new $self] - set @grid [Grid new $self] -} - -def Canvas activate_menubar= {val} {if {$val} {.$self configure -menu $@menubar} {.$self configure -menu ""}} - -def Canvas activate_buttonbar= {val} { - if {$val} { - pack [$@buttonbar widget] -side top -fill x -expand no -before [$self widget] - } else {pack forget [$@buttonbar widget]} -} - -def Canvas activate_statusbar= {val} { - if {$val} { - if {[winfo exists $@yscroll]} {set w .$self.yscroll} else {set w .$self.c} - pack [$@statusbar widget] -side bottom -fill x -before $w - } else {pack forget [$@statusbar widget]} -} - -def Canvas activate_scrollbars= {val} {if {!$val} {$self init_scrollbars} {$self remove_scrollbars}} - -def Canvas activate_grid= {val} {if {$val} {$@grid draw} {$@grid erase}} - -def Canvas init_scrollbars {} { - set win .$self - set c [$self widget] - if {[winfo exists $win.yscroll]} {return} - set size [$c bbox foo] - mset {xs ys} $@canvas_size - pack [scrollbar $win.yscroll -command "$c yview" ] -side right -fill y -before $c - pack [scrollbar $win.xscroll -command "$c xview" -orient horizontal] -side bottom -fill x -before $c - set xw $win.xscroll; set yw $win.yscroll - $c configure -yscrollcommand "$self scroll_set $yw" -xscrollcommand "$self scroll_set $xw" - after 0 [list $self adjust_scrollbars] -} - -def Canvas remove_scrollbars {} { - set win .$self - set c [$self widget] - if {![winfo exists $win.yscroll]} {return} - #use destroy instead of pack forget so that it can be tested with winfo exists - destroy $win.yscroll - destroy $win.xscroll - $c configure -yscrollcommand "" -xscrollcommand "" -scrollregion "" -} - -def Canvas adjust_scrollbars {} { - set c [$self widget] - set size [$c bbox foo] - if {[$self look scrollbar]} {$self auto_scrollbars} - if {$size != ""} { - mset {xmin ymin xmax ymax} {0 0 100 100} - mset {x1 y1 x2 y2} $size - if {$x2 > 100} {set xmax $x2} - if {$y2 > 100} {set ymax $y2} - set bbox [list $xmin $ymin $xmax $ymax] - set oldbbox [$c cget -scrollregion] - # it is very inefficient to call "configure" here - if {"$oldbbox" != "$bbox"} {$c configure -scrollregion $bbox} - set @bbox $bbox - } -} - -def Canvas auto_scrollbars {} { - set c [$self widget] - if {[$c bbox foo] != ""} { - mset {cx1 cy1 cx2 cy2} [$c bbox foo] - } else { - set cx2 [lindex $@canvas_size 0]; set cy2 [lindex $@canvas_size 1] - } - set x2 [$c canvasx [winfo width $c]] - set y2 [$c canvasy [winfo height $c]] - if {$x2 == 1} {set x2 $cx2; set y2 $cy2} - if {$cx2 <= $x2 && $cy2 <= $y2} {$self remove_scrollbars} {$self init_scrollbars} -} - -def Canvas delete_window {} { - set wl {} - foreach w $::window_list {if {$w != $self} {lappend wl $w}} - set ::window_list $wl - destroy .$self -} - -def Canvas delete {} { - $self delete_window - super -} - -def Canvas focus {} {return $@focus} -def Canvas focus= {o} {set @focus $o} -def Canvas history {} {return $@history} - -#-----------------------------------------------------------------------------------# -def Canvas find {} { - if {[info exists ::_(findmodel:_class)]} { - focus .$self.find.find - findmodel reinit - } else { - FindModel new_as findmodel $self - FindView new $self - focus .$self.find.find - } -} -def Canvas find_again {} { - if {[info exists ::_(findmodel:_class)]} {findmodel remove_info;findmodel search_recursive} -} - -def Canvas find_last_error {} {netsend [list pd finderror]} - -def Canvas bind {eventtype selector args} { - set c [$self widget] - #bind $c $eventtype [concat [list $self $selector] $args \; $self statusbar_draw %x %y] - #bind $c $eventtype "puts \[time {[concat [list $self $selector] $args \; $self statusbar_draw %x %y]}\]" - #bind $c $eventtype "puts \[time {[concat [list $self $selector] $args]}\]" - if {[$self look statusbar]} { - bind $c $eventtype [concat [list $self $selector] $args \; $self statusbar_draw %x %y] - } else { - bind $c $eventtype [concat [list $self $selector] $args] - } -} - -def Canvas new_binds {} { - # mouse buttons - $self bind