summaryrefslogtreecommitdiff
path: root/apps/plugins/pdbox/PDa/src/u_main.tk
diff options
context:
space:
mode:
Diffstat (limited to 'apps/plugins/pdbox/PDa/src/u_main.tk')
-rw-r--r--apps/plugins/pdbox/PDa/src/u_main.tk6734
1 files changed, 6734 insertions, 0 deletions
diff --git a/apps/plugins/pdbox/PDa/src/u_main.tk b/apps/plugins/pdbox/PDa/src/u_main.tk
new file mode 100644
index 0000000000..00cb25c4a2
--- /dev/null
+++ b/apps/plugins/pdbox/PDa/src/u_main.tk
@@ -0,0 +1,6734 @@
1set pd_nt 1
2# (The above is 0 for unix, 1 for microsoft, and 2 for Mac OSX. The first
3# line is automatically munged by the relevant makefiles.)
4
5# Copyright (c) 1997-1999 Miller Puckette.
6# For information on usage and redistribution, and for a DISCLAIMER OF ALL
7# WARRANTIES, see the file, "LICENSE.txt," in this distribution.
8
9# changed by Thomas Musil 09.2001
10# between "pdtk_graph_dialog -- dialog window for graphs"
11# and "pdtk_array_dialog -- dialog window for arrays"
12# a new dialogbox was inserted, named:
13# "pdtk_iemgui_dialog -- dialog window for iem guis"
14#
15# all this changes are labeled with #######iemlib##########
16
17# Tearoff is set to true by default:
18set pd_tearoff 0
19set menubar 1
20
21set File "F"
22set Windows "W"
23set Edit "E"
24set Find "F"
25set Put "P"
26set Media "M"
27set Help "H"
28
29set color grey16
30set lightcolor grey24
31
32option add *font -*-helvetica-*--bold--9-*
33
34# los colores de la muerte
35
36option add *background $color
37option add *activeBackground $lightcolor
38
39option add *foreground white
40option add *activeForeground white
41
42option add *troughColor $lightcolor
43
44option add *highlightThickness 0
45option add *relief solid startupFile
46
47if {$pd_nt == 1} {
48 global pd_guidir
49 global pd_tearoff
50 set pd_gui2 [string range $argv0 0 [expr [string last \\ $argv0 ] - 1]]
51 regsub -all \\\\ $pd_gui2 / pd_gui3
52 set pd_guidir $pd_gui3/..
53 load $pd_guidir/bin/pdtcl
54 set pd_tearoff 1
55}
56
57if {$pd_nt == 2} {
58 global pd_guidir
59 global pd_tearoff
60 set pd_gui2 [string range $argv0 0 [expr [string last / $argv0 ] - 1]]
61 set pd_guidir $pd_gui2/..
62 load $pd_guidir/bin/pdtcl
63 set pd_tearoff 0
64}
65
66# hack so you can easily test-run this script in linux... define pd_guidir
67# (which is normally defined at startup in pd under linux...)
68
69if {$pd_nt == 0} {
70 if {! [info exists pd_guidir]} {
71 global pd_guidir
72 puts stderr {setting pd_guidir to '.'}
73 set pd_guidir .
74 }
75}
76
77# it's unfortunate but we seem to have to turn off global bindings
78# for Text objects to get control-s and control-t to do what we want for
79# "text" dialogs below. Also we have to get rid of tab's changing the focus.
80
81bind all <Key-Tab> ""
82bind all <<PrevWindow>> ""
83bind Text <Control-t> {}
84bind Text <Control-s> {}
85# puts stderr [bind all]
86
87################## set up main window #########################
88menu .mbar
89canvas .dummy -height 2p -width 6c
90
91frame .controls
92pack .controls .dummy -side top -fill x
93menu .mbar.file -tearoff $pd_tearoff
94.mbar add cascade -label "$File" -menu .mbar.file
95menu .mbar.find -tearoff $pd_tearoff
96.mbar add cascade -label "$Find" -menu .mbar.find
97menu .mbar.windows -postcommand [concat pdtk_fixwindowmenu] -tearoff $pd_tearoff
98menu .mbar.audio -tearoff $pd_tearoff
99if {$pd_nt != 2} {
100 .mbar add cascade -label "$Windows" -menu .mbar.windows
101 .mbar add cascade -label "$Media" -menu .mbar.audio
102} else {
103# Perhaps this is silly, but Mac HIG want "Window Help" as the last menus
104 .mbar add cascade -label "$Media" -menu .mbar.audio
105 .mbar add cascade -label "$Windows" -menu .mbar.windows
106}
107menu .mbar.help -tearoff $pd_tearoff
108.mbar add cascade -label "$Help" -menu .mbar.help
109
110set ctrls_audio_on 0
111set ctrls_meter_on 0
112set ctrls_inlevel 0
113set ctrls_outlevel 0
114
115frame .controls.switches
116checkbutton .controls.switches.audiobutton -text {compute audio} \
117 -variable ctrls_audio_on \
118 -anchor w \
119 -command {pd [concat pd dsp $ctrls_audio_on \;]}
120
121checkbutton .controls.switches.meterbutton -text {peak meters} \
122 -variable ctrls_meter_on \
123 -anchor w \
124 -command {pd [concat pd meters $ctrls_meter_on \;]}
125
126pack .controls.switches.meterbutton .controls.switches.audiobutton -side left
127
128frame .controls.inout
129frame .controls.inout.in
130label .controls.inout.in.label -text IN
131entry .controls.inout.in.level -textvariable ctrls_inlevel -width 3
132button .controls.inout.in.clip -text {CLIP} -state disabled
133pack .controls.inout.in.label .controls.inout.in.level \
134 .controls.inout.in.clip -side top -pady 2
135
136frame .controls.inout.out
137label .controls.inout.out.label -text OUT
138entry .controls.inout.out.level -textvariable ctrls_outlevel -width 3
139button .controls.inout.out.clip -text {CLIP} -state disabled
140pack .controls.inout.out.label .controls.inout.out.level \
141 .controls.inout.out.clip -side top -pady 2
142
143button .controls.dio -text "DIO\nerrors" \
144 -command {pd [concat pd audiostatus \;]}
145
146pack .controls.switches -side bottom -pady 12
147pack .controls.inout.in .controls.inout.out -side left -padx 6
148pack .controls.inout -side left -padx 14
149pack .controls.dio -side right -padx 20
150
151bind . <Control-Key> {pdtk_pd_ctrlkey %W %K 0}
152bind . <Control-Shift-Key> {pdtk_pd_ctrlkey %W %K 1}
153if {$pd_nt == 2} {
154 bind . <Mod1-Key> {pdtk_canvas_ctrlkey %W %K 0}
155 bind . <Mod1-Shift-Key> {pdtk_canvas_ctrlkey %W %K 1}
156}
157
158
159wm title . "PDa"
160. configure -menu .mbar -width 200 -height 150
161
162############### set up global variables ################################
163
164set untitled_number 1
165set untitled_directory [pwd]
166set saveas_client doggy
167set pd_opendir $untitled_directory
168set pd_undoaction no
169set pd_redoaction no
170set pd_undocanvas no
171
172################ utility functions #########################
173
174proc pdtk_enquote {x} {
175 set foo [string map {"," "" ";" "" \" ""} $x]
176 set foo2 [string map {" " "\\ "} $foo]
177 concat $foo2
178}
179
180proc pdtk_debug {x} {
181 tk_messageBox -message $x -type ok
182}
183
184proc pdtk_watchdog {} {
185 pd [concat pd ping \;]
186 after 2000 {pdtk_watchdog}
187}
188
189proc pdtk_check {x message} {
190 set answer [tk_messageBox \-message $x \-type yesno \-icon question]
191 switch $answer {
192 yes {pd $message} }
193# no {tk_messageBox \-message "cancelled" \-type ok}
194}
195
196set menu_windowlist {}
197
198proc pdtk_fixwindowmenu {} {
199 global menu_windowlist
200 .mbar.windows delete 0 end
201 foreach i $menu_windowlist {
202 .mbar.windows add command -label [lindex $i 0] \
203 -command [concat menu_domenuwindow [lindex $i 1]]
204 menu_fixwindowmenu [lindex $i 1]
205 }
206}
207
208####### Odd little function to make better Mac accelerators #####
209
210proc accel_munge {acc} {
211 global pd_nt
212
213 if {$pd_nt == 2} {
214 if [string is upper [string index $acc end]] {
215 return [format "%s%s" "Shift+" \
216 [string toupper [string map {Ctrl Meta} $acc] end]]
217 } else {
218 return [string toupper [string map {Ctrl Meta} $acc] end]
219 }
220 } else {
221 return $acc
222 }
223}
224
225
226
227############### the "New" menu command ########################
228proc menu_new {} {
229 global untitled_number
230 global untitled_directory
231 pd [concat pd filename Untitled-$untitled_number $untitled_directory \;]
232 pd {
233 #N canvas;
234 #X pop 1;
235 }
236 set untitled_number [expr $untitled_number + 1]
237}
238
239################## the "Open" menu command #########################
240
241proc menu_open {} {
242 global pd_opendir
243
244 set filename [tk_getOpenFile -defaultextension .pd \
245 -filetypes { {{pd files} {.pd}} {{max files} {.pat}}} \
246 -initialdir $pd_opendir]
247
248 if {$filename != ""} {
249 set directory [string range $filename 0 \
250 [expr [string last / $filename ] - 1]]
251 set pd_opendir $directory
252 set basename [string range $filename \
253 [expr [string last / $filename ] + 1] end]
254
255# pd_debug [concat file $filename base $basename dir $directory]
256
257 pd [concat pd open [pdtk_enquote $basename] \
258 [pdtk_enquote $directory]\;]
259 }
260}
261
262################## the "Message" menu command #########################
263proc menu_send {} {
264 toplevel .sendpanel
265 entry .sendpanel.entry -textvariable send_textvariable
266 pack .sendpanel.entry -side bottom -fill both -ipadx 100
267 .sendpanel.entry select from 0
268 .sendpanel.entry select adjust end
269 bind .sendpanel.entry <KeyPress-Return> {
270 pd [concat $send_textvariable \;]
271 after 50 {destroy .sendpanel}
272 }
273 focus .sendpanel.entry
274}
275
276################## the "Quit" menu command #########################
277proc menu_really_quit {} {pd {pd quit;}}
278
279proc menu_quit {} {pd {pd quit;}}
280
281######### the "Pd" menu command, which puts the Pd window on top ########
282proc menu_pop_pd {} {raise .}
283
284######### the "audio" menu command ###############
285proc menu_audio {flag} {pd [concat pd dsp $flag \;]}
286
287######### the "documentation" menu command ###############
288
289set doc_number 1
290
291proc menu_opentext {filename} {
292 global doc_number
293 global pd_guidir
294 global pd_myversion
295 set name [format ".help%d" $doc_number]
296 toplevel $name
297 text $name.text -fg black -relief raised -bd 2 -font -*-courier-bold--normal--12-* \
298 -yscrollcommand "$name.scroll set" -background white
299 scrollbar $name.scroll -command "$name.text yview"
300 pack $name.scroll -side right -fill y
301 pack $name.text -side left -fill both -expand 1
302
303 set f [open $filename]
304 while {![eof $f]} {
305 set bigstring [read $f 1000]
306 regsub -all PD_BASEDIR $bigstring $pd_guidir bigstring2
307 regsub -all PD_VERSION $bigstring2 $pd_myversion bigstring3
308 $name.text insert end $bigstring3
309 }
310 close $f
311 set doc_number [expr $doc_number + 1]
312}
313
314set help_directory $pd_guidir/doc
315
316proc menu_documentation {} {
317 global help_directory
318 global pd_nt
319
320 set filename [tk_getOpenFile -defaultextension .pd \
321 -filetypes { {{documentation} {.pd .txt .htm}} } \
322 -initialdir $help_directory]
323
324 if {$filename != ""} {
325 if {[string first .txt $filename] >= 0} {
326 menu_opentext $filename
327 } elseif {[string first .htm $filename] >= 0} {
328 if {$pd_nt == 0} {
329 exec sh -c \
330 [format "mozilla file:%s || netscape file:%s &\n" \
331 $filename $filename]
332 } elseif {$pd_nt == 2} {
333 puts stderr [format "open %s" $filename]
334 exec sh -c \
335 [format "open %s" $filename]
336 } else {
337 exec rundll32 url.dll,FileProtocolHandler \
338 [format "file:%s" $filename] &
339 }
340 } else {
341 set help_directory [string range $filename 0 \
342 [expr [string last / $filename ] - 1]]
343 set basename [string range $filename \
344 [expr [string last / $filename ] + 1] end]
345 pd [concat pd open [pdtk_enquote $basename] \
346 [pdtk_enquote $help_directory] \;]
347 }
348 }
349}
350
351proc menu_doc_open {subdir basename} {
352 global pd_guidir
353
354 set dirname $pd_guidir/$subdir
355
356 if {[string first .txt $basename] >= 0} {
357 menu_opentext $dirname/$basename
358 } else {
359 pd [concat pd open [pdtk_enquote $basename] \
360 [pdtk_enquote $dirname] \;]
361 }
362}
363
364############# routine to add audio and help menus ###############
365
366proc menu_addstd {mbar} {
367 global pd_apilist
368# the "Audio" menu
369 $mbar.audio add command -label {audio ON} -accelerator [accel_munge "Ctrl+/"] \
370 -command {menu_audio 1}
371 $mbar.audio add command -label {audio OFF} -accelerator [accel_munge "Ctrl+."] \
372 -command {menu_audio 0}
373 for {set x 0} {$x<[llength $pd_apilist]} {incr x} {
374 $mbar.audio add radiobutton -label [lindex [lindex $pd_apilist $x] 0] \
375 -command {menu_audio 0} -variable pd_whichapi \
376 -value [lindex [lindex $pd_apilist $x] 1]\
377 -command {pd [concat pd audio-setapi $pd_whichapi \;]}
378 }
379 $mbar.audio add command -label {Audio settings...} \
380 -command {pd pd audio-properties \;}
381
382 $mbar.audio add command -label {MIDI settings...} \
383 -command {pd pd midi-properties \;}
384 $mbar.audio add command -label {Test Audio and MIDI} \
385 -command {menu_doc_open doc/7.stuff/tools testtone.pd}
386 $mbar.audio add command -label {Load Meter} \
387 -command {menu_doc_open doc/7.stuff/tools load-meter.pd}
388
389
390 $mbar.audio add checkbutton -label "Show Menubar" \
391 -indicatoron true -selectcolor grey85 \
392 -variable menubar
393
394# the "Help" menu
395 $mbar.help add command -label {About Pd} \
396 -command {menu_doc_open doc/1.manual 1.introduction.txt}
397 $mbar.help add command -label {Pure Documentation...} \
398 -command {menu_documentation}
399}
400
401#################### the "File" menu for the Pd window ##############
402
403.mbar.file add command -label New -command {menu_new} \
404 -accelerator [accel_munge "Ctrl+n"]
405.mbar.file add command -label Open -command {menu_open} \
406 -accelerator [accel_munge "Ctrl+o"]
407.mbar.file add separator
408.mbar.file add command -label Message -command {menu_send} \
409 -accelerator [accel_munge "Ctrl+m"]
410.mbar.file add command -label Path... \
411 -command {pd pd start-path-dialog \;}
412.mbar.file add separator
413.mbar.file add command -label Quit -command {menu_quit} \
414 -accelerator [accel_munge "Ctrl+q"]
415
416#################### the "Find" menu for the Pd window ##############
417.mbar.find add command -label {last error?} -command {menu_finderror}
418
419########### functions for menu functions on document windows ########
420
421proc menu_save {name} {
422 pdtk_canvas_checkgeometry $name
423 pd [concat $name menusave \;]
424}
425
426proc menu_saveas {name} {
427 pdtk_canvas_checkgeometry $name
428 pd [concat $name menusaveas \;]
429}
430
431proc menu_print {name} {
432 set filename [tk_getSaveFile -initialfile pd.ps \
433 -defaultextension .ps \
434 -filetypes { {{postscript} {.ps}} }]
435
436 if {$filename != ""} {
437 $name.c postscript -file $filename
438 }
439}
440
441proc menu_close {name} {
442 pd [concat $name menuclose \;]
443}
444
445proc menu_undo {name} {
446 global pd_undoaction
447 global pd_redoaction
448 global pd_undocanvas
449 if {$name == $pd_undocanvas && $pd_undoaction != "no"} {
450 pd [concat $name undo \;]
451 }
452}
453
454proc menu_redo {name} {
455 global pd_undoaction
456 global pd_redoaction
457 global pd_undocanvas
458 if {$name == $pd_undocanvas && $pd_redoaction != "no"} {
459 pd [concat $name redo \;]
460 }
461}
462
463proc menu_cut {name} {
464 pd [concat $name cut \;]
465}
466
467proc menu_copy {name} {
468 pd [concat $name copy \;]
469}
470
471proc menu_paste {name} {
472 pd [concat $name paste \;]
473}
474
475proc menu_duplicate {name} {
476 pd [concat $name duplicate \;]
477}
478
479proc menu_selectall {name} {
480 pd [concat $name selectall \;]
481}
482
483proc menu_texteditor {name} {
484 pd [concat $name texteditor \;]
485}
486
487proc menu_font {name} {
488 pd [concat $name menufont \;]
489}
490
491proc menu_tidyup {name} {
492 pd [concat $name tidy \;]
493}
494
495proc menu_editmode {name} {
496 pd [concat $name editmode 0 \;]
497}
498
499proc menu_object {name accel} {
500 pd [concat $name obj $accel \;]
501}
502
503proc menu_message {name accel} {
504 pd [concat $name msg $accel \;]
505}
506
507proc menu_floatatom {name accel} {
508 pd [concat $name floatatom $accel \;]
509}
510
511proc menu_symbolatom {name accel} {
512 pd [concat $name symbolatom $accel \;]
513}
514
515proc menu_comment {name accel} {
516 pd [concat $name text $accel \;]
517}
518
519proc menu_graph {name} {
520 pd [concat $name graph \;]
521}
522
523proc menu_array {name} {
524 pd [concat $name menuarray \;]
525}
526
527############iemlib##################
528proc menu_bng {name accel} {
529 pd [concat $name bng $accel \;]
530}
531
532proc menu_toggle {name accel} {
533 pd [concat $name toggle $accel \;]
534}
535
536proc menu_numbox {name accel} {
537 pd [concat $name numbox $accel \;]
538}
539
540proc menu_vslider {name accel} {
541 pd [concat $name vslider $accel \;]
542}
543
544proc menu_hslider {name accel} {
545 pd [concat $name hslider $accel \;]
546}
547
548proc menu_hradio {name accel} {
549 pd [concat $name hradio $accel \;]
550}
551
552proc menu_vradio {name accel} {
553 pd [concat $name vradio $accel \;]
554}
555
556proc menu_vumeter {name accel} {
557 pd [concat $name vumeter $accel \;]
558}
559
560proc menu_mycnv {name accel} {
561 pd [concat $name mycnv $accel \;]
562}
563
564############iemlib##################
565
566# correct edit menu, enabling or disabling undo/redo
567# LATER also cut/copy/paste
568proc menu_fixeditmenu {name} {
569 global pd_undoaction
570 global pd_redoaction
571 global pd_undocanvas
572# puts stderr [concat menu_fixeditmenu $name $pd_undocanvas $pd_undoaction]
573 if {$name == $pd_undocanvas && $pd_undoaction != "no"} {
574 $name.m.edit entryconfigure "Undo*" -state normal \
575 -label [concat "Undo " $pd_undoaction]
576 } else {
577 $name.m.edit entryconfigure "Undo*" -state disabled -label "Undo"
578 }
579 if {$name == $pd_undocanvas && $pd_redoaction != "no"} {
580 $name.m.edit entryconfigure "Redo*" -state normal\
581 -label [concat "Redo " $pd_redoaction]
582 } else {
583 $name.m.edit entryconfigure "Redo*" -state disabled
584 }
585}
586
587# message from Pd to update the currently available undo/redo action
588proc pdtk_undomenu {name undoaction redoaction} {
589 global pd_undoaction
590 global pd_redoaction
591 global pd_undocanvas
592# puts stderr [concat pdtk_undomenu $name $undoaction $redoaction]
593 set pd_undocanvas $name
594 set pd_undoaction $undoaction
595 set pd_redoaction $redoaction
596 if {$name != "nobody"} {
597# unpleasant way of avoiding a more unpleasant bug situation --atl 2002.11.25
598 menu_fixeditmenu $name
599 }
600}
601
602proc menu_windowparent {name} {
603 pd [concat $name findparent \;]
604}
605
606proc menu_findagain {name} {
607 pd [concat $name findagain \;]
608}
609
610proc menu_finderror {} {
611 pd [concat pd finderror \;]
612}
613
614proc menu_domenuwindow {i} {
615 raise $i
616}
617
618proc menu_fixwindowmenu {name} {
619 global menu_windowlist
620 global pd_tearoff
621 global menubar
622
623 if { $menubar == 1 } {
624 $name.m.windows add command
625 if $pd_tearoff {
626 $name.m.windows delete 4 end
627 } else {
628 $name.m.windows delete 3 end
629 }
630 foreach i $menu_windowlist {
631 $name.m.windows add command -label [lindex $i 0] \
632 -command [concat menu_domenuwindow [lindex $i 1]]
633 }
634 }
635}
636
637################## the "find" menu item ###################
638
639set find_canvas nobody
640set find_string ""
641set find_count 1
642
643proc find_apply {name} {
644 global find_string
645 global find_canvas
646 regsub -all \; $find_string " _semi_ " find_string2
647 regsub -all \, $find_string2 " _comma_ " find_string3
648# puts stderr [concat $find_canvas find $find_string3 \
649# \;]
650 pd [concat $find_canvas find $find_string3 \
651 \;]
652 after 50 destroy $name
653}
654
655proc find_cancel {name} {
656 after 50 destroy $name
657}
658
659proc menu_findobject {canvas} {
660 global find_string
661 global find_canvas
662 global find_count
663
664 set name [format ".find%d" $find_count]
665 set find_count [expr $find_count + 1]
666
667 set find_canvas $canvas
668
669 toplevel $name
670
671 label $name.label -text {find...}
672 pack $name.label -side top
673
674 entry $name.entry -textvariable find_string
675 pack $name.entry -side top
676
677 frame $name.buttonframe
678 pack $name.buttonframe -side bottom -fill x -pady 2m
679 button $name.buttonframe.cancel -text {Cancel}\
680 -command "find_cancel $name"
681 button $name.buttonframe.ok -text {OK}\
682 -command "find_apply $name"
683 pack $name.buttonframe.cancel -side left -expand 1
684 pack $name.buttonframe.ok -side left -expand 1
685
686 $name.entry select from 0
687 $name.entry select adjust end
688 bind $name.entry <KeyPress-Return> [ concat find_apply $name]
689 focus $name.entry
690}
691
692
693
694proc pdtk_canvas_menubar {name width height geometry editable} {
695 global pd_opendir
696 global pd_tearoff
697 global pd_nt
698
699 global File Edit Find Put Windows Media Help
700
701
702 menu $name.m.file -tearoff $pd_tearoff
703 $name.m add cascade -label "$File" -menu $name.m.file
704
705 $name.m.file add command -label New -command {menu_new} \
706 -accelerator [accel_munge "Ctrl+n"]
707
708 $name.m.file add command -label Open -command {menu_open} \
709 -accelerator [accel_munge "Ctrl+o"]
710
711 $name.m.file add separator
712 $name.m.file add command -label Message -command {menu_send} \
713 -accelerator [accel_munge "Ctrl+m"]
714
715 $name.m.file add command -label Path... \
716 -command {pd pd start-path-dialog \;}
717
718 $name.m.file add separator
719 $name.m.file add command -label Close \
720 -command [concat menu_close $name] \
721 -accelerator [accel_munge "Ctrl+w"]
722
723 $name.m.file add command -label Save -command [concat menu_save $name] \
724 -accelerator [accel_munge "Ctrl+s"]
725
726 $name.m.file add command -label "Save as..." \
727 -command [concat menu_saveas $name] \
728 -accelerator [accel_munge "Ctrl+S"]
729
730 $name.m.file add command -label Print -command [concat menu_print $name] \
731 -accelerator [accel_munge "Ctrl+p"]
732
733 $name.m.file add separator
734
735 $name.m.file add command -label Quit -command {menu_quit} \
736 -accelerator [accel_munge "Ctrl+q"]
737
738# the edit menu
739 menu $name.m.edit -postcommand [concat menu_fixeditmenu $name] -tearoff $pd_tearoff
740 $name.m add cascade -label $Edit -menu $name.m.edit
741
742 $name.m.edit add command -label Undo -command [concat menu_undo $name] \
743 -accelerator [accel_munge "Ctrl+z"]
744
745 $name.m.edit add command -label Redo -command [concat menu_redo $name] \
746 -accelerator [accel_munge "Ctrl+Z"]
747
748 $name.m.edit add separator
749
750 $name.m.edit add command -label Cut -command [concat menu_cut $name] \
751 -accelerator [accel_munge "Ctrl+x"]
752
753 $name.m.edit add command -label Copy -command [concat menu_copy $name] \
754 -accelerator [accel_munge "Ctrl+c"]
755
756 $name.m.edit add command -label Paste \
757 -command [concat menu_paste $name] \
758 -accelerator [accel_munge "Ctrl+v"]
759
760 $name.m.edit add command -label Duplicate \
761 -command [concat menu_duplicate $name] \
762 -accelerator [accel_munge "Ctrl+d"]
763
764 $name.m.edit add command -label {Select all} \
765 -command [concat menu_selectall $name] \
766 -accelerator [accel_munge "Ctrl+a"]
767
768 $name.m.edit add separator
769
770 $name.m.edit add command -label {Text Editor} \
771 -command [concat menu_texteditor $name] \
772 -accelerator [accel_munge "Ctrl+t"]
773
774 $name.m.edit add command -label Font \
775 -command [concat menu_font $name]
776
777 $name.m.edit add command -label {Tidy Up} \
778 -command [concat menu_tidyup $name]
779
780 $name.m.edit add separator
781
782############iemlib##################
783# instead of "red = #BC3C60" we take "grey85", so there is no difference,
784# if widget is selected or not.
785
786 $name.m.edit add checkbutton -label "Edit mode" \
787 -indicatoron true -selectcolor grey85 \
788 -command [concat menu_editmode $name] \
789 -accelerator [accel_munge "Ctrl+e"]
790
791 if { $editable == 0 } {
792 $name.m.edit entryconfigure "Edit mode" -indicatoron false }
793
794############iemlib##################
795
796# the put menu
797 menu $name.m.put -tearoff $pd_tearoff
798 $name.m add cascade -label $Put -menu $name.m.put
799
800 $name.m.put add command -label Object \
801 -command [concat menu_object $name 0] \
802 -accelerator [accel_munge "Ctrl+1"]
803
804 $name.m.put add command -label Message \
805 -command [concat menu_message $name 0] \
806 -accelerator [accel_munge "Ctrl+2"]
807
808 $name.m.put add command -label Number \
809 -command [concat menu_floatatom $name 0] \
810 -accelerator [accel_munge "Ctrl+3"]
811
812 $name.m.put add command -label Symbol \
813 -command [concat menu_symbolatom $name 0] \
814 -accelerator [accel_munge "Ctrl+4"]
815
816 $name.m.put add command -label Comment \
817 -command [concat menu_comment $name 0] \
818 -accelerator [accel_munge "Ctrl+5"]
819
820 $name.m.put add separator
821
822############iemlib##################
823
824 $name.m.put add command -label Bang \
825 -command [concat menu_bng $name 0] \
826 -accelerator [accel_munge "Alt+b"]
827
828 $name.m.put add command -label Toggle \
829 -command [concat menu_toggle $name 0] \
830 -accelerator [accel_munge "Alt+t"]
831
832 $name.m.put add command -label Number2 \
833 -command [concat menu_numbox $name 0] \
834 -accelerator [accel_munge "Alt+n"]
835
836 $name.m.put add command -label Vslider \
837 -command [concat menu_vslider $name 0] \
838 -accelerator [accel_munge "Alt+v"]
839
840 $name.m.put add command -label Hslider \
841 -command [concat menu_hslider $name 0] \
842 -accelerator [accel_munge "Alt+h"]
843
844 $name.m.put add command -label Vradio \
845 -command [concat menu_vradio $name 0] \
846 -accelerator [accel_munge "Alt+d"]
847
848 $name.m.put add command -label Hradio \
849 -command [concat menu_hradio $name 0] \
850 -accelerator [accel_munge "Alt+i"]
851
852 $name.m.put add command -label VU \
853 -command [concat menu_vumeter $name 0] \
854 -accelerator [accel_munge "Alt+u"]
855
856 $name.m.put add command -label Canvas \
857 -command [concat menu_mycnv $name 0] \
858 -accelerator [accel_munge "Alt+c"]
859
860############iemlib##################
861
862 $name.m.put add separator
863
864 $name.m.put add command -label Graph \
865 -command [concat menu_graph $name]
866
867 $name.m.put add command -label Array \
868 -command [concat menu_array $name]
869
870# the find menu
871 menu $name.m.find -tearoff $pd_tearoff
872 $name.m add cascade -label "$Find" -menu $name.m.find
873
874 $name.m.find add command -label {Find...} \
875 -accelerator [accel_munge "Ctrl+f"] \
876 -command [concat menu_findobject $name]
877 $name.m.find add command -label {Find Again} \
878 -accelerator [accel_munge "Ctrl+g"] \
879 -command [concat menu_findagain $name]
880 $name.m.find add command -label {Find last error} \
881 -command [concat menu_finderror]
882
883# the window menu
884 menu $name.m.windows -postcommand [concat menu_fixwindowmenu $name] \
885 -tearoff $pd_tearoff
886
887 $name.m.windows add command -label {parent window}\
888 -command [concat menu_windowparent $name]
889 $name.m.windows add command -label {Pd window} -command menu_pop_pd
890 $name.m.windows add separator
891
892# the audio menu
893 menu $name.m.audio -tearoff $pd_tearoff
894
895 if {$pd_nt != 2} {
896 $name.m add cascade -label $Windows -menu $name.m.windows
897 $name.m add cascade -label $Media -menu $name.m.audio
898 } else {
899 $name.m add cascade -label $Media -menu $name.m.audio
900 $name.m add cascade -label $Windows -menu $name.m.windows
901 }
902
903# the help menu
904 menu $name.m.help -tearoff $pd_tearoff
905 $name.m add cascade -label $Help -menu $name.m.help
906
907 menu_addstd $name.m
908}
909
910
911############# pdtk_canvas_new -- create a new canvas ###############
912proc pdtk_canvas_new {name width height geometry editable} {
913 global pd_opendir
914 global pd_tearoff
915 global pd_nt
916 global menubar
917
918 toplevel $name -menu $name.m
919# puts stderr [concat geometry: $geometry]
920 wm geometry $name $geometry
921 wm minsize $name 1 1
922
923 canvas $name.c -width $width -height $height -background white \
924 -yscrollcommand "$name.scrollvert set" \
925 -xscrollcommand "$name.scrollhort set" \
926 -scrollregion [concat 0 0 $width $height]
927
928
929 scrollbar $name.scrollvert -command "$name.c yview" -width 7
930 scrollbar $name.scrollhort -command "$name.c xview" \
931 -orient horizontal -width 7
932
933 pack $name.scrollhort -side bottom -fill x
934 pack $name.scrollvert -side right -fill y
935 pack $name.c -side left -expand 1 -fill both
936
937# the menubar
938
939 menu $name.m
940
941 if { $menubar == 1 } {
942 pdtk_canvas_menubar $name $width $height $geometry $editable
943 }
944
945# the popup menu
946 menu $name.popup -tearoff false
947 $name.popup add command -label {Properties} \
948 -command [concat popup_action $name 0]
949 $name.popup add command -label {Open} \
950 -command [concat popup_action $name 1]
951 $name.popup add command -label {Help} \
952 -command [concat popup_action $name 2]
953
954# WM protocol
955 wm protocol $name WM_DELETE_WINDOW [concat menu_close $name]
956
957# bindings.
958# this is idiotic -- how do you just sense what mod keys are down and
959# pass them on? I can't find it anywhere.
960# Here we encode shift as 1, control 2, alt 4, in agreement
961# with definitions in g_canvas.c. The third button gets "8" but we don't
962# bother with modifiers there.
963# We don't handle multiple clicks yet.
964
965 bind $name.c <Button> {pdtk_canvas_click %W %x %y %b 0}
966 bind $name.c <Shift-Button> {pdtk_canvas_click %W %x %y %b 1}
967 bind $name.c <Control-Shift-Button> {pdtk_canvas_click %W %x %y %b 3}
968 bind $name.c <Alt-Button> {pdtk_canvas_click %W %x %y %b 4}
969 bind $name.c <Alt-Shift-Button> {pdtk_canvas_click %W %x %y %b 5}
970 bind $name.c <Alt-Control-Button> {pdtk_canvas_click %W %x %y %b 6}
971 bind $name.c <Alt-Control-Shift-Button> {pdtk_canvas_click %W %x %y %b 7}
972 global pd_nt
973 if {$pd_nt == 2} {
974 bind $name.c <Button-2> {pdtk_canvas_click %W %x %y %b 8}
975 bind $name.c <Control-Button> {pdtk_canvas_click %W %x %y %b 8}
976 } else {
977 bind $name.c <Button-3> {pdtk_canvas_click %W %x %y %b 8}
978 bind $name.c <Control-Button> {pdtk_canvas_click %W %x %y %b 2}
979 }
980# change mac to right-click, not middle click -atl 2002.09.02
981
982 bind $name.c <ButtonRelease> {pdtk_canvas_mouseup %W %x %y %b}
983 bind $name.c <Control-Key> {pdtk_canvas_ctrlkey %W %K 0}
984 bind $name.c <Control-Shift-Key> {pdtk_canvas_ctrlkey %W %K 1}
985 bind $name.c <Alt-Key> {pdtk_canvas_altkey %W %K %A}
986# bind $name.c <Mod1-Key> {puts stderr [concat mod1 %W %K %A]}
987 if {$pd_nt == 2} {
988 bind $name.c <Mod1-Key> {pdtk_canvas_ctrlkey %W %K 0}
989 bind $name.c <Mod1-Shift-Key> {pdtk_canvas_ctrlkey %W %K 1}
990 }
991 bind $name.c <Key> {pdtk_canvas_key %W %K %A 0}
992 bind $name.c <Shift-Key> {pdtk_canvas_key %W %K %A 1}
993 bind $name.c <KeyRelease> {pdtk_canvas_keyup %W %K %A}
994 bind $name.c <Motion> {pdtk_canvas_motion %W %x %y 0}
995 bind $name.c <Alt-Motion> {pdtk_canvas_motion %W %x %y 4}
996 bind $name.c <Map> {pdtk_canvas_map %W}
997 bind $name.c <Unmap> {pdtk_canvas_unmap %W}
998 focus $name.c
999# puts stderr "all done"
1000# after 1 [concat raise $name]
1001}
1002
1003#################### event binding procedures ################
1004
1005#get the name of the toplevel window for a canvas; this is also
1006#the name of the canvas object in Pd.
1007
1008proc canvastosym {name} {
1009 string range $name 0 [expr [string length $name] - 3]
1010}
1011
1012set pdtk_lastcanvasconfigured ""
1013set pdtk_lastcanvasconfiguration ""
1014
1015proc pdtk_canvas_checkgeometry {topname} {
1016 set boo [winfo geometry $topname.c]
1017 set boo2 [wm geometry $topname]
1018 global pdtk_lastcanvasconfigured
1019 global pdtk_lastcanvasconfiguration
1020 if {$topname != $pdtk_lastcanvasconfigured || \
1021 $boo != $pdtk_lastcanvasconfiguration} {
1022 set pdtk_lastcanvasconfigured $topname
1023 set pdtk_lastcanvasconfiguration $boo
1024 pd $topname relocate $boo $boo2 \;
1025 }
1026}
1027
1028proc pdtk_canvas_click {name x y b f} {
1029# puts stderr [concat got $f]
1030 pd [canvastosym $name] mouse [$name canvasx $x] [$name canvasy $y] $b $f \;
1031}
1032
1033proc pdtk_canvas_shiftclick {name x y b} {
1034 pd [canvastosym $name] mouse [$name canvasx $x] [$name canvasy $y] $b 1 \;
1035}
1036
1037proc pdtk_canvas_ctrlclick {name x y b} {
1038 pd [canvastosym $name] mouse [$name canvasx $x] [$name canvasy $y] $b 2 \;
1039}
1040
1041proc pdtk_canvas_altclick {name x y b} {
1042 pd [canvastosym $name] mouse [$name canvasx $x] [$name canvasy $y] $b 3 \;
1043}
1044
1045proc pdtk_canvas_dblclick {name x y b} {
1046 pd [canvastosym $name] mouse [$name canvasx $x] [$name canvasy $y] $b 4 \;
1047}
1048
1049set pdtk_canvas_mouseup_name 0
1050set pdtk_canvas_mouseup_xminval 0
1051set pdtk_canvas_mouseup_xmaxval 0
1052set pdtk_canvas_mouseup_yminval 0
1053set pdtk_canvas_mouseup_ymaxval 0
1054
1055proc pdtk_canvas_mouseup {name x y b} {
1056 pd [concat [canvastosym $name] mouseup [$name canvasx $x] \
1057 [$name canvasy $y] $b \;]
1058
1059# we use the mouseup event to update scrollbar ranges and recheck the
1060# geometry of the window since I haven't taken the time to figure out
1061# how to do it right.
1062
1063 global pdtk_canvas_mouseup_name
1064 global pdtk_canvas_mouseup_xminval
1065 global pdtk_canvas_mouseup_xmaxval
1066 global pdtk_canvas_mouseup_yminval
1067 global pdtk_canvas_mouseup_ymaxval
1068
1069 set size [$name bbox all]
1070 if {$size != ""} {
1071 set xminval 0
1072 set yminval 0
1073 set xmaxval 100
1074 set ymaxval 100
1075 set x1 [lindex $size 0]
1076 set x2 [lindex $size 2]
1077 set y1 [lindex $size 1]
1078 set y2 [lindex $size 3]
1079
1080 if {$x1 < 0} {set xminval $x1}
1081 if {$y1 < 0} {set yminval $y1}
1082
1083 if {$x2 > 100} {set xmaxval $x2}
1084 if {$y2 > 100} {set ymaxval $y2}
1085
1086 if {$pdtk_canvas_mouseup_name != $name || \
1087 $pdtk_canvas_mouseup_xminval != $xminval || \
1088 $pdtk_canvas_mouseup_xmaxval != $xmaxval || \
1089 $pdtk_canvas_mouseup_yminval != $yminval || \
1090 $pdtk_canvas_mouseup_ymaxval != $ymaxval } {
1091
1092 set newsize "$xminval $yminval $xmaxval $ymaxval"
1093 $name configure -scrollregion $newsize
1094 set pdtk_canvas_mouseup_name $name
1095 set pdtk_canvas_mouseup_xminval $xminval
1096 set pdtk_canvas_mouseup_xmaxval $xmaxval
1097 set pdtk_canvas_mouseup_yminval $yminval
1098 set pdtk_canvas_mouseup_ymaxval $ymaxval
1099 }
1100
1101 }
1102 pdtk_canvas_checkgeometry [canvastosym $name]
1103}
1104
1105proc pdtk_canvas_key {name key iso shift} {
1106# puts stderr [concat down key= $key iso= $iso]
1107# .controls.switches.meterbutton configure -text $key
1108# HACK for MAC OSX -- backspace seems different; I don't understand why.
1109# invesigate this LATER...
1110 global pd_nt
1111 if {$pd_nt == 2} {
1112 if {$key == "BackSpace"} {
1113 set key 8
1114 set keynum 8
1115 }
1116 if {$key == "Delete"} {
1117 set key 8
1118 set keynum 8
1119 }
1120 }
1121 if {$key == "KP_Delete"} {
1122 set key 127
1123 set keynum 127
1124 }
1125 if {$iso != ""} {
1126 scan $iso %c keynum
1127 pd [canvastosym $name] key 1 $keynum $shift\;
1128 } else {
1129 pd [canvastosym $name] key 1 $key $shift\;
1130 }
1131}
1132
1133proc pdtk_canvas_keyup {name key iso} {
1134# puts stderr [concat up key= $key iso= $iso]
1135 if {$iso != ""} {
1136 scan $iso %c keynum
1137 pd [canvastosym $name] key 0 $keynum 0 \;
1138 } else {
1139 pd [canvastosym $name] key 0 $key 0 \;
1140 }
1141}
1142
1143proc pdtk_canvas_altkey {name key iso} {
1144# puts stderr [concat alt-key $iso]
1145############iemlib##################
1146 set topname [string trimright $name .c]
1147 if {$key == "b" || $key == "B"} {menu_bng $topname 1}
1148 if {$key == "t" || $key == "T"} {menu_toggle $topname 1}
1149 if {$key == "n" || $key == "N"} {menu_numbox $topname 1}
1150 if {$key == "v" || $key == "V"} {menu_vslider $topname 1}
1151 if {$key == "h" || $key == "H"} {menu_hslider $topname 1}
1152 if {$key == "i" || $key == "I"} {menu_hradio $topname 1}
1153 if {$key == "d" || $key == "D"} {menu_vradio $topname 1}
1154 if {$key == "u" || $key == "U"} {menu_vumeter $topname 1}
1155 if {$key == "c" || $key == "C"} {menu_mycnv $topname 1}
1156############iemlib##################
1157}
1158
1159proc pdtk_canvas_ctrlkey {name key shift} {
1160# first get rid of ".c" suffix; we'll refer to the toplevel instead
1161 set topname [string trimright $name .c]
1162# puts stderr [concat ctrl-key $key $topname]
1163
1164 if {$key == "n" || $key == "N"} {menu_new}
1165 if {$key == "o" || $key == "O"} {menu_open}
1166 if {$key == "m" || $key == "M"} {menu_send}
1167 if {$key == "q" || $key == "Q"} {
1168 if {$shift == 1} {menu_really_quit} else {menu_quit}
1169 }
1170 if {$key == "s" || $key == "S"} {
1171 if {$shift == 1} {menu_saveas $topname} else {menu_save $topname}
1172 }
1173 if {$key == "z" || $key == "Z"} {
1174 if {$shift == 1} {menu_redo $topname} else {menu_undo $topname}
1175 }
1176 if {$key == "w" || $key == "W"} {menu_close $topname}
1177 if {$key == "p" || $key == "P"} {menu_print $topname}
1178 if {$key == "x" || $key == "X"} {menu_cut $topname}
1179 if {$key == "c" || $key == "C"} {menu_copy $topname}
1180 if {$key == "v" || $key == "V"} {menu_paste $topname}
1181 if {$key == "d" || $key == "D"} {menu_duplicate $topname}
1182 if {$key == "a" || $key == "A"} {menu_selectall $topname}
1183 if {$key == "t" || $key == "T"} {menu_texteditor $topname}
1184 if {$key == "f" || $key == "F"} {menu_findobject $topname}
1185 if {$key == "g" || $key == "G"} {menu_findagain $topname}
1186 if {$key == "1"} {menu_object $topname 1}
1187 if {$key == "2"} {menu_message $topname 1}
1188 if {$key == "3"} {menu_floatatom $topname 1}
1189 if {$key == "4"} {menu_symbolatom $topname 1}
1190 if {$key == "5"} {menu_comment $topname 1}
1191 if {$key == "slash"} {menu_audio 1}
1192 if {$key == "period"} {menu_audio 0}
1193 if {$key == "e" || $key == "E"} {menu_editmode $topname}
1194}
1195
1196proc pdtk_canvas_motion {name x y mods} {
1197# puts stderr [concat [canvastosym $name] $name $x $y]
1198 pd [canvastosym $name] motion [$name canvasx $x] [$name canvasy $y] $mods \;
1199}
1200
1201# "map" event tells us when the canvas becomes visible (arg is "0") or
1202# invisible (arg is ""). Invisibility means the Window Manager has minimized
1203# us. We don't get a final "unmap" event when we destroy the window.
1204proc pdtk_canvas_map {name} {
1205# puts stderr [concat map $name]
1206 pd [canvastosym $name] map 1 \;
1207}
1208
1209proc pdtk_canvas_unmap {name} {
1210# puts stderr [concat unmap $name]
1211 pd [canvastosym $name] map 0 \;
1212}
1213
1214set saveas_dir nowhere
1215
1216############ pdtk_canvas_saveas -- run a saveas dialog ##############
1217
1218proc pdtk_canvas_saveas {name initfile initdir} {
1219 set filename [tk_getSaveFile -initialfile $initfile \
1220 -initialdir $initdir -defaultextension .pd \
1221 -filetypes { {{pd files} {.pd}} {{max files} {.pat}} }]
1222
1223 if {$filename != ""} {
1224 set directory [string range $filename 0 \
1225 [expr [string last / $filename ] - 1]]
1226 set basename [string range $filename \
1227 [expr [string last / $filename ] + 1] end]
1228 pd [concat $name savetofile [pdtk_enquote $basename] \
1229 [pdtk_enquote $directory] \;]
1230# pd [concat $name savetofile $basename $directory \;]
1231 }
1232}
1233
1234############ pdtk_canvas_dofont -- run a font and resize dialog #########
1235
1236set fontsize 0
1237set stretchval 0
1238set whichstretch 0
1239
1240proc dofont_apply {name} {
1241 global fontsize
1242 global stretchval
1243 global whichstretch
1244 set cmd [concat $name font $fontsize $stretchval $whichstretch \;]
1245# puts stderr $cmd
1246 pd $cmd
1247}
1248
1249proc dofont_cancel {name} {
1250 set cmd [concat $name cancel \;]
1251# puts stderr $cmd
1252 pd $cmd
1253}
1254
1255proc pdtk_canvas_dofont {name initsize} {
1256
1257 global fontsize
1258 set fontsize $initsize
1259
1260 global stretchval
1261 set stretchval 100
1262
1263 global whichstretch
1264 set whichstretch 1
1265
1266 toplevel $name
1267 wm title $name {FONT BOMB}
1268 wm protocol $name WM_DELETE_WINDOW [concat dofont_cancel $name]
1269
1270 frame $name.buttonframe
1271 pack $name.buttonframe -side bottom -fill x -pady 2m
1272 button $name.buttonframe.cancel -text {Cancel}\
1273 -command "dofont_cancel $name"
1274 button $name.buttonframe.ok -text {Do it}\
1275 -command "dofont_apply $name"
1276 pack $name.buttonframe.cancel -side left -expand 1
1277 pack $name.buttonframe.ok -side left -expand 1
1278
1279 frame $name.radiof
1280 pack $name.radiof -side left
1281
1282 label $name.radiof.label -text {Font Size:}
1283 pack $name.radiof.label -side top
1284
1285 radiobutton $name.radiof.radio8 -value 8 -variable fontsize -text "8"
1286 radiobutton $name.radiof.radio10 -value 10 -variable fontsize -text "10"
1287 radiobutton $name.radiof.radio12 -value 12 -variable fontsize -text "12"
1288 radiobutton $name.radiof.radio16 -value 16 -variable fontsize -text "16"
1289 radiobutton $name.radiof.radio24 -value 24 -variable fontsize -text "24"
1290 radiobutton $name.radiof.radio36 -value 36 -variable fontsize -text "36"
1291 pack $name.radiof.radio8 -side top -anchor w
1292 pack $name.radiof.radio10 -side top -anchor w
1293 pack $name.radiof.radio12 -side top -anchor w
1294 pack $name.radiof.radio16 -side top -anchor w
1295 pack $name.radiof.radio24 -side top -anchor w
1296 pack $name.radiof.radio36 -side top -anchor w
1297
1298 frame $name.stretchf
1299 pack $name.stretchf -side left
1300
1301 label $name.stretchf.label -text {Stretch:}
1302 pack $name.stretchf.label -side top
1303
1304 entry $name.stretchf.entry -textvariable stretchval -width 5
1305 pack $name.stretchf.entry -side left
1306
1307 radiobutton $name.stretchf.radio1 \
1308 -value 1 -variable whichstretch -text "X and Y"
1309 radiobutton $name.stretchf.radio2 \
1310 -value 2 -variable whichstretch -text "X only"
1311 radiobutton $name.stretchf.radio3 \
1312 -value 3 -variable whichstretch -text "Y only"
1313
1314 pack $name.stretchf.radio1 -side top -anchor w
1315 pack $name.stretchf.radio2 -side top -anchor w
1316 pack $name.stretchf.radio3 -side top -anchor w
1317
1318}
1319
1320############ pdtk_gatom_dialog -- run a gatom dialog #########
1321
1322# see graph_apply, etc., for comments about handling variable names here...
1323
1324proc gatom_escape {sym} {
1325 if {[string length $sym] == 0} {
1326 set ret "-"
1327# puts stderr [concat escape1 $sym $ret]
1328 } else {
1329 if {[string equal -length 1 $sym "-"]} {
1330 set ret [string replace $sym 0 0 "--"]
1331# puts stderr [concat escape $sym $ret]
1332 } else {
1333 if {[string equal -length 1 $sym "$"]} {
1334 set ret [string replace $sym 0 0 "#"]
1335# puts stderr [concat unescape $sym $ret]
1336 } else {
1337 set ret $sym
1338# puts stderr [concat escape $sym "no change"]
1339 }
1340 }
1341 }
1342 concat $ret
1343}
1344
1345proc gatom_unescape {sym} {
1346 if {[string equal -length 1 $sym "-"]} {
1347 set ret [string replace $sym 0 0 ""]
1348# puts stderr [concat unescape $sym $ret]
1349 } else {
1350 if {[string equal -length 1 $sym "#"]} {
1351 set ret [string replace $sym 0 0 "$"]
1352# puts stderr [concat unescape $sym $ret]
1353 } else {
1354 set ret $sym
1355# puts stderr [concat unescape $sym "no change"]
1356 }
1357 }
1358 concat $ret
1359}
1360
1361proc dogatom_apply {id} {
1362 set vid [string trimleft $id .]
1363
1364 set var_gatomwidth [concat gatomwidth_$vid]
1365 global $var_gatomwidth
1366 set var_gatomlo [concat gatomlo_$vid]
1367 global $var_gatomlo
1368 set var_gatomhi [concat gatomhi_$vid]
1369 global $var_gatomhi
1370 set var_gatomwherelabel [concat gatomwherelabel_$vid]
1371 global $var_gatomwherelabel
1372 set var_gatomlabel [concat gatomlabel_$vid]
1373 global $var_gatomlabel
1374 set var_gatomsymfrom [concat gatomsymfrom_$vid]
1375 global $var_gatomsymfrom
1376 set var_gatomsymto [concat gatomsymto_$vid]
1377 global $var_gatomsymto
1378
1379# set cmd [concat $id param $gatomwidth $gatomlo $gatomhi \;]
1380
1381 set cmd [concat $id param \
1382 [eval concat $$var_gatomwidth] \
1383 [eval concat $$var_gatomlo] \
1384 [eval concat $$var_gatomhi] \
1385 [eval gatom_escape $$var_gatomlabel] \
1386 [eval concat $$var_gatomwherelabel] \
1387 [eval gatom_escape $$var_gatomsymfrom] \
1388 [eval gatom_escape $$var_gatomsymto] \
1389 \;]
1390
1391# puts stderr $cmd
1392 pd $cmd
1393}
1394
1395proc dogatom_cancel {name} {
1396 set cmd [concat $name cancel \;]
1397# puts stderr $cmd
1398 pd $cmd
1399}
1400
1401proc dogatom_ok {name} {
1402 dogatom_apply $name
1403 dogatom_cancel $name
1404}
1405
1406proc pdtk_gatom_dialog {id initwidth initlo inithi \
1407 wherelabel label symfrom symto} {
1408
1409 set vid [string trimleft $id .]
1410
1411 set var_gatomwidth [concat gatomwidth_$vid]
1412 global $var_gatomwidth
1413 set var_gatomlo [concat gatomlo_$vid]
1414 global $var_gatomlo
1415 set var_gatomhi [concat gatomhi_$vid]
1416 global $var_gatomhi
1417 set var_gatomwherelabel [concat gatomwherelabel_$vid]
1418 global $var_gatomwherelabel
1419 set var_gatomlabel [concat gatomlabel_$vid]
1420 global $var_gatomlabel
1421 set var_gatomsymfrom [concat gatomsymfrom_$vid]
1422 global $var_gatomsymfrom
1423 set var_gatomsymto [concat gatomsymto_$vid]
1424 global $var_gatomsymto
1425
1426 set $var_gatomwidth $initwidth
1427 set $var_gatomlo $initlo
1428 set $var_gatomhi $inithi
1429 set $var_gatomwherelabel $wherelabel
1430 set $var_gatomlabel [gatom_unescape $label]
1431 set $var_gatomsymfrom [gatom_unescape $symfrom]
1432 set $var_gatomsymto [gatom_unescape $symto]
1433
1434 toplevel $id
1435 wm title $id {Atom}
1436 wm protocol $id WM_DELETE_WINDOW [concat dogatom_cancel $id]
1437
1438 frame $id.buttonframe
1439 pack $id.buttonframe -side bottom -fill x -pady 2m
1440 button $id.buttonframe.cancel -text {Cancel}\
1441 -command "dogatom_cancel $id"
1442 button $id.buttonframe.apply -text {Apply}\
1443 -command "dogatom_apply $id"
1444 button $id.buttonframe.ok -text {OK}\
1445 -command "dogatom_ok $id"
1446 pack $id.buttonframe.cancel -side left -expand 1
1447 pack $id.buttonframe.apply -side left -expand 1
1448 pack $id.buttonframe.ok -side left -expand 1
1449
1450 frame $id.paramsymto
1451 pack $id.paramsymto -side bottom
1452 label $id.paramsymto.entryname -text {send symbol}
1453 entry $id.paramsymto.entry -textvariable $var_gatomsymto -width 20
1454 pack $id.paramsymto.entryname $id.paramsymto.entry -side left
1455
1456 frame $id.paramsymfrom
1457 pack $id.paramsymfrom -side bottom
1458 label $id.paramsymfrom.entryname -text {receive symbol}
1459 entry $id.paramsymfrom.entry -textvariable $var_gatomsymfrom -width 20
1460 pack $id.paramsymfrom.entryname $id.paramsymfrom.entry -side left
1461
1462 frame $id.radio
1463 pack $id.radio -side bottom
1464 label $id.radio.label -text {show label on:}
1465 frame $id.radio.l
1466 frame $id.radio.r
1467 pack $id.radio.label -side top
1468 pack $id.radio.l $id.radio.r -side left
1469 radiobutton $id.radio.l.radio0 -value 0 \
1470 -variable $var_gatomwherelabel \
1471 -text "left"
1472 radiobutton $id.radio.l.radio1 -value 1 \
1473 -variable $var_gatomwherelabel \
1474 -text "right"
1475 radiobutton $id.radio.r.radio2 -value 2 \
1476 -variable $var_gatomwherelabel \
1477 -text "top"
1478 radiobutton $id.radio.r.radio3 -value 3 \
1479 -variable $var_gatomwherelabel \
1480 -text "bottom"
1481 pack $id.radio.l.radio0 $id.radio.l.radio1 -side top -anchor w
1482 pack $id.radio.r.radio2 $id.radio.r.radio3 -side top -anchor w
1483
1484
1485 frame $id.paramlabel
1486 pack $id.paramlabel -side bottom
1487 label $id.paramlabel.entryname -text label
1488 entry $id.paramlabel.entry -textvariable $var_gatomlabel -width 20
1489 pack $id.paramlabel.entryname $id.paramlabel.entry -side left
1490
1491 frame $id.paramhi
1492 pack $id.paramhi -side bottom
1493 label $id.paramhi.entryname -text "upper limit"
1494 entry $id.paramhi.entry -textvariable $var_gatomhi -width 8
1495 pack $id.paramhi.entryname $id.paramhi.entry -side left
1496
1497 frame $id.paramlo
1498 pack $id.paramlo -side bottom
1499 label $id.paramlo.entryname -text "lower limit"
1500 entry $id.paramlo.entry -textvariable $var_gatomlo -width 8
1501 pack $id.paramlo.entryname $id.paramlo.entry -side left
1502
1503 frame $id.params
1504 pack $id.params -side bottom
1505 label $id.params.entryname -text width
1506 entry $id.params.entry -textvariable $var_gatomwidth -width 4
1507 pack $id.params.entryname $id.params.entry -side left
1508
1509
1510
1511 bind $id.paramhi.entry <KeyPress-Return> [concat dogatom_ok $id]
1512 bind $id.paramlo.entry <KeyPress-Return> [concat dogatom_ok $id]
1513 bind $id.params.entry <KeyPress-Return> [concat dogatom_ok $id]
1514 $id.params.entry select from 0
1515 $id.params.entry select adjust end
1516 focus $id.params.entry
1517}
1518
1519############ pdtk_canvas_popup -- popup menu for canvas #########
1520
1521set popup_xpix 0
1522set popup_ypix 0
1523
1524proc popup_action {name action} {
1525 global popup_xpix popup_ypix
1526 set cmd [concat $name done-popup $action $popup_xpix $popup_ypix \;]
1527# puts stderr $cmd
1528 pd $cmd
1529}
1530
1531proc pdtk_canvas_popup {name xpix ypix canprop canopen} {
1532 global popup_xpix popup_ypix
1533 set popup_xpix $xpix
1534 set popup_ypix $ypix
1535 if {$canprop == 0} {$name.popup entryconfigure 0 -state disabled}
1536 if {$canprop == 1} {$name.popup entryconfigure 0 -state active}
1537 if {$canopen == 0} {$name.popup entryconfigure 1 -state disabled}
1538 if {$canopen == 1} {$name.popup entryconfigure 1 -state active}
1539 tk_popup $name.popup [expr $xpix + [winfo rootx $name.c]] \
1540 [expr $ypix + [winfo rooty $name.c]] 0
1541}
1542
1543############ pdtk_graph_dialog -- dialog window for graphs #########
1544
1545# the graph and array dialogs can come up in many copies; but in TK the easiest
1546# way to get data from an "entry", etc., is to set an associated variable
1547# name. This is especially true for grouped "radio buttons". So we have
1548# to synthesize variable names for each instance of the dialog. The dialog
1549# gets a TK pathname $id, from which it strips the leading "." to make a
1550# variable suffix $vid. Then you can get the actual value out by asking for
1551# [eval concat $$variablename]. There should be an easier way but I don't see
1552# it yet.
1553
1554proc graph_apply {id} {
1555# strip "." from the TK id to make a variable name suffix
1556 set vid [string trimleft $id .]
1557# for each variable, make a local variable to hold its name...
1558 set var_graph_x1 [concat graph_x1_$vid]
1559 global $var_graph_x1
1560 set var_graph_x2 [concat graph_x2_$vid]
1561 global $var_graph_x2
1562 set var_graph_xpix [concat graph_xpix_$vid]
1563 global $var_graph_xpix
1564 set var_graph_y1 [concat graph_y1_$vid]
1565 global $var_graph_y1
1566 set var_graph_y2 [concat graph_y2_$vid]
1567 global $var_graph_y2
1568 set var_graph_ypix [concat graph_ypix_$vid]
1569 global $var_graph_ypix
1570
1571 pd [concat $id dialog \
1572 [eval concat $$var_graph_x1] \
1573 [eval concat $$var_graph_y1] \
1574 [eval concat $$var_graph_x2] \
1575 [eval concat $$var_graph_y2] \
1576 [eval concat $$var_graph_xpix] \
1577 [eval concat $$var_graph_ypix] \
1578 \;]
1579}
1580
1581proc graph_cancel {id} {
1582 set cmd [concat $id cancel \;]
1583# puts stderr $cmd
1584 pd $cmd
1585}
1586
1587proc graph_ok {id} {
1588 graph_apply $id
1589 graph_cancel $id
1590}
1591
1592proc pdtk_graph_dialog {id x1 y1 x2 y2 xpix ypix} {
1593 set vid [string trimleft $id .]
1594 set var_graph_x1 [concat graph_x1_$vid]
1595 global $var_graph_x1
1596 set var_graph_x2 [concat graph_x2_$vid]
1597 global $var_graph_x2
1598 set var_graph_xpix [concat graph_xpix_$vid]
1599 global $var_graph_xpix
1600 set var_graph_y1 [concat graph_y1_$vid]
1601 global $var_graph_y1
1602 set var_graph_y2 [concat graph_y2_$vid]
1603 global $var_graph_y2
1604 set var_graph_ypix [concat graph_ypix_$vid]
1605 global $var_graph_ypix
1606
1607 set $var_graph_x1 $x1
1608 set $var_graph_x2 $x2
1609 set $var_graph_xpix $xpix
1610 set $var_graph_y1 $y1
1611 set $var_graph_y2 $y2
1612 set $var_graph_ypix $ypix
1613
1614 toplevel $id
1615 wm title $id {graph}
1616 wm protocol $id WM_DELETE_WINDOW [concat graph_cancel $id]
1617
1618 label $id.label -text {GRAPH BOUNDS}
1619 pack $id.label -side top
1620
1621 frame $id.buttonframe
1622 pack $id.buttonframe -side bottom -fill x -pady 2m
1623 button $id.buttonframe.cancel -text {Cancel}\
1624 -command "graph_cancel $id"
1625 button $id.buttonframe.apply -text {Apply}\
1626 -command "graph_apply $id"
1627 button $id.buttonframe.ok -text {OK}\
1628 -command "graph_ok $id"
1629 pack $id.buttonframe.cancel -side left -expand 1
1630 pack $id.buttonframe.apply -side left -expand 1
1631 pack $id.buttonframe.ok -side left -expand 1
1632
1633 frame $id.xrangef
1634 pack $id.xrangef -side top
1635
1636 label $id.xrangef.l1 -text "X from:"
1637 entry $id.xrangef.x1 -textvariable $var_graph_x1 -width 7
1638 label $id.xrangef.l2 -text "to:"
1639 entry $id.xrangef.x2 -textvariable $var_graph_x2 -width 7
1640 label $id.xrangef.l3 -text "screen width:"
1641 entry $id.xrangef.xpix -textvariable $var_graph_xpix -width 7
1642 pack $id.xrangef.l1 $id.xrangef.x1 \
1643 $id.xrangef.l2 $id.xrangef.x2 \
1644 $id.xrangef.l3 $id.xrangef.xpix -side left
1645
1646 frame $id.yrangef
1647 pack $id.yrangef -side top
1648
1649# dig in the following that the upper bound is labeled y1 but the variable is
1650# y2, etc. This is to deal with the inconsistent use of "upper and lower"
1651# graph bounds... in the dialog the upper Y bound is the lower valued Y pixel.
1652 label $id.yrangef.l1 -text "Y from:"
1653 entry $id.yrangef.y1 -textvariable $var_graph_y2 -width 7
1654 label $id.yrangef.l2 -text "to:"
1655 entry $id.yrangef.y2 -textvariable $var_graph_y1 -width 7
1656 label $id.yrangef.l3 -text "screen height:"
1657 entry $id.yrangef.ypix -textvariable $var_graph_ypix -width 7
1658 pack $id.yrangef.l1 $id.yrangef.y1 \
1659 $id.yrangef.l2 $id.yrangef.y2 \
1660 $id.yrangef.l3 $id.yrangef.ypix -side left
1661
1662 bind $id.xrangef.x1 <KeyPress-Return> [concat graph_ok $id]
1663 bind $id.xrangef.x2 <KeyPress-Return> [concat graph_ok $id]
1664 bind $id.xrangef.xpix <KeyPress-Return> [concat graph_ok $id]
1665 bind $id.yrangef.y1 <KeyPress-Return> [concat graph_ok $id]
1666 bind $id.yrangef.y2 <KeyPress-Return> [concat graph_ok $id]
1667 bind $id.yrangef.ypix <KeyPress-Return> [concat graph_ok $id]
1668 $id.xrangef.x2 select from 0
1669 $id.xrangef.x2 select adjust end
1670 focus $id.xrangef.x2
1671}
1672
1673# begin of change "iemlib"
1674############ pdtk_iemgui_dialog -- dialog window for iem guis #########
1675
1676set iemgui_define_min_flashhold 50
1677set iemgui_define_min_flashbreak 10
1678set iemgui_define_min_fontsize 4
1679
1680proc iemgui_clip_dim {id} {
1681 set vid [string trimleft $id .]
1682
1683 set var_iemgui_wdt [concat iemgui_wdt_$vid]
1684 global $var_iemgui_wdt
1685 set var_iemgui_min_wdt [concat iemgui_min_wdt_$vid]
1686 global $var_iemgui_min_wdt
1687 set var_iemgui_hgt [concat iemgui_hgt_$vid]
1688 global $var_iemgui_hgt
1689 set var_iemgui_min_hgt [concat iemgui_min_hgt_$vid]
1690 global $var_iemgui_min_hgt
1691
1692 if {[eval concat $$var_iemgui_wdt] < [eval concat $$var_iemgui_min_wdt]} {
1693 set $var_iemgui_wdt [eval concat $$var_iemgui_min_wdt]
1694 $id.dim.w_ent configure -textvariable $var_iemgui_wdt
1695 }
1696 if {[eval concat $$var_iemgui_hgt] < [eval concat $$var_iemgui_min_hgt]} {
1697 set $var_iemgui_hgt [eval concat $$var_iemgui_min_hgt]
1698 $id.dim.h_ent configure -textvariable $var_iemgui_hgt
1699 }
1700}
1701
1702proc iemgui_clip_num {id} {
1703 set vid [string trimleft $id .]
1704
1705 set var_iemgui_num [concat iemgui_num_$vid]
1706 global $var_iemgui_num
1707
1708 if {[eval concat $$var_iemgui_num] > 2000} {
1709 set $var_iemgui_num 2000
1710 $id.para.num_ent configure -textvariable $var_iemgui_num
1711 }
1712 if {[eval concat $$var_iemgui_num] < 1} {
1713 set $var_iemgui_num 1
1714 $id.para.num_ent configure -textvariable $var_iemgui_num
1715 }
1716}
1717
1718proc iemgui_sched_rng {id} {
1719 set vid [string trimleft $id .]
1720
1721 set var_iemgui_min_rng [concat iemgui_min_rng_$vid]
1722 global $var_iemgui_min_rng
1723 set var_iemgui_max_rng [concat iemgui_max_rng_$vid]
1724 global $var_iemgui_max_rng
1725 set var_iemgui_rng_sch [concat iemgui_rng_sch_$vid]
1726 global $var_iemgui_rng_sch
1727
1728 global iemgui_define_min_flashhold
1729 global iemgui_define_min_flashbreak
1730
1731 if {[eval concat $$var_iemgui_rng_sch] == 2} {
1732 if {[eval concat $$var_iemgui_max_rng] < [eval concat $$var_iemgui_min_rng]} {
1733 set hhh [eval concat $$var_iemgui_min_rng]
1734 set $var_iemgui_min_rng [eval concat $$var_iemgui_max_rng]
1735 set $var_iemgui_max_rng $hhh
1736 $id.rng.max_ent configure -textvariable $var_iemgui_max_rng
1737 $id.rng.min_ent configure -textvariable $var_iemgui_min_rng }
1738 if {[eval concat $$var_iemgui_max_rng] < $iemgui_define_min_flashhold} {
1739 set $var_iemgui_max_rng $iemgui_define_min_flashhold
1740 $id.rng.max_ent configure -textvariable $var_iemgui_max_rng
1741 }
1742 if {[eval concat $$var_iemgui_min_rng] < $iemgui_define_min_flashbreak} {
1743 set $var_iemgui_min_rng $iemgui_define_min_flashbreak
1744 $id.rng.min_ent configure -textvariable $var_iemgui_min_rng
1745 }
1746 }
1747 if {[eval concat $$var_iemgui_rng_sch] == 1} {
1748 if {[eval concat $$var_iemgui_min_rng] == 0.0} {
1749 set $var_iemgui_min_rng 1.0
1750 $id.rng.min_ent configure -textvariable $var_iemgui_min_rng
1751 }
1752 }
1753}
1754
1755proc iemgui_verify_rng {id} {
1756 set vid [string trimleft $id .]
1757
1758 set var_iemgui_min_rng [concat iemgui_min_rng_$vid]
1759 global $var_iemgui_min_rng
1760 set var_iemgui_max_rng [concat iemgui_max_rng_$vid]
1761 global $var_iemgui_max_rng
1762 set var_iemgui_lin0_log1 [concat iemgui_lin0_log1_$vid]
1763 global $var_iemgui_lin0_log1
1764
1765 if {[eval concat $$var_iemgui_lin0_log1] == 1} {
1766 if {[eval concat $$var_iemgui_max_rng] == 0.0 && [eval concat $$var_iemgui_min_rng] == 0.0} {
1767 set $var_iemgui_max_rng 1.0
1768 $id.rng.max_ent configure -textvariable $var_iemgui_max_rng
1769 }
1770 if {[eval concat $$var_iemgui_max_rng] > 0} {
1771 if {[eval concat $$var_iemgui_min_rng] <= 0} {
1772 set $var_iemgui_min_rng [expr [eval concat $$var_iemgui_max_rng] * 0.01]
1773 $id.rng.min_ent configure -textvariable $var_iemgui_min_rng
1774 }
1775 } else {
1776 if {[eval concat $$var_iemgui_min_rng] > 0} {
1777 set $var_iemgui_max_rng [expr [eval concat $$var_iemgui_min_rng] * 0.01]
1778 $id.rng.max_ent configure -textvariable $var_iemgui_max_rng
1779 }
1780 }
1781 }
1782}
1783
1784proc iemgui_clip_fontsize {id} {
1785 set vid [string trimleft $id .]
1786
1787 set var_iemgui_gn_fs [concat iemgui_gn_fs_$vid]
1788 global $var_iemgui_gn_fs
1789
1790 global iemgui_define_min_fontsize
1791
1792 if {[eval concat $$var_iemgui_gn_fs] < $iemgui_define_min_fontsize} {
1793 set $var_iemgui_gn_fs $iemgui_define_min_fontsize
1794 $id.gnfs.fs_ent configure -textvariable $var_iemgui_gn_fs
1795 }
1796}
1797
1798proc iemgui_set_col_example {id} {
1799 set vid [string trimleft $id .]
1800
1801 set var_iemgui_bcol [concat iemgui_bcol_$vid]
1802 global $var_iemgui_bcol
1803 set var_iemgui_fcol [concat iemgui_fcol_$vid]
1804 global $var_iemgui_fcol
1805 set var_iemgui_lcol [concat iemgui_lcol_$vid]
1806 global $var_iemgui_lcol
1807
1808 $id.col_example_choose.lb_bk configure \
1809 -background [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
1810 -activebackground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
1811 -foreground [format "#%6.6x" [eval concat $$var_iemgui_lcol]] \
1812 -activeforeground [format "#%6.6x" [eval concat $$var_iemgui_lcol]]
1813
1814 if { [eval concat $$var_iemgui_fcol] >= 0 } {
1815 $id.col_example_choose.fr_bk configure \
1816 -background [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
1817 -activebackground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
1818 -foreground [format "#%6.6x" [eval concat $$var_iemgui_fcol]] \
1819 -activeforeground [format "#%6.6x" [eval concat $$var_iemgui_fcol]]
1820 } else {
1821 $id.col_example_choose.fr_bk configure \
1822 -background [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
1823 -activebackground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
1824 -foreground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
1825 -activeforeground [format "#%6.6x" [eval concat $$var_iemgui_bcol]]}
1826}
1827
1828proc iemgui_preset_col {id presetcol} {
1829 set vid [string trimleft $id .]
1830
1831 set var_iemgui_l2_f1_b0 [concat iemgui_l2_f1_b0_$vid]
1832 global $var_iemgui_l2_f1_b0
1833 set var_iemgui_bcol [concat iemgui_bcol_$vid]
1834 global $var_iemgui_bcol
1835 set var_iemgui_fcol [concat iemgui_fcol_$vid]
1836 global $var_iemgui_fcol
1837 set var_iemgui_lcol [concat iemgui_lcol_$vid]
1838 global $var_iemgui_lcol
1839
1840 if { [eval concat $$var_iemgui_l2_f1_b0] == 0 } { set $var_iemgui_bcol $presetcol }
1841 if { [eval concat $$var_iemgui_l2_f1_b0] == 1 } { set $var_iemgui_fcol $presetcol }
1842 if { [eval concat $$var_iemgui_l2_f1_b0] == 2 } { set $var_iemgui_lcol $presetcol }
1843 iemgui_set_col_example $id
1844}
1845
1846proc iemgui_choose_col_bkfrlb {id} {
1847 set vid [string trimleft $id .]
1848
1849 set var_iemgui_l2_f1_b0 [concat iemgui_l2_f1_b0_$vid]
1850 global $var_iemgui_l2_f1_b0
1851 set var_iemgui_bcol [concat iemgui_bcol_$vid]
1852 global $var_iemgui_bcol
1853 set var_iemgui_fcol [concat iemgui_fcol_$vid]
1854 global $var_iemgui_fcol
1855 set var_iemgui_lcol [concat iemgui_lcol_$vid]
1856 global $var_iemgui_lcol
1857
1858 if {[eval concat $$var_iemgui_l2_f1_b0] == 0} {
1859 set $var_iemgui_bcol [expr [eval concat $$var_iemgui_bcol] & 0xFCFCFC]
1860 set helpstring [tk_chooseColor -title "Background-Color" -initialcolor [format "#%6.6x" [eval concat $$var_iemgui_bcol]]]
1861 if { $helpstring != "" } {
1862 set $var_iemgui_bcol [string replace $helpstring 0 0 "0x"]
1863 set $var_iemgui_bcol [expr [eval concat $$var_iemgui_bcol] & 0xFCFCFC] }
1864 }
1865 if {[eval concat $$var_iemgui_l2_f1_b0] == 1} {
1866 set $var_iemgui_fcol [expr [eval concat $$var_iemgui_fcol] & 0xFCFCFC]
1867 set helpstring [tk_chooseColor -title "Front-Color" -initialcolor [format "#%6.6x" [eval concat $$var_iemgui_fcol]]]
1868 if { $helpstring != "" } {
1869 set $var_iemgui_fcol [string replace $helpstring 0 0 "0x"]
1870 set $var_iemgui_fcol [expr [eval concat $$var_iemgui_fcol] & 0xFCFCFC] }
1871 }
1872 if {[eval concat $$var_iemgui_l2_f1_b0] == 2} {
1873 set $var_iemgui_lcol [expr [eval concat $$var_iemgui_lcol] & 0xFCFCFC]
1874 set helpstring [tk_chooseColor -title "Label-Color" -initialcolor [format "#%6.6x" [eval concat $$var_iemgui_lcol]]]
1875 if { $helpstring != "" } {
1876 set $var_iemgui_lcol [string replace $helpstring 0 0 "0x"]
1877 set $var_iemgui_lcol [expr [eval concat $$var_iemgui_lcol] & 0xFCFCFC] }
1878 }
1879 iemgui_set_col_example $id
1880}
1881
1882proc iemgui_lilo {id} {
1883 set vid [string trimleft $id .]
1884
1885 set var_iemgui_lin0_log1 [concat iemgui_lin0_log1_$vid]
1886 global $var_iemgui_lin0_log1
1887 set var_iemgui_lilo0 [concat iemgui_lilo0_$vid]
1888 global $var_iemgui_lilo0
1889 set var_iemgui_lilo1 [concat iemgui_lilo1_$vid]
1890 global $var_iemgui_lilo1
1891
1892 iemgui_sched_rng $id
1893
1894 if {[eval concat $$var_iemgui_lin0_log1] == 0} {
1895 set $var_iemgui_lin0_log1 1
1896 $id.para.lilo configure -text [eval concat $$var_iemgui_lilo1]
1897 iemgui_verify_rng $id
1898 iemgui_sched_rng $id
1899 } else {
1900 set $var_iemgui_lin0_log1 0
1901 $id.para.lilo configure -text [eval concat $$var_iemgui_lilo0]
1902 }
1903}
1904
1905proc iemgui_toggle_font {id} {
1906 set vid [string trimleft $id .]
1907
1908 set var_iemgui_gn_f [concat iemgui_gn_f_$vid]
1909 global $var_iemgui_gn_f
1910
1911 set $var_iemgui_gn_f [expr [eval concat $$var_iemgui_gn_f] + 1]
1912 if {[eval concat $$var_iemgui_gn_f] > 2} {set $var_iemgui_gn_f 0}
1913 if {[eval concat $$var_iemgui_gn_f] == 0} {$id.gnfs.fb configure -text "courier" -font {courier 10 bold}}
1914 if {[eval concat $$var_iemgui_gn_f] == 1} {$id.gnfs.fb configure -text "helvetica" -font {helvetica 10 bold}}
1915 if {[eval concat $$var_iemgui_gn_f] == 2} {$id.gnfs.fb configure -text "times" -font {times 10 bold}}
1916}
1917
1918proc iemgui_lb {id} {
1919 set vid [string trimleft $id .]
1920
1921 set var_iemgui_loadbang [concat iemgui_loadbang_$vid]
1922 global $var_iemgui_loadbang
1923
1924 if {[eval concat $$var_iemgui_loadbang] == 0} {
1925 set $var_iemgui_loadbang 1
1926 $id.para.lb configure -text "init"
1927 } else {
1928 set $var_iemgui_loadbang 0
1929 $id.para.lb configure -text "no init"
1930 }
1931}
1932
1933proc iemgui_stdy_jmp {id} {
1934 set vid [string trimleft $id .]
1935
1936 set var_iemgui_steady [concat iemgui_steady_$vid]
1937 global $var_iemgui_steady
1938
1939 if {[eval concat $$var_iemgui_steady]} {
1940 set $var_iemgui_steady 0
1941 $id.para.stdy_jmp configure -text "jump on click"
1942 } else {
1943 set $var_iemgui_steady 1
1944 $id.para.stdy_jmp configure -text "steady on click"
1945 }
1946}
1947
1948proc iemgui_apply {id} {
1949 set vid [string trimleft $id .]
1950
1951 set var_iemgui_wdt [concat iemgui_wdt_$vid]
1952 global $var_iemgui_wdt
1953 set var_iemgui_min_wdt [concat iemgui_min_wdt_$vid]
1954 global $var_iemgui_min_wdt
1955 set var_iemgui_hgt [concat iemgui_hgt_$vid]
1956 global $var_iemgui_hgt
1957 set var_iemgui_min_hgt [concat iemgui_min_hgt_$vid]
1958 global $var_iemgui_min_hgt
1959 set var_iemgui_min_rng [concat iemgui_min_rng_$vid]
1960 global $var_iemgui_min_rng
1961 set var_iemgui_max_rng [concat iemgui_max_rng_$vid]
1962 global $var_iemgui_max_rng
1963 set var_iemgui_lin0_log1 [concat iemgui_lin0_log1_$vid]
1964 global $var_iemgui_lin0_log1
1965 set var_iemgui_lilo0 [concat iemgui_lilo0_$vid]
1966 global $var_iemgui_lilo0
1967 set var_iemgui_lilo1 [concat iemgui_lilo1_$vid]
1968 global $var_iemgui_lilo1
1969 set var_iemgui_loadbang [concat iemgui_loadbang_$vid]
1970 global $var_iemgui_loadbang
1971 set var_iemgui_num [concat iemgui_num_$vid]
1972 global $var_iemgui_num
1973 set var_iemgui_steady [concat iemgui_steady_$vid]
1974 global $var_iemgui_steady
1975 set var_iemgui_snd [concat iemgui_snd_$vid]
1976 global $var_iemgui_snd
1977 set var_iemgui_rcv [concat iemgui_rcv_$vid]
1978 global $var_iemgui_rcv
1979 set var_iemgui_gui_nam [concat iemgui_gui_nam_$vid]
1980 global $var_iemgui_gui_nam
1981 set var_iemgui_gn_dx [concat iemgui_gn_dx_$vid]
1982 global $var_iemgui_gn_dx
1983 set var_iemgui_gn_dy [concat iemgui_gn_dy_$vid]
1984 global $var_iemgui_gn_dy
1985 set var_iemgui_gn_f [concat iemgui_gn_f_$vid]
1986 global $var_iemgui_gn_f
1987 set var_iemgui_gn_fs [concat iemgui_gn_fs_$vid]
1988 global $var_iemgui_gn_fs
1989 set var_iemgui_bcol [concat iemgui_bcol_$vid]
1990 global $var_iemgui_bcol
1991 set var_iemgui_fcol [concat iemgui_fcol_$vid]
1992 global $var_iemgui_fcol
1993 set var_iemgui_lcol [concat iemgui_lcol_$vid]
1994 global $var_iemgui_lcol
1995
1996 iemgui_clip_dim $id
1997 iemgui_clip_num $id
1998 iemgui_sched_rng $id
1999 iemgui_verify_rng $id
2000 iemgui_sched_rng $id
2001 iemgui_clip_fontsize $id
2002
2003 if {[eval concat $$var_iemgui_snd] == ""} {set hhhsnd "empty"} else {set hhhsnd [eval concat $$var_iemgui_snd]}
2004 if {[eval concat $$var_iemgui_rcv] == ""} {set hhhrcv "empty"} else {set hhhrcv [eval concat $$var_iemgui_rcv]}
2005 if {[eval concat $$var_iemgui_gui_nam] == ""} {set hhhgui_nam "empty"
2006 } else {
2007 set hhhgui_nam [eval concat $$var_iemgui_gui_nam]}
2008
2009 if {[string index $hhhsnd 0] == "$"} {
2010 set hhhsnd [string replace $hhhsnd 0 0 #] }
2011 if {[string index $hhhrcv 0] == "$"} {
2012 set hhhrcv [string replace $hhhrcv 0 0 #] }
2013 if {[string index $hhhgui_nam 0] == "$"} {
2014 set hhhgui_nam [string replace $hhhgui_nam 0 0 #] }
2015
2016 set hhhsnd [string map {" " _} $hhhsnd]
2017 set hhhrcv [string map {" " _} $hhhrcv]
2018 set hhhgui_nam [string map {" " _} $hhhgui_nam]
2019
2020 pd [concat $id dialog \
2021 [eval concat $$var_iemgui_wdt] \
2022 [eval concat $$var_iemgui_hgt] \
2023 [eval concat $$var_iemgui_min_rng] \
2024 [eval concat $$var_iemgui_max_rng] \
2025 [eval concat $$var_iemgui_lin0_log1] \
2026 [eval concat $$var_iemgui_loadbang] \
2027 [eval concat $$var_iemgui_num] \
2028 $hhhsnd \
2029 $hhhrcv \
2030 $hhhgui_nam \
2031 [eval concat $$var_iemgui_gn_dx] \
2032 [eval concat $$var_iemgui_gn_dy] \
2033 [eval concat $$var_iemgui_gn_f] \
2034 [eval concat $$var_iemgui_gn_fs] \
2035 [eval concat $$var_iemgui_bcol] \
2036 [eval concat $$var_iemgui_fcol] \
2037 [eval concat $$var_iemgui_lcol] \
2038 [eval concat $$var_iemgui_steady] \
2039 \;]
2040}
2041
2042proc iemgui_cancel {id} {pd [concat $id cancel \;]}
2043
2044proc iemgui_ok {id} {
2045 iemgui_apply $id
2046 iemgui_cancel $id
2047}
2048
2049proc pdtk_iemgui_dialog {id mainheader \
2050 dim_header wdt min_wdt wdt_label hgt min_hgt hgt_label \
2051 rng_header min_rng min_rng_label max_rng max_rng_label rng_sched \
2052 lin0_log1 lilo0_label lilo1_label loadbang steady num_label num \
2053 snd rcv \
2054 gui_name \
2055 gn_dx gn_dy \
2056 gn_f gn_fs \
2057 bcol fcol lcol} {
2058
2059 set vid [string trimleft $id .]
2060
2061 set var_iemgui_wdt [concat iemgui_wdt_$vid]
2062 global $var_iemgui_wdt
2063 set var_iemgui_min_wdt [concat iemgui_min_wdt_$vid]
2064 global $var_iemgui_min_wdt
2065 set var_iemgui_hgt [concat iemgui_hgt_$vid]
2066 global $var_iemgui_hgt
2067 set var_iemgui_min_hgt [concat iemgui_min_hgt_$vid]
2068 global $var_iemgui_min_hgt
2069 set var_iemgui_min_rng [concat iemgui_min_rng_$vid]
2070 global $var_iemgui_min_rng
2071 set var_iemgui_max_rng [concat iemgui_max_rng_$vid]
2072 global $var_iemgui_max_rng
2073 set var_iemgui_rng_sch [concat iemgui_rng_sch_$vid]
2074 global $var_iemgui_rng_sch
2075 set var_iemgui_lin0_log1 [concat iemgui_lin0_log1_$vid]
2076 global $var_iemgui_lin0_log1
2077 set var_iemgui_lilo0 [concat iemgui_lilo0_$vid]
2078 global $var_iemgui_lilo0
2079 set var_iemgui_lilo1 [concat iemgui_lilo1_$vid]
2080 global $var_iemgui_lilo1
2081 set var_iemgui_loadbang [concat iemgui_loadbang_$vid]
2082 global $var_iemgui_loadbang
2083 set var_iemgui_num [concat iemgui_num_$vid]
2084 global $var_iemgui_num
2085 set var_iemgui_steady [concat iemgui_steady_$vid]
2086 global $var_iemgui_steady
2087 set var_iemgui_snd [concat iemgui_snd_$vid]
2088 global $var_iemgui_snd
2089 set var_iemgui_rcv [concat iemgui_rcv_$vid]
2090 global $var_iemgui_rcv
2091 set var_iemgui_gui_nam [concat iemgui_gui_nam_$vid]
2092 global $var_iemgui_gui_nam
2093 set var_iemgui_gn_dx [concat iemgui_gn_dx_$vid]
2094 global $var_iemgui_gn_dx
2095 set var_iemgui_gn_dy [concat iemgui_gn_dy_$vid]
2096 global $var_iemgui_gn_dy
2097 set var_iemgui_gn_f [concat iemgui_gn_f_$vid]
2098 global $var_iemgui_gn_f
2099 set var_iemgui_gn_fs [concat iemgui_gn_fs_$vid]
2100 global $var_iemgui_gn_fs
2101 set var_iemgui_l2_f1_b0 [concat iemgui_l2_f1_b0_$vid]
2102 global $var_iemgui_l2_f1_b0
2103 set var_iemgui_bcol [concat iemgui_bcol_$vid]
2104 global $var_iemgui_bcol
2105 set var_iemgui_fcol [concat iemgui_fcol_$vid]
2106 global $var_iemgui_fcol
2107 set var_iemgui_lcol [concat iemgui_lcol_$vid]
2108 global $var_iemgui_lcol
2109
2110 set $var_iemgui_wdt $wdt
2111 set $var_iemgui_min_wdt $min_wdt
2112 set $var_iemgui_hgt $hgt
2113 set $var_iemgui_min_hgt $min_hgt
2114 set $var_iemgui_min_rng $min_rng
2115 set $var_iemgui_max_rng $max_rng
2116 set $var_iemgui_rng_sch $rng_sched
2117 set $var_iemgui_lin0_log1 $lin0_log1
2118 set $var_iemgui_lilo0 $lilo0_label
2119 set $var_iemgui_lilo1 $lilo1_label
2120 set $var_iemgui_loadbang $loadbang
2121 set $var_iemgui_num $num
2122 set $var_iemgui_steady $steady
2123 if {$snd == "empty"} {set $var_iemgui_snd [format ""]
2124 } else {set $var_iemgui_snd [format "%s" $snd]}
2125 if {$rcv == "empty"} {set $var_iemgui_rcv [format ""]
2126 } else {set $var_iemgui_rcv [format "%s" $rcv]}
2127 if {$gui_name == "empty"} {set $var_iemgui_gui_nam [format ""]
2128 } else {set $var_iemgui_gui_nam [format "%s" $gui_name]}
2129
2130 if {[string index [eval concat $$var_iemgui_snd] 0] == "#"} {
2131 set $var_iemgui_snd [string replace [eval concat $$var_iemgui_snd] 0 0 $] }
2132 if {[string index [eval concat $$var_iemgui_rcv] 0] == "#"} {
2133 set $var_iemgui_rcv [string replace [eval concat $$var_iemgui_rcv] 0 0 $] }
2134 if {[string index [eval concat $$var_iemgui_gui_nam] 0] == "#"} {
2135 set $var_iemgui_gui_nam [string replace [eval concat $$var_iemgui_gui_nam] 0 0 $] }
2136 set $var_iemgui_gn_dx $gn_dx
2137 set $var_iemgui_gn_dy $gn_dy
2138 set $var_iemgui_gn_f $gn_f
2139 set $var_iemgui_gn_fs $gn_fs
2140
2141 set $var_iemgui_bcol $bcol
2142 set $var_iemgui_fcol $fcol
2143 set $var_iemgui_lcol $lcol
2144
2145 set $var_iemgui_l2_f1_b0 0
2146
2147 toplevel $id
2148 wm title $id [format "%s-PROPERTIES" $mainheader]
2149 wm protocol $id WM_DELETE_WINDOW [concat iemgui_cancel $id]
2150
2151 frame $id.dim
2152 pack $id.dim -side top
2153 label $id.dim.head -text $dim_header
2154 label $id.dim.w_lab -text $wdt_label -width 6
2155 entry $id.dim.w_ent -textvariable $var_iemgui_wdt -width 5
2156 label $id.dim.dummy1 -text " " -width 10
2157 label $id.dim.h_lab -text $hgt_label -width 6
2158 entry $id.dim.h_ent -textvariable $var_iemgui_hgt -width 5
2159 pack $id.dim.head -side top
2160 pack $id.dim.w_lab $id.dim.w_ent $id.dim.dummy1 -side left
2161 if { $hgt_label != "empty" } {
2162 pack $id.dim.h_lab $id.dim.h_ent -side left}
2163
2164 frame $id.rng
2165 pack $id.rng -side top
2166 label $id.rng.head -text $rng_header
2167 label $id.rng.min_lab -text $min_rng_label -width 6
2168 entry $id.rng.min_ent -textvariable $var_iemgui_min_rng -width 9
2169 label $id.rng.dummy1 -text " " -width 1
2170 label $id.rng.max_lab -text $max_rng_label -width 8
2171 entry $id.rng.max_ent -textvariable $var_iemgui_max_rng -width 9
2172 if { $rng_header != "empty" } {
2173 pack $id.rng.head -side top
2174 if { $min_rng_label != "empty" } {
2175 pack $id.rng.min_lab $id.rng.min_ent -side left}
2176 if { $max_rng_label != "empty" } {
2177 pack $id.rng.dummy1 \
2178 $id.rng.max_lab $id.rng.max_ent -side left} }
2179
2180 if { [eval concat $$var_iemgui_lin0_log1] >= 0 || [eval concat $$var_iemgui_loadbang] >= 0 || [eval concat $$var_iemgui_num] > 0 || [eval concat $$var_iemgui_steady] >= 0 } {
2181 label $id.space1 -text "---------------------------------"
2182 pack $id.space1 -side top }
2183
2184 frame $id.para
2185 pack $id.para -side top
2186 label $id.para.dummy2 -text "" -width 1
2187 label $id.para.dummy3 -text "" -width 1
2188 if {[eval concat $$var_iemgui_lin0_log1] == 0} {
2189 button $id.para.lilo -text [eval concat $$var_iemgui_lilo0] -width 5 -command "iemgui_lilo $id" }
2190 if {[eval concat $$var_iemgui_lin0_log1] == 1} {
2191 button $id.para.lilo -text [eval concat $$var_iemgui_lilo1] -width 5 -command "iemgui_lilo $id" }
2192 if {[eval concat $$var_iemgui_loadbang] == 0} {
2193 button $id.para.lb -text "no init" -width 5 -command "iemgui_lb $id" }
2194 if {[eval concat $$var_iemgui_loadbang] == 1} {
2195 button $id.para.lb -text "init" -width 5 -command "iemgui_lb $id" }
2196 label $id.para.num_lab -text $num_label -width 9
2197 entry $id.para.num_ent -textvariable $var_iemgui_num -width 4
2198 if {[eval concat $$var_iemgui_steady] == 0} {
2199 button $id.para.stdy_jmp -text "jump on click" -width 11 -command "iemgui_stdy_jmp $id" }
2200 if {[eval concat $$var_iemgui_steady] == 1} {
2201 button $id.para.stdy_jmp -text "steady on click" -width 11 -command "iemgui_stdy_jmp $id" }
2202 if {[eval concat $$var_iemgui_lin0_log1] >= 0} {
2203 pack $id.para.lilo -side left -expand 1}
2204 if {[eval concat $$var_iemgui_loadbang] >= 0} {
2205 pack $id.para.dummy2 $id.para.lb -side left -expand 1}
2206 if {[eval concat $$var_iemgui_num] > 0} {
2207 pack $id.para.dummy3 $id.para.num_lab $id.para.num_ent -side left -expand 1}
2208 if {[eval concat $$var_iemgui_steady] >= 0} {
2209 pack $id.para.dummy3 $id.para.stdy_jmp -side left -expand 1}
2210 if { $snd != "nosndno" || $rcv != "norcvno" } {
2211 label $id.space2 -text "---------------------------------"
2212 pack $id.space2 -side top }
2213
2214 frame $id.snd
2215 pack $id.snd -side top
2216 label $id.snd.dummy1 -text "" -width 2
2217 label $id.snd.lab -text "send-symbol:" -width 12
2218 entry $id.snd.ent -textvariable $var_iemgui_snd -width 20
2219 if { $snd != "nosndno" } {
2220 pack $id.snd.dummy1 $id.snd.lab $id.snd.ent -side left}
2221
2222 frame $id.rcv
2223 pack $id.rcv -side top
2224 label $id.rcv.lab -text "receive-symbol:" -width 15
2225 entry $id.rcv.ent -textvariable $var_iemgui_rcv -width 20
2226 if { $rcv != "norcvno" } {
2227 pack $id.rcv.lab $id.rcv.ent -side left}
2228
2229 frame $id.gnam
2230 pack $id.gnam -side top
2231 label $id.gnam.head -text "--------------label:---------------"
2232 label $id.gnam.dummy1 -text "" -width 1
2233 label $id.gnam.lab -text "name:" -width 6
2234 entry $id.gnam.ent -textvariable $var_iemgui_gui_nam -width 29
2235 label $id.gnam.dummy2 -text "" -width 1
2236 pack $id.gnam.head -side top
2237 pack $id.gnam.dummy1 $id.gnam.lab $id.gnam.ent $id.gnam.dummy2 -side left
2238
2239 frame $id.gnxy
2240 pack $id.gnxy -side top
2241 label $id.gnxy.x_lab -text "x_off:" -width 6
2242 entry $id.gnxy.x_ent -textvariable $var_iemgui_gn_dx -width 5
2243 label $id.gnxy.dummy1 -text " " -width 10
2244 label $id.gnxy.y_lab -text "y_off:" -width 6
2245 entry $id.gnxy.y_ent -textvariable $var_iemgui_gn_dy -width 5
2246 pack $id.gnxy.x_lab $id.gnxy.x_ent $id.gnxy.dummy1 \
2247 $id.gnxy.y_lab $id.gnxy.y_ent -side left
2248
2249 frame $id.gnfs
2250 pack $id.gnfs -side top
2251 label $id.gnfs.f_lab -text "font:" -width 6
2252 if {[eval concat $$var_iemgui_gn_f] == 0} {
2253 button $id.gnfs.fb -text "courier" -font {courier 10 bold} -width 7 -command "iemgui_toggle_font $id" }
2254 if {[eval concat $$var_iemgui_gn_f] == 1} {
2255 button $id.gnfs.fb -text "helvetica" -font {helvetica 10 bold} -width 7 -command "iemgui_toggle_font $id" }
2256 if {[eval concat $$var_iemgui_gn_f] == 2} {
2257 button $id.gnfs.fb -text "times" -font {times 10 bold} -width 7 -command "iemgui_toggle_font $id" }
2258 label $id.gnfs.dummy1 -text "" -width 1
2259 label $id.gnfs.fs_lab -text "fontsize:" -width 8
2260 entry $id.gnfs.fs_ent -textvariable $var_iemgui_gn_fs -width 5
2261 pack $id.gnfs.f_lab $id.gnfs.fb $id.gnfs.dummy1 \
2262 $id.gnfs.fs_lab $id.gnfs.fs_ent -side left
2263
2264 label $id.col_head -text "--------------colors:--------------"
2265 pack $id.col_head -side top
2266
2267 frame $id.col_select
2268 pack $id.col_select -side top
2269 radiobutton $id.col_select.radio0 -value 0 -variable $var_iemgui_l2_f1_b0 \
2270 -text "backgd" -width 5
2271 radiobutton $id.col_select.radio1 -value 1 -variable $var_iemgui_l2_f1_b0 \
2272 -text "front" -width 5
2273 radiobutton $id.col_select.radio2 -value 2 -variable $var_iemgui_l2_f1_b0 \
2274 -text "label" -width 5
2275 if { [eval concat $$var_iemgui_fcol] >= 0 } {
2276 pack $id.col_select.radio0 $id.col_select.radio1 $id.col_select.radio2 -side left
2277 } else {pack $id.col_select.radio0 $id.col_select.radio2 -side left}
2278
2279 frame $id.col_example_choose
2280 pack $id.col_example_choose -side top
2281 button $id.col_example_choose.but -text "compose color" -width 10 \
2282 -command "iemgui_choose_col_bkfrlb $id"
2283 label $id.col_example_choose.dummy1 -text "" -width 1
2284 if { [eval concat $$var_iemgui_fcol] >= 0 } {
2285 button $id.col_example_choose.fr_bk -text "o=||=o" -width 5 \
2286 -background [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
2287 -activebackground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
2288 -foreground [format "#%6.6x" [eval concat $$var_iemgui_fcol]] \
2289 -activeforeground [format "#%6.6x" [eval concat $$var_iemgui_fcol]] -pady 2
2290 } else {
2291 button $id.col_example_choose.fr_bk -text "o=||=o" -width 5 \
2292 -background [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
2293 -activebackground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
2294 -foreground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
2295 -activeforeground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] -pady 2}
2296 button $id.col_example_choose.lb_bk -text "testlabel" -width 7 \
2297 -background [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
2298 -activebackground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
2299 -foreground [format "#%6.6x" [eval concat $$var_iemgui_lcol]] \
2300 -activeforeground [format "#%6.6x" [eval concat $$var_iemgui_lcol]] -pady 2
2301
2302 pack $id.col_example_choose.but $id.col_example_choose.dummy1 \
2303 $id.col_example_choose.fr_bk $id.col_example_choose.lb_bk -side left
2304
2305 label $id.space3 -text "------or click color preset:-------"
2306 pack $id.space3 -side top
2307
2308 frame $id.bcol
2309 pack $id.bcol -side top
2310 foreach i { 0 1 2 3 4 5 6 7 8 9 } hexcol { 16579836 14737632 12369084 \
2311 16572640 16572608 16579784 14220504 14220540 14476540 16308476 } {
2312 button $id.bcol.c$i -background [format "#%6.6x" $hexcol] \
2313 -activebackground [format "#%6.6x" $hexcol] \
2314 -font {courier 2 normal} -padx 7 -pady 6 \
2315 -command [format "iemgui_preset_col %s %d" $id $hexcol] }
2316 pack $id.bcol.c0 $id.bcol.c1 $id.bcol.c2 $id.bcol.c3 $id.bcol.c4 \
2317 $id.bcol.c5 $id.bcol.c6 $id.bcol.c7 $id.bcol.c8 $id.bcol.c9 -side left
2318
2319 frame $id.fcol
2320 pack $id.fcol -side top
2321 foreach i { 0 1 2 3 4 5 6 7 8 9 } hexcol { 10526880 8158332 6316128 \
2322 16525352 16559172 15263784 1370132 2684148 3952892 16003312 } {
2323 button $id.fcol.c$i -background [format "#%6.6x" $hexcol] \
2324 -activebackground [format "#%6.6x" $hexcol] \
2325 -font {courier 2 normal} -padx 7 -pady 6 \
2326 -command [format "iemgui_preset_col %s %d" $id $hexcol] }
2327 pack $id.fcol.c0 $id.fcol.c1 $id.fcol.c2 $id.fcol.c3 $id.fcol.c4 \
2328 $id.fcol.c5 $id.fcol.c6 $id.fcol.c7 $id.fcol.c8 $id.fcol.c9 -side left
2329
2330 frame $id.lcol
2331 pack $id.lcol -side top
2332 foreach i { 0 1 2 3 4 5 6 7 8 9 } hexcol { 4210752 2105376 0 \
2333 9177096 5779456 7874580 2641940 17488 5256 5767248 } {
2334 button $id.lcol.c$i -background [format "#%6.6x" $hexcol] \
2335 -activebackground [format "#%6.6x" $hexcol] \
2336 -font {courier 2 normal} -padx 7 -pady 6 \
2337 -command [format "iemgui_preset_col %s %d" $id $hexcol] }
2338 pack $id.lcol.c0 $id.lcol.c1 $id.lcol.c2 $id.lcol.c3 $id.lcol.c4 \
2339 $id.lcol.c5 $id.lcol.c6 $id.lcol.c7 $id.lcol.c8 $id.lcol.c9 -side left
2340
2341
2342 label $id.space4 -text "---------------------------------"
2343 pack $id.space4 -side top
2344
2345 frame $id.cao
2346 pack $id.cao -side top
2347 button $id.cao.cancel -text {Cancel} -width 6 \
2348 -command "iemgui_cancel $id"
2349 label $id.cao.dummy1 -text "" -width 3
2350 button $id.cao.apply -text {Apply} -width 6 \
2351 -command "iemgui_apply $id"
2352 label $id.cao.dummy2 -text "" -width 3
2353 button $id.cao.ok -text {OK} -width 6 \
2354 -command "iemgui_ok $id"
2355 pack $id.cao.cancel $id.cao.dummy1 \
2356 $id.cao.apply $id.cao.dummy2 \
2357 $id.cao.ok -side left
2358
2359 label $id.space5 -text ""
2360 pack $id.space5 -side top
2361
2362 if {[info tclversion] < 8.4} {
2363 bind $id <Key-Tab> {tkTabToWindow [tk_focusNext %W]}
2364 bind $id <<PrevWindow>> {tkTabToWindow [tk_focusPrev %W]}
2365 } else {
2366 bind $id <Key-Tab> {tk::TabToWindow [tk_focusNext %W]}
2367 bind $id <<PrevWindow>> {tk::TabToWindow [tk_focusPrev %W]}
2368 }
2369
2370 bind $id.dim.w_ent <KeyPress-Return> [concat iemgui_ok $id]
2371 bind $id.dim.h_ent <KeyPress-Return> [concat iemgui_ok $id]
2372 bind $id.rng.min_ent <KeyPress-Return> [concat iemgui_ok $id]
2373 bind $id.rng.max_ent <KeyPress-Return> [concat iemgui_ok $id]
2374 bind $id.para.num_ent <KeyPress-Return> [concat iemgui_ok $id]
2375 bind $id.snd.ent <KeyPress-Return> [concat iemgui_ok $id]
2376 bind $id.rcv.ent <KeyPress-Return> [concat iemgui_ok $id]
2377 bind $id.gnam.ent <KeyPress-Return> [concat iemgui_ok $id]
2378 bind $id.gnxy.x_ent <KeyPress-Return> [concat iemgui_ok $id]
2379 bind $id.gnxy.y_ent <KeyPress-Return> [concat iemgui_ok $id]
2380 bind $id.gnfs.fs_ent <KeyPress-Return> [concat iemgui_ok $id]
2381 bind $id.cao.ok <KeyPress-Return> [concat iemgui_ok $id]
2382
2383 $id.dim.w_ent select from 0
2384 $id.dim.w_ent select adjust end
2385 focus $id.dim.w_ent
2386}
2387# end of change "iemlib"
2388
2389############ pdtk_array_dialog -- dialog window for arrays #########
2390proc array_apply {id} {
2391# strip "." from the TK id to make a variable name suffix
2392 set vid [string trimleft $id .]
2393# for each variable, make a local variable to hold its name...
2394 set var_array_name [concat array_name_$vid]
2395 global $var_array_name
2396 set var_array_n [concat array_n_$vid]
2397 global $var_array_n
2398 set var_array_saveit [concat array_saveit_$vid]
2399 global $var_array_saveit
2400 set var_array_otherflag [concat array_otherflag_$vid]
2401 global $var_array_otherflag
2402 set mofo [eval concat $$var_array_name]
2403 if {[string index $mofo 0] == "$"} {
2404 set mofo [string replace $mofo 0 0 #] }
2405
2406 pd [concat $id arraydialog $mofo \
2407 [eval concat $$var_array_n] \
2408 [eval concat $$var_array_saveit] \
2409 [eval concat $$var_array_otherflag] \
2410 \;]
2411}
2412
2413proc array_cancel {id} {
2414 set cmd [concat $id cancel \;]
2415 pd $cmd
2416}
2417
2418proc array_ok {id} {
2419 array_apply $id
2420 array_cancel $id
2421}
2422
2423proc pdtk_array_dialog {id name n saveit newone} {
2424 set vid [string trimleft $id .]
2425
2426 set var_array_name [concat array_name_$vid]
2427 global $var_array_name
2428 set var_array_n [concat array_n_$vid]
2429 global $var_array_n
2430 set var_array_saveit [concat array_saveit_$vid]
2431 global $var_array_saveit
2432 set var_array_otherflag [concat array_otherflag_$vid]
2433 global $var_array_otherflag
2434
2435 set $var_array_name $name
2436 set $var_array_n $n
2437 set $var_array_saveit $saveit
2438 set $var_array_otherflag 0
2439
2440 toplevel $id
2441 wm title $id {array}
2442 wm protocol $id WM_DELETE_WINDOW [concat array_cancel $id]
2443
2444 frame $id.name
2445 pack $id.name -side top
2446 label $id.name.label -text "name"
2447 entry $id.name.entry -textvariable $var_array_name
2448 pack $id.name.label $id.name.entry -side left
2449
2450 frame $id.n
2451 pack $id.n -side top
2452 label $id.n.label -text "size"
2453 entry $id.n.entry -textvariable $var_array_n
2454 pack $id.n.label $id.n.entry -side left
2455
2456 checkbutton $id.saveme -text {save contents} -variable $var_array_saveit \
2457 -anchor w
2458 pack $id.saveme -side top
2459
2460 if {$newone != 0} {
2461 frame $id.radio
2462 pack $id.radio -side top
2463 radiobutton $id.radio.radio0 -value 0 \
2464 -variable $var_array_otherflag \
2465 -text "in new graph"
2466 radiobutton $id.radio.radio1 -value 1 \
2467 -variable $var_array_otherflag \
2468 -text "in last graph"
2469 pack $id.radio.radio0 -side top -anchor w
2470 pack $id.radio.radio1 -side top -anchor w
2471 } else {
2472 checkbutton $id.deleteme -text {delete me} \
2473 -variable $var_array_otherflag -anchor w
2474 pack $id.deleteme -side top
2475 }
2476 frame $id.buttonframe
2477 pack $id.buttonframe -side bottom -fill x -pady 2m
2478 button $id.buttonframe.cancel -text {Cancel}\
2479 -command "array_cancel $id"
2480 if {$newone == 0} {button $id.buttonframe.apply -text {Apply}\
2481 -command "array_apply $id"}
2482 button $id.buttonframe.ok -text {OK}\
2483 -command "array_ok $id"
2484 pack $id.buttonframe.cancel -side left -expand 1
2485 if {$newone == 0} {pack $id.buttonframe.apply -side left -expand 1}
2486 pack $id.buttonframe.ok -side left -expand 1
2487
2488 bind $id.name.entry <KeyPress-Return> [concat array_ok $id]
2489 bind $id.n.entry <KeyPress-Return> [concat array_ok $id]
2490 $id.name.entry select from 0
2491 $id.name.entry select adjust end
2492 focus $id.name.entry
2493}
2494
2495############ pdtk_canvas_dialog -- dialog window for canvass #########
2496proc canvas_apply {id} {
2497# strip "." from the TK id to make a variable name suffix
2498 set vid [string trimleft $id .]
2499# for each variable, make a local variable to hold its name...
2500 set var_canvas_xscale [concat canvas_xscale_$vid]
2501 global $var_canvas_xscale
2502 set var_canvas_yscale [concat canvas_yscale_$vid]
2503 global $var_canvas_yscale
2504 set var_canvas_graphme [concat canvas_graphme_$vid]
2505 global $var_canvas_graphme
2506# set var_canvas_stretch [concat canvas_stretch_$vid]
2507# global $var_canvas_stretch
2508 pd [concat $id donecanvasdialog \
2509 [eval concat $$var_canvas_xscale] \
2510 [eval concat $$var_canvas_yscale] \
2511 [eval concat $$var_canvas_graphme] \
2512 \;]
2513}
2514
2515proc canvas_cancel {id} {
2516 set cmd [concat $id cancel \;]
2517 pd $cmd
2518}
2519
2520proc canvas_ok {id} {
2521 canvas_apply $id
2522 canvas_cancel $id
2523}
2524
2525proc pdtk_canvas_dialog {id xscale yscale graphme stretch} {
2526 set vid [string trimleft $id .]
2527
2528 set var_canvas_xscale [concat canvas_xscale_$vid]
2529 global $var_canvas_xscale
2530 set var_canvas_yscale [concat canvas_yscale_$vid]
2531 global $var_canvas_yscale
2532 set var_canvas_graphme [concat canvas_graphme_$vid]
2533 global $var_canvas_graphme
2534# set var_canvas_stretch [concat canvas_stretch_$vid]
2535# global $var_canvas_stretch
2536
2537 set $var_canvas_xscale $xscale
2538 set $var_canvas_yscale $yscale
2539 set $var_canvas_graphme $graphme
2540# set $var_canvas_stretch $stretch
2541
2542 toplevel $id
2543 wm title $id {canvas}
2544 wm protocol $id WM_DELETE_WINDOW [concat canvas_cancel $id]
2545
2546 frame $id.xscale
2547 pack $id.xscale -side top
2548 label $id.xscale.label -text "X units per pixel"
2549 entry $id.xscale.entry -textvariable $var_canvas_xscale -width 10
2550 pack $id.xscale.label $id.xscale.entry -side left
2551
2552 frame $id.yscale
2553 pack $id.yscale -side top
2554 label $id.yscale.label -text "Y units per pixel"
2555 entry $id.yscale.entry -textvariable $var_canvas_yscale -width 10
2556 pack $id.yscale.label $id.yscale.entry -side left
2557
2558 checkbutton $id.graphme -text {graph on parent} \
2559 -variable $var_canvas_graphme -anchor w
2560 pack $id.graphme -side top
2561
2562# checkbutton $id.stretch -text {stretch on resize} \
2563# -variable $var_canvas_stretch -anchor w
2564# pack $id.stretch -side top
2565
2566
2567 frame $id.buttonframe
2568 pack $id.buttonframe -side bottom -fill x -pady 2m
2569 button $id.buttonframe.cancel -text {Cancel}\
2570 -command "canvas_cancel $id"
2571 button $id.buttonframe.apply -text {Apply}\
2572 -command "canvas_apply $id"
2573 button $id.buttonframe.ok -text {OK}\
2574 -command "canvas_ok $id"
2575 pack $id.buttonframe.cancel -side left -expand 1
2576 pack $id.buttonframe.apply -side left -expand 1
2577 pack $id.buttonframe.ok -side left -expand 1
2578
2579 bind $id.xscale.entry <KeyPress-Return> [concat canvas_ok $id]
2580 bind $id.yscale.entry <KeyPress-Return> [concat canvas_ok $id]
2581 $id.xscale.entry select from 0
2582 $id.xscale.entry select adjust end
2583 focus $id.xscale.entry
2584}
2585
2586############ pdtk_data_dialog -- run a data dialog #########
2587proc dodata_send {name} {
2588# puts stderr [$name.text get 0.0 end]
2589
2590 for {set i 1} {[$name.text compare [concat $i.0 + 3 chars] < end]} \
2591 {incr i 1} {
2592# puts stderr [concat it's [$name.text get $i.0 [expr $i + 1].0]]
2593 set cmd [concat $name data [$name.text get $i.0 [expr $i + 1].0] \;]
2594# puts stderr $cmd
2595 pd $cmd
2596 }
2597 set cmd [concat $name end \;]
2598# puts stderr $cmd
2599 pd $cmd
2600}
2601
2602proc dodata_cancel {name} {
2603 set cmd [concat $name cancel \;]
2604# puts stderr $cmd
2605 pd $cmd
2606}
2607
2608proc dodata_ok {name} {
2609 dodata_send $name
2610 dodata_cancel $name
2611}
2612
2613proc pdtk_data_dialog {name stuff} {
2614
2615 toplevel $name
2616 wm title $name {Atom}
2617 wm protocol $name WM_DELETE_WINDOW [concat dodata_cancel $name]
2618
2619 frame $name.buttonframe
2620 pack $name.buttonframe -side bottom -fill x -pady 2m
2621 button $name.buttonframe.send -text {Send (Ctrl s)}\
2622 -command [concat dodata_send $name]
2623 button $name.buttonframe.ok -text {OK (Ctrl t)}\
2624 -command [concat dodata_ok $name]
2625 pack $name.buttonframe.send -side left -expand 1
2626 pack $name.buttonframe.ok -side left -expand 1
2627
2628 text $name.text -relief raised -bd 2 -height 40 -width 60 \
2629 -yscrollcommand "$name.scroll set" -font -*-courier-bold--normal--12-*
2630 scrollbar $name.scroll -command "$name.text yview"
2631 pack $name.scroll -side right -fill y
2632 pack $name.text -side left -fill both -expand 1
2633 $name.text insert end $stuff
2634 focus $name.text
2635 bind $name.text <Control-t> [concat dodata_ok $name]
2636 bind $name.text <Control-s> [concat dodata_send $name]
2637}
2638
2639############ check or uncheck the "edit" menu item ##############
2640#####################iemlib#######################
2641proc pdtk_canvas_editval {name value} {
2642 if { $value } {
2643 $name.m.edit entryconfigure "Edit mode" -indicatoron true
2644 } else {
2645 $name.m.edit entryconfigure "Edit mode" -indicatoron false
2646 }
2647}
2648#####################iemlib#######################
2649
2650############ pdtk_text_new -- create a new text object #2###########
2651proc pdtk_text_new {canvasname myname x y text font color} {
2652# if {$font < 13} {set fontname [format -*-courier-bold----%d-* $font]}
2653# if {$font >= 13} {set fontname [format -*-courier-----%d-* $font]}
2654 $canvasname create text $x $y \
2655 -font [format -*-courier-bold--normal--%d-* $font] \
2656 -tags $myname -text $text -fill $color -anchor nw
2657# pd [concat $myname size [$canvasname bbox $myname] \;]
2658}
2659
2660################ pdtk_text_set -- change the text ##################
2661proc pdtk_text_set {canvasname myname text} {
2662 $canvasname itemconfig $myname -text $text
2663# pd [concat $myname size [$canvasname bbox $myname] \;]
2664}
2665
2666############### event binding procedures for Pd window ################
2667
2668proc pdtk_pd_ctrlkey {name key shift} {
2669# puts stderr [concat key $key shift $shift]
2670# .dummy itemconfig goo -text [concat ---> control-key event $key];
2671 if {$key == "n" || $key == "N"} {menu_new}
2672 if {$key == "o" || $key == "O"} {menu_open}
2673 if {$key == "m" || $key == "M"} {menu_send}
2674 if {$key == "q" || $key == "Q"} {
2675 if {$shift == 1} {menu_really_quit} else {menu_quit}
2676 }
2677 if {$key == "slash"} {menu_audio 1}
2678 if {$key == "period"} {menu_audio 0}
2679}
2680
2681######### startup function. ##############
2682# Tell pd the current directory; this is used in case the command line
2683# asked pd to open something. Also, get character width and height for
2684# font sizes 8, 10, 12, 14, 16, and 24.
2685
2686proc pdtk_pd_startup {version apilist} {
2687 global pd_myversion pd_apilist
2688 set pd_myversion $version
2689 set pd_apilist $apilist
2690
2691 set width1 [font measure -*-courier-bold--normal--8-* x]
2692 set height1 [lindex [font metrics -*-courier-bold--normal--8-*] 5]
2693
2694 set width2 [font measure -*-courier-bold--normal--10-* x]
2695 set height2 [lindex [font metrics -*-courier-bold--normal--10-*] 5]
2696
2697 set width3 [font measure -*-courier-bold--normal--12-* x]
2698 set height3 [lindex [font metrics -*-courier-bold--normal--12-*] 5]
2699
2700 set width4 [font measure -*-courier-bold--normal--14-* x]
2701 set height4 [lindex [font metrics -*-courier-bold--normal--14-*] 5]
2702
2703 set width5 [font measure -*-courier-bold--normal--16-* x]
2704 set height5 [lindex [font metrics -*-courier-bold--normal--16-*] 5]
2705
2706 set width6 [font measure -*-courier-bold--normal--24-* x]
2707 set height6 [lindex [font metrics -*-courier-bold--normal--24-*] 5]
2708
2709 set width7 [font measure -*-courier-bold--normal--36-* x]
2710 set height7 [lindex [font metrics -*-courier-bold--normal--36-*] 5]
2711
2712 set tclpatch [info patchlevel]
2713 if {$tclpatch == "8.3.0" || \
2714 $tclpatch == "8.3.1" || \
2715 $tclpatch == "8.3.2" || \
2716 $tclpatch == "8.3.3" } {
2717 set oldtclversion 1
2718 } else {
2719 set oldtclversion 0
2720 }
2721 pd [concat pd init [pdtk_enquote [pwd]] \
2722 8 $width1 $height1 \
2723 10 $width2 $height2 \
2724 12 $width3 $height3 \
2725 14 $width4 $height4 \
2726 16 $width5 $height5 \
2727 24 $width6 $height6 \
2728 36 $width7 $height7 \
2729 $oldtclversion \;];
2730
2731 # add the audio and help menus to the Pd window. We delayed this
2732 # so that we'd know the value of "apilist".
2733 menu_addstd .mbar
2734
2735}
2736
2737##################### DSP ON/OFF, METERS, DIO ERROR ###################
2738proc pdtk_pd_dsp {value} {
2739 global ctrls_audio_on
2740 if {$value == "ON"} {set ctrls_audio_on 1} else {set ctrls_audio_on 0}
2741# puts stderr [concat its $ctrls_audio_on]
2742}
2743
2744proc pdtk_pd_meters {indb outdb inclip outclip} {
2745# puts stderr [concat meters $indb $outdb $inclip $outclip]
2746 global ctrls_inlevel ctrls_outlevel
2747 set ctrls_inlevel $indb
2748 if {$inclip == 1} {
2749 .controls.inout.in.clip configure -background red
2750 } else {
2751 .controls.inout.in.clip configure -background grey
2752 }
2753 set ctrls_outlevel $outdb
2754 if {$outclip == 1} {
2755 .controls.inout.out.clip configure -background red
2756 } else {
2757 .controls.inout.out.clip configure -background grey
2758 }
2759
2760}
2761
2762proc pdtk_pd_dio {red} {
2763# puts stderr [concat dio $red]
2764 if {$red == 1} {
2765 .controls.dio configure -background red -activebackground red
2766 } else {
2767 .controls.dio configure -background grey -activebackground lightgrey
2768 }
2769
2770}
2771
2772############# text editing from the "edit" menu ###################
2773set edit_number 1
2774
2775proc texteditor_send {name} {
2776 set topname [string trimright $name .text]
2777 for {set i 0} \
2778 {[$name compare [concat 0.0 + [expr $i + 1] chars] < end]} \
2779 {incr i 1} {
2780 set cha [$name get [concat 0.0 + $i chars]]
2781 scan $cha %c keynum
2782 pd [concat pd key 1 $keynum 0 \;]
2783 }
2784}
2785
2786proc texteditor_ok {name} {
2787 set topname [string trimright $name .text]
2788 texteditor_send $name
2789 destroy $topname
2790}
2791
2792
2793proc pdtk_pd_texteditor {stuff} {
2794 global edit_number
2795 set name [format ".text%d" $edit_number]
2796 set edit_number [expr $edit_number + 1]
2797
2798 toplevel $name
2799 wm title $name {TEXT}
2800
2801 frame $name.buttons
2802 pack $name.buttons -side bottom -fill x -pady 2m
2803 button $name.buttons.send -text {Send (Ctrl s)}\
2804 -command "texteditor_send $name.text"
2805 button $name.buttons.ok -text {OK (Ctrl t)}\
2806 -command "texteditor_ok $name.text"
2807 pack $name.buttons.send -side left -expand 1
2808 pack $name.buttons.ok -side left -expand 1
2809
2810 text $name.text -relief raised -bd 2 -height 12 -width 60 \
2811 -yscrollcommand "$name.scroll set" -font -*-courier-bold--normal--12-*
2812 scrollbar $name.scroll -command "$name.text yview"
2813 pack $name.scroll -side right -fill y
2814 pack $name.text -side left -fill both -expand 1
2815 $name.text insert end $stuff
2816 focus $name.text
2817 bind $name.text <Control-t> {texteditor_ok %W}
2818 bind $name.text <Control-s> {texteditor_send %W}
2819}
2820
2821############# open and save dialogs for objects in Pd ##########
2822
2823proc pdtk_openpanel {target} {
2824 global pd_opendir
2825 set filename [tk_getOpenFile \
2826 -initialdir $pd_opendir]
2827 if {$filename != ""} {
2828 set directory [string range $filename 0 \
2829 [expr [string last / $filename ] - 1]]
2830 set pd_opendir $directory
2831
2832 pd [concat $target symbol [pdtk_enquote $filename] \;]
2833 }
2834}
2835
2836proc pdtk_savepanel {target} {
2837 set filename [tk_getSaveFile]
2838 if {$filename != ""} {
2839 pd [concat $target symbol [pdtk_enquote $filename] \;]
2840 }
2841}
2842
2843########################### comport hack ########################
2844
2845set com1 0
2846set com2 0
2847set com3 0
2848set com4 0
2849
2850proc com1_open {} {
2851 global com1
2852 set com1 [open com1 w]
2853 .dummy itemconfig goo -text $com1
2854 fconfigure $com1 -buffering none
2855 fconfigure $com1 -mode 19200,e,8,2
2856}
2857
2858proc com1_send {str} {
2859 global com1
2860 puts -nonewline $com1 $str
2861}
2862
2863
2864############# start a polling process to watch the socket ##############
2865# this is needed for nt, and presumably for Mac as well.
2866# in UNIX this is handled by a tcl callback (set up in t_tkcmd.c)
2867
2868if {$pd_nt == 1} {
2869 proc polleofloop {} {
2870 pd_pollsocket
2871 after 20 polleofloop
2872 }
2873
2874 polleofloop
2875}
2876
2877####################### audio dialog ##################3
2878
2879proc audio_apply {id} {
2880 global audio_indev1 audio_indev2 audio_indev3 audio_indev4
2881 global audio_inchan1 audio_inchan2 audio_inchan3 audio_inchan4
2882 global audio_outdev1 audio_outdev2 audio_outdev3 audio_outdev4
2883 global audio_outchan1 audio_outchan2 audio_outchan3 audio_outchan4
2884 global audio_sr audio_advance
2885
2886 pd [concat pd audio-dialog \
2887 $audio_indev1 \
2888 $audio_indev2 \
2889 $audio_indev3 \
2890 $audio_indev4 \
2891 $audio_inchan1 \
2892 $audio_inchan2 \
2893 $audio_inchan3 \
2894 $audio_inchan4 \
2895 $audio_outdev1 \
2896 $audio_outdev2 \
2897 $audio_outdev3 \
2898 $audio_outdev4 \
2899 $audio_outchan1 \
2900 $audio_outchan2 \
2901 $audio_outchan3 \
2902 $audio_outchan4 \
2903 $audio_sr \
2904 $audio_advance \
2905 \;]
2906}
2907
2908proc audio_cancel {id} {
2909 pd [concat $id cancel \;]
2910}
2911
2912proc audio_ok {id} {
2913 audio_apply $id
2914 audio_cancel $id
2915}
2916
2917# callback from popup menu
2918proc audio_popup_action {buttonname varname devlist index} {
2919 global audio_indevlist audio_outdevlist $varname
2920 $buttonname configure -text [lindex $devlist $index]
2921# puts stderr [concat popup_action $buttonname $varname $index]
2922 set $varname $index
2923}
2924
2925# create a popup menu
2926proc audio_popup {name buttonname varname devlist} {
2927 if [winfo exists $name.popup] {destroy $name.popup}
2928 menu $name.popup -tearoff false
2929# puts stderr [concat $devlist ]
2930 for {set x 0} {$x<[llength $devlist]} {incr x} {
2931 $name.popup add command -label [lindex $devlist $x] \
2932 -command [list audio_popup_action \
2933 $buttonname $varname $devlist $x]
2934 }
2935 tk_popup $name.popup [winfo pointerx $name] [winfo pointery $name] 0
2936}
2937
2938# start a dialog window to select audio devices and settings. "multi"
2939# is 0 if only one device is allowed; 1 if one apiece may be specified for
2940# input and output; and 2 if we can select multiple devices. "longform"
2941# (which only makes sense if "multi" is 2) asks us to make controls for
2942# opening several devices; if not, we get an extra button to turn longform
2943# on and restart the dialog.
2944
2945proc pdtk_audio_dialog {id indevlist indev1 indev2 indev3 indev4 \
2946 inchan1 inchan2 inchan3 inchan4 \
2947 outdevlist outdev1 outdev2 outdev3 outdev4 \
2948 outchan1 outchan2 outchan3 outchan4 sr advance multi longform} {
2949 global audio_indev1 audio_indev2 audio_indev3 audio_indev4
2950 global audio_inchan1 audio_inchan2 audio_inchan3 audio_inchan4
2951 global audio_outdev1 audio_outdev2 audio_outdev3 audio_outdev4
2952 global audio_outchan1 audio_outchan2 audio_outchan3 audio_outchan4
2953 global audio_sr audio_advance
2954 global audio_indevlist audio_outdevlist
2955
2956 set audio_indev1 $indev1
2957 set audio_indev2 $indev2
2958 set audio_indev3 $indev3
2959 set audio_indev4 $indev4
2960 set audio_inchan1 $inchan1
2961 set audio_inchan2 $inchan2
2962 set audio_inchan3 $inchan3
2963 set audio_inchan4 $inchan4
2964 set audio_outdev1 $outdev1
2965 set audio_outdev2 $outdev2
2966 set audio_outdev3 $outdev3
2967 set audio_outdev4 $outdev4
2968 set audio_outchan1 $outchan1
2969 set audio_outchan2 $outchan2
2970 set audio_outchan3 $outchan3
2971 set audio_outchan4 $outchan4
2972 set audio_sr $sr
2973 set audio_advance $advance
2974 set audio_indevlist $indevlist
2975 set audio_outdevlist $outdevlist
2976
2977 toplevel $id
2978 wm title $id {audio}
2979 wm protocol $id WM_DELETE_WINDOW [concat audio_cancel $id]
2980
2981 frame $id.buttonframe
2982 pack $id.buttonframe -side bottom -fill x -pady 2m
2983 button $id.buttonframe.cancel -text {Cancel}\
2984 -command "audio_cancel $id"
2985 button $id.buttonframe.apply -text {Apply}\
2986 -command "audio_apply $id"
2987 button $id.buttonframe.ok -text {OK}\
2988 -command "audio_ok $id"
2989 pack $id.buttonframe.cancel -side left -expand 1
2990 pack $id.buttonframe.apply -side left -expand 1
2991 pack $id.buttonframe.ok -side left -expand 1
2992
2993 # sample rate and advance
2994 frame $id.srf
2995 pack $id.srf -side top
2996
2997 label $id.srf.l1 -text "sample rate:"
2998 entry $id.srf.x1 -textvariable audio_sr -width 7
2999 label $id.srf.l2 -text "delay (msec):"
3000 entry $id.srf.x2 -textvariable audio_advance -width 4
3001 pack $id.srf.l1 $id.srf.x1 $id.srf.l2 $id.srf.x2 -side left
3002
3003 # input device 1
3004 frame $id.in1f
3005 pack $id.in1f -side top
3006
3007 label $id.in1f.l1 -text "input device 1:"
3008 button $id.in1f.x1 -text [lindex $indevlist $audio_indev1] \
3009 -command [list audio_popup $id $id.in1f.x1 audio_indev1 $indevlist]
3010 label $id.in1f.l2 -text "channels:"
3011 entry $id.in1f.x2 -textvariable audio_inchan1 -width 3
3012 pack $id.in1f.l1 $id.in1f.x1 $id.in1f.l2 $id.in1f.x2 -side left
3013
3014 # input device 2
3015 if {$longform && $multi > 1 && [llength $indevlist] > 1} {
3016 frame $id.in2f
3017 pack $id.in2f -side top
3018
3019 label $id.in2f.l1 -text "input device 2:"
3020 button $id.in2f.x1 -text [lindex $indevlist $audio_indev2] \
3021 -command [list audio_popup $id $id.in2f.x1 audio_indev2 $indevlist]
3022 label $id.in2f.l2 -text "channels:"
3023 entry $id.in2f.x2 -textvariable audio_inchan2 -width 3
3024 pack $id.in2f.l1 $id.in2f.x1 $id.in2f.l2 $id.in2f.x2 -side left
3025 }
3026
3027 # input device 3
3028 if {$longform && $multi > 1 && [llength $indevlist] > 2} {
3029 frame $id.in3f
3030 pack $id.in3f -side top
3031
3032 label $id.in3f.l1 -text "input device 3:"
3033 button $id.in3f.x1 -text [lindex $indevlist $audio_indev3] \
3034 -command [list audio_popup $id $id.in3f.x1 audio_indev3 $indevlist]
3035 label $id.in3f.l2 -text "channels:"
3036 entry $id.in3f.x2 -textvariable audio_inchan3 -width 3
3037 pack $id.in3f.l1 $id.in3f.x1 $id.in3f.l2 $id.in3f.x2 -side left
3038 }
3039
3040 # input device 4
3041 if {$longform && $multi > 1 && [llength $indevlist] > 3} {
3042 frame $id.in4f
3043 pack $id.in4f -side top
3044
3045 label $id.in4f.l1 -text "input device 4:"
3046 button $id.in4f.x1 -text [lindex $indevlist $audio_indev4] \
3047 -command [list audio_popup $id $id.in4f.x1 audio_indev4 $indevlist]
3048 label $id.in4f.l2 -text "channels:"
3049 entry $id.in4f.x2 -textvariable audio_inchan4 -width 3
3050 pack $id.in4f.l1 $id.in4f.x1 $id.in4f.l2 $id.in4f.x2 -side left
3051 }
3052
3053 # output device 1
3054 frame $id.out1f
3055 pack $id.out1f -side top
3056
3057 if {$multi == 0} {
3058 label $id.out1f.l1 \
3059 -text "(output device same as input device) .............. "
3060 } else {
3061 label $id.out1f.l1 -text "output device 1:"
3062 button $id.out1f.x1 -text [lindex $outdevlist $audio_outdev1] \
3063 -command \
3064 [list audio_popup $id $id.out1f.x1 audio_outdev1 $outdevlist]
3065 }
3066 label $id.out1f.l2 -text "channels:"
3067 entry $id.out1f.x2 -textvariable audio_outchan1 -width 3
3068 if {$multi == 0} {
3069 pack $id.out1f.l1 $id.out1f.l2 $id.out1f.x2 -side left
3070 } else {
3071 pack $id.out1f.l1 $id.out1f.x1 $id.out1f.l2 $id.out1f.x2 -side left
3072 }
3073
3074 # output device 2
3075 if {$longform && $multi > 1 && [llength $indevlist] > 1} {
3076 frame $id.out2f
3077 pack $id.out2f -side top
3078 label $id.out2f.l1 -text "output device 2:"
3079 button $id.out2f.x1 -text [lindex $outdevlist $audio_outdev2] \
3080 -command \
3081 [list audio_popup $id $id.out2f.x1 audio_outdev2 $outdevlist]
3082 label $id.out2f.l2 -text "channels:"
3083 entry $id.out2f.x2 -textvariable audio_outchan2 -width 3
3084 pack $id.out2f.l1 $id.out2f.x1 $id.out2f.l2 $id.out2f.x2 -side left
3085 }
3086
3087 # output device 3
3088 if {$longform && $multi > 1 && [llength $indevlist] > 2} {
3089 frame $id.out3f
3090 pack $id.out3f -side top
3091 label $id.out3f.l1 -text "output device 3:"
3092 button $id.out3f.x1 -text [lindex $outdevlist $audio_outdev3] \
3093 -command \
3094 [list audio_popup $id $id.out3f.x1 audio_outdev3 $outdevlist]
3095 label $id.out3f.l2 -text "channels:"
3096 entry $id.out3f.x2 -textvariable audio_outchan3 -width 3
3097 pack $id.out3f.l1 $id.out3f.x1 $id.out3f.l2 $id.out3f.x2 -side left
3098 }
3099
3100 # output device 4
3101 if {$longform && $multi > 1 && [llength $indevlist] > 3} {
3102 frame $id.out4f
3103 pack $id.out4f -side top
3104 label $id.out4f.l1 -text "output device 4:"
3105 button $id.out4f.x1 -text [lindex $outdevlist $audio_outdev4] \
3106 -command \
3107 [list audio_popup $id $id.out4f.x1 audio_outdev4 $outdevlist]
3108 label $id.out4f.l2 -text "channels:"
3109 entry $id.out4f.x2 -textvariable audio_outchan4 -width 3
3110 pack $id.out4f.l1 $id.out4f.x1 $id.out4f.l2 $id.out4f.x2 -side left
3111 }
3112
3113 # if not the "long form" but if "multi" is 2, make a button to
3114 # restart with longform set.
3115
3116 if {$longform == 0 && $multi > 1} {
3117 frame $id.longbutton
3118 pack $id.longbutton -side top
3119 button $id.longbutton.b -text {use multiple devices} \
3120 -command {pd pd audio-properties 1 \;}
3121 pack $id.longbutton.b
3122 }
3123 bind $id.srf.x1 <KeyPress-Return> [concat audio_ok $id]
3124 bind $id.srf.x2 <KeyPress-Return> [concat audio_ok $id]
3125 bind $id.in1f.x2 <KeyPress-Return> [concat audio_ok $id]
3126 $id.srf.x1 select from 0
3127 $id.srf.x1 select adjust end
3128 focus $id.srf.x1
3129}
3130
3131####################### midi dialog ##################3
3132
3133proc midi_apply {id} {
3134 global midi_indev1 midi_indev2 midi_indev3 midi_indev4
3135 global midi_outdev1 midi_outdev2 midi_outdev3 midi_outdev4
3136
3137 pd [concat pd midi-dialog \
3138 $midi_indev1 \
3139 $midi_indev2 \
3140 $midi_indev3 \
3141 $midi_indev4 \
3142 $midi_outdev1 \
3143 $midi_outdev2 \
3144 $midi_outdev3 \
3145 $midi_outdev4 \
3146 \;]
3147}
3148
3149proc midi_cancel {id} {
3150 pd [concat $id cancel \;]
3151}
3152
3153proc midi_ok {id} {
3154 midi_apply $id
3155 midi_cancel $id
3156}
3157
3158# callback from popup menu
3159proc midi_popup_action {buttonname varname devlist index} {
3160 global midi_indevlist midi_outdevlist $varname
3161 $buttonname configure -text [lindex $devlist $index]
3162# puts stderr [concat popup_action $buttonname $varname $index]
3163 set $varname $index
3164}
3165
3166# create a popup menu
3167proc midi_popup {name buttonname varname devlist} {
3168 if [winfo exists $name.popup] {destroy $name.popup}
3169 menu $name.popup -tearoff false
3170# puts stderr [concat $devlist ]
3171 for {set x 0} {$x<[llength $devlist]} {incr x} {
3172 $name.popup add command -label [lindex $devlist $x] \
3173 -command [list midi_popup_action \
3174 $buttonname $varname $devlist $x]
3175 }
3176 tk_popup $name.popup [winfo pointerx $name] [winfo pointery $name] 0
3177}
3178
3179# start a dialog window to select midi devices. "longform" asks us to make
3180# controls for opening several devices; if not, we get an extra button to
3181# turn longform on and restart the dialog.
3182
3183proc pdtk_midi_dialog {id indevlist indev1 indev2 indev3 indev4 \
3184 outdevlist outdev1 outdev2 outdev3 outdev4 longform} {
3185 global midi_indev1 midi_indev2 midi_indev3 midi_indev4
3186 global midi_outdev1 midi_outdev2 midi_outdev3 midi_outdev4
3187 global midi_indevlist midi_outdevlist
3188
3189 set midi_indev1 $indev1
3190 set midi_indev2 $indev2
3191 set midi_indev3 $indev3
3192 set midi_indev4 $indev4
3193 set midi_outdev1 $outdev1
3194 set midi_outdev2 $outdev2
3195 set midi_outdev3 $outdev3
3196 set midi_outdev4 $outdev4
3197 set midi_indevlist $indevlist
3198 set midi_outdevlist $outdevlist
3199
3200 toplevel $id
3201 wm title $id {midi}
3202 wm protocol $id WM_DELETE_WINDOW [concat midi_cancel $id]
3203
3204 frame $id.buttonframe
3205 pack $id.buttonframe -side bottom -fill x -pady 2m
3206 button $id.buttonframe.cancel -text {Cancel}\
3207 -command "midi_cancel $id"
3208 button $id.buttonframe.apply -text {Apply}\
3209 -command "midi_apply $id"
3210 button $id.buttonframe.ok -text {OK}\
3211 -command "midi_ok $id"
3212 pack $id.buttonframe.cancel -side left -expand 1
3213 pack $id.buttonframe.apply -side left -expand 1
3214 pack $id.buttonframe.ok -side left -expand 1
3215
3216 # input device 1
3217 frame $id.in1f
3218 pack $id.in1f -side top
3219
3220 label $id.in1f.l1 -text "input device 1:"
3221 button $id.in1f.x1 -text [lindex $indevlist $midi_indev1] \
3222 -command [list midi_popup $id $id.in1f.x1 midi_indev1 $indevlist]
3223 pack $id.in1f.l1 $id.in1f.x1 -side left
3224
3225 # input device 2
3226 if {$longform && [llength $indevlist] > 2} {
3227 frame $id.in2f
3228 pack $id.in2f -side top
3229
3230 label $id.in2f.l1 -text "input device 2:"
3231 button $id.in2f.x1 -text [lindex $indevlist $midi_indev2] \
3232 -command [list midi_popup $id $id.in2f.x1 midi_indev2 $indevlist]
3233 pack $id.in2f.l1 $id.in2f.x1 -side left
3234 }
3235
3236 # input device 3
3237 if {$longform && [llength $indevlist] > 3} {
3238 frame $id.in3f
3239 pack $id.in3f -side top
3240
3241 label $id.in3f.l1 -text "input device 3:"
3242 button $id.in3f.x1 -text [lindex $indevlist $midi_indev3] \
3243 -command [list midi_popup $id $id.in3f.x1 midi_indev3 $indevlist]
3244 pack $id.in3f.l1 $id.in3f.x1 -side left
3245 }
3246
3247 # input device 4
3248 if {$longform && [llength $indevlist] > 4} {
3249 frame $id.in4f
3250 pack $id.in4f -side top
3251
3252 label $id.in4f.l1 -text "input device 4:"
3253 button $id.in4f.x1 -text [lindex $indevlist $midi_indev4] \
3254 -command [list midi_popup $id $id.in4f.x1 midi_indev4 $indevlist]
3255 pack $id.in4f.l1 $id.in4f.x1 -side left
3256 }
3257
3258 # output device 1
3259
3260 frame $id.out1f
3261 pack $id.out1f -side top
3262 label $id.out1f.l1 -text "output device 1:"
3263 button $id.out1f.x1 -text [lindex $outdevlist $midi_outdev1] \
3264 -command [list midi_popup $id $id.out1f.x1 midi_outdev1 $outdevlist]
3265 pack $id.out1f.l1 $id.out1f.x1 -side left
3266
3267 # output device 2
3268 if {$longform && [llength $indevlist] > 2} {
3269 frame $id.out2f
3270 pack $id.out2f -side top
3271 label $id.out2f.l1 -text "output device 2:"
3272 button $id.out2f.x1 -text [lindex $outdevlist $midi_outdev2] \
3273 -command \
3274 [list midi_popup $id $id.out2f.x1 midi_outdev2 $outdevlist]
3275 pack $id.out2f.l1 $id.out2f.x1 -side left
3276 }
3277
3278 # output device 3
3279 if {$longform && [llength $indevlist] > 3} {
3280 frame $id.out3f
3281 pack $id.out3f -side top
3282 label $id.out3f.l1 -text "output device 3:"
3283 button $id.out3f.x1 -text [lindex $outdevlist $midi_outdev3] \
3284 -command \
3285 [list midi_popup $id $id.out3f.x1 midi_outdev3 $outdevlist]
3286 pack $id.out3f.l1 $id.out3f.x1 -side left
3287 }
3288
3289 # output device 4
3290 if {$longform && [llength $indevlist] > 4} {
3291 frame $id.out4f
3292 pack $id.out4f -side top
3293 label $id.out4f.l1 -text "output device 4:"
3294 button $id.out4f.x1 -text [lindex $outdevlist $midi_outdev4] \
3295 -command \
3296 [list midi_popup $id $id.out4f.x1 midi_outdev4 $outdevlist]
3297 pack $id.out4f.l1 $id.out4f.x1 -side left
3298 }
3299
3300 # if not the "long form" make a button to
3301 # restart with longform set.
3302
3303 if {$longform == 0} {
3304 frame $id.longbutton
3305 pack $id.longbutton -side top
3306 button $id.longbutton.b -text {use multiple devices} \
3307 -command {pd pd midi-properties 1 \;}
3308 pack $id.longbutton.b
3309 }
3310}
3311
3312############ pdtk_path_dialog -- dialog window for search path #########
3313
3314proc path_apply {id} {
3315 global pd_path0 pd_path1 pd_path2 pd_path3 pd_path4
3316 global pd_path5 pd_path6 pd_path7 pd_path8 pd_path9
3317
3318 pd [concat pd path-dialog \
3319 $pd_path0 $pd_path1 $pd_path2 $pd_path3 $pd_path4 \
3320 $pd_path5 $pd_path6 $pd_path7 $pd_path8 $pd_path9 \
3321 \;]
3322}
3323
3324proc path_cancel {id} {
3325 pd [concat $id cancel \;]
3326}
3327
3328proc path_ok {id} {
3329 path_apply $id
3330 path_cancel $id
3331}
3332set pd_path0 sdfgh
3333
3334proc pdtk_path_dialog {id} {
3335 global pd_path0 pd_path1 pd_path2 pd_path3 pd_path4
3336 global pd_path5 pd_path6 pd_path7 pd_path8 pd_path9
3337
3338 toplevel $id
3339 wm title $id {PD search path for patches and other files}
3340 wm protocol $id WM_DELETE_WINDOW [concat path_cancel $id]
3341
3342 frame $id.buttonframe
3343 pack $id.buttonframe -side bottom -fill x -pady 2m
3344 button $id.buttonframe.cancel -text {Cancel}\
3345 -command "path_cancel $id"
3346 button $id.buttonframe.apply -text {Apply}\
3347 -command "path_apply $id"
3348 button $id.buttonframe.ok -text {OK}\
3349 -command "path_ok $id"
3350 pack $id.buttonframe.cancel -side left -expand 1
3351 pack $id.buttonframe.apply -side left -expand 1
3352 pack $id.buttonframe.ok -side left -expand 1
3353
3354 for {set x 0} {$x < 10} {incr x} {
3355 # input device 1
3356 entry $id.f$x -textvariable pd_path$x -width 80
3357 bind $id.f$x <KeyPress-Return> [concat path_ok $id]
3358 pack $id.f$x -side top
3359 }
3360
3361 focus $id.f0
3362}
3363
3364proc pd_set {var value} {
3365 global $var
3366 set $var $value
3367}
3368set pd_nt 1
3369# (The above is 0 for unix, 1 for microsoft, and 2 for Mac OSX. The first
3370# line is automatically munged by the relevant makefiles.)
3371
3372# Copyright (c) 1997-1999 Miller Puckette.
3373# For information on usage and redistribution, and for a DISCLAIMER OF ALL
3374# WARRANTIES, see the file, "LICENSE.txt," in this distribution.
3375
3376# changed by Thomas Musil 09.2001
3377# between "pdtk_graph_dialog -- dialog window for graphs"
3378# and "pdtk_array_dialog -- dialog window for arrays"
3379# a new dialogbox was inserted, named:
3380# "pdtk_iemgui_dialog -- dialog window for iem guis"
3381#
3382# all this changes are labeled with #######iemlib##########
3383
3384# Tearoff is set to true by default:
3385set pd_tearoff 0
3386set menubar 1
3387
3388set File "F"
3389set Windows "W"
3390set Edit "E"
3391set Find "F"
3392set Put "P"
3393set Media "M"
3394set Help "H"
3395
3396set color grey16
3397set lightcolor grey24
3398
3399option add *font -*-helvetica-*--bold--9-*
3400
3401# los colores de la muerte
3402
3403option add *background $color
3404option add *activeBackground $lightcolor
3405
3406option add *foreground white
3407option add *activeForeground white
3408
3409option add *troughColor $lightcolor
3410
3411option add *highlightThickness 0
3412option add *relief solid startupFile
3413
3414if {$pd_nt == 1} {
3415 global pd_guidir
3416 global pd_tearoff
3417 set pd_gui2 [string range $argv0 0 [expr [string last \\ $argv0 ] - 1]]
3418 regsub -all \\\\ $pd_gui2 / pd_gui3
3419 set pd_guidir $pd_gui3/..
3420 load $pd_guidir/bin/pdtcl
3421 set pd_tearoff 1
3422}
3423
3424if {$pd_nt == 2} {
3425 global pd_guidir
3426 global pd_tearoff
3427 set pd_gui2 [string range $argv0 0 [expr [string last / $argv0 ] - 1]]
3428 set pd_guidir $pd_gui2/..
3429 load $pd_guidir/bin/pdtcl
3430 set pd_tearoff 0
3431}
3432
3433# hack so you can easily test-run this script in linux... define pd_guidir
3434# (which is normally defined at startup in pd under linux...)
3435
3436if {$pd_nt == 0} {
3437 if {! [info exists pd_guidir]} {
3438 global pd_guidir
3439 puts stderr {setting pd_guidir to '.'}
3440 set pd_guidir .
3441 }
3442}
3443
3444# it's unfortunate but we seem to have to turn off global bindings
3445# for Text objects to get control-s and control-t to do what we want for
3446# "text" dialogs below. Also we have to get rid of tab's changing the focus.
3447
3448bind all <Key-Tab> ""
3449bind all <<PrevWindow>> ""
3450bind Text <Control-t> {}
3451bind Text <Control-s> {}
3452# puts stderr [bind all]
3453
3454################## set up main window #########################
3455menu .mbar
3456canvas .dummy -height 2p -width 6c
3457
3458frame .controls
3459pack .controls .dummy -side top -fill x
3460menu .mbar.file -tearoff $pd_tearoff
3461.mbar add cascade -label "$File" -menu .mbar.file
3462menu .mbar.find -tearoff $pd_tearoff
3463.mbar add cascade -label "$Find" -menu .mbar.find
3464menu .mbar.windows -postcommand [concat pdtk_fixwindowmenu] -tearoff $pd_tearoff
3465menu .mbar.audio -tearoff $pd_tearoff
3466if {$pd_nt != 2} {
3467 .mbar add cascade -label "$Windows" -menu .mbar.windows
3468 .mbar add cascade -label "$Media" -menu .mbar.audio
3469} else {
3470# Perhaps this is silly, but Mac HIG want "Window Help" as the last menus
3471 .mbar add cascade -label "$Media" -menu .mbar.audio
3472 .mbar add cascade -label "$Windows" -menu .mbar.windows
3473}
3474menu .mbar.help -tearoff $pd_tearoff
3475.mbar add cascade -label "$Help" -menu .mbar.help
3476
3477set ctrls_audio_on 0
3478set ctrls_meter_on 0
3479set ctrls_inlevel 0
3480set ctrls_outlevel 0
3481
3482frame .controls.switches
3483checkbutton .controls.switches.audiobutton -text {compute audio} \
3484 -variable ctrls_audio_on \
3485 -anchor w \
3486 -command {pd [concat pd dsp $ctrls_audio_on \;]}
3487
3488checkbutton .controls.switches.meterbutton -text {peak meters} \
3489 -variable ctrls_meter_on \
3490 -anchor w \
3491 -command {pd [concat pd meters $ctrls_meter_on \;]}
3492
3493pack .controls.switches.meterbutton .controls.switches.audiobutton -side left
3494
3495frame .controls.inout
3496frame .controls.inout.in
3497label .controls.inout.in.label -text IN
3498entry .controls.inout.in.level -textvariable ctrls_inlevel -width 3
3499button .controls.inout.in.clip -text {CLIP} -state disabled
3500pack .controls.inout.in.label .controls.inout.in.level \
3501 .controls.inout.in.clip -side top -pady 2
3502
3503frame .controls.inout.out
3504label .controls.inout.out.label -text OUT
3505entry .controls.inout.out.level -textvariable ctrls_outlevel -width 3
3506button .controls.inout.out.clip -text {CLIP} -state disabled
3507pack .controls.inout.out.label .controls.inout.out.level \
3508 .controls.inout.out.clip -side top -pady 2
3509
3510button .controls.dio -text "DIO\nerrors" \
3511 -command {pd [concat pd audiostatus \;]}
3512
3513pack .controls.switches -side bottom -pady 12
3514pack .controls.inout.in .controls.inout.out -side left -padx 6
3515pack .controls.inout -side left -padx 14
3516pack .controls.dio -side right -padx 20
3517
3518bind . <Control-Key> {pdtk_pd_ctrlkey %W %K 0}
3519bind . <Control-Shift-Key> {pdtk_pd_ctrlkey %W %K 1}
3520if {$pd_nt == 2} {
3521 bind . <Mod1-Key> {pdtk_canvas_ctrlkey %W %K 0}
3522 bind . <Mod1-Shift-Key> {pdtk_canvas_ctrlkey %W %K 1}
3523}
3524
3525
3526wm title . "PDa"
3527. configure -menu .mbar -width 200 -height 150
3528
3529############### set up global variables ################################
3530
3531set untitled_number 1
3532set untitled_directory [pwd]
3533set saveas_client doggy
3534set pd_opendir $untitled_directory
3535set pd_undoaction no
3536set pd_redoaction no
3537set pd_undocanvas no
3538
3539################ utility functions #########################
3540
3541proc pdtk_enquote {x} {
3542 set foo [string map {"," "" ";" "" \" ""} $x]
3543 set foo2 [string map {" " "\\ "} $foo]
3544 concat $foo2
3545}
3546
3547proc pdtk_debug {x} {
3548 tk_messageBox -message $x -type ok
3549}
3550
3551proc pdtk_watchdog {} {
3552 pd [concat pd ping \;]
3553 after 2000 {pdtk_watchdog}
3554}
3555
3556proc pdtk_check {x message} {
3557 set answer [tk_messageBox \-message $x \-type yesno \-icon question]
3558 switch $answer {
3559 yes {pd $message} }
3560# no {tk_messageBox \-message "cancelled" \-type ok}
3561}
3562
3563set menu_windowlist {}
3564
3565proc pdtk_fixwindowmenu {} {
3566 global menu_windowlist
3567 .mbar.windows delete 0 end
3568 foreach i $menu_windowlist {
3569 .mbar.windows add command -label [lindex $i 0] \
3570 -command [concat menu_domenuwindow [lindex $i 1]]
3571 menu_fixwindowmenu [lindex $i 1]
3572 }
3573}
3574
3575####### Odd little function to make better Mac accelerators #####
3576
3577proc accel_munge {acc} {
3578 global pd_nt
3579
3580 if {$pd_nt == 2} {
3581 if [string is upper [string index $acc end]] {
3582 return [format "%s%s" "Shift+" \
3583 [string toupper [string map {Ctrl Meta} $acc] end]]
3584 } else {
3585 return [string toupper [string map {Ctrl Meta} $acc] end]
3586 }
3587 } else {
3588 return $acc
3589 }
3590}
3591
3592
3593
3594############### the "New" menu command ########################
3595proc menu_new {} {
3596 global untitled_number
3597 global untitled_directory
3598 pd [concat pd filename Untitled-$untitled_number $untitled_directory \;]
3599 pd {
3600 #N canvas;
3601 #X pop 1;
3602 }
3603 set untitled_number [expr $untitled_number + 1]
3604}
3605
3606################## the "Open" menu command #########################
3607
3608proc menu_open {} {
3609 global pd_opendir
3610
3611 set filename [tk_getOpenFile -defaultextension .pd \
3612 -filetypes { {{pd files} {.pd}} {{max files} {.pat}}} \
3613 -initialdir $pd_opendir]
3614
3615 if {$filename != ""} {
3616 set directory [string range $filename 0 \
3617 [expr [string last / $filename ] - 1]]
3618 set pd_opendir $directory
3619 set basename [string range $filename \
3620 [expr [string last / $filename ] + 1] end]
3621
3622# pd_debug [concat file $filename base $basename dir $directory]
3623
3624 pd [concat pd open [pdtk_enquote $basename] \
3625 [pdtk_enquote $directory]\;]
3626 }
3627}
3628
3629################## the "Message" menu command #########################
3630proc menu_send {} {
3631 toplevel .sendpanel
3632 entry .sendpanel.entry -textvariable send_textvariable
3633 pack .sendpanel.entry -side bottom -fill both -ipadx 100
3634 .sendpanel.entry select from 0
3635 .sendpanel.entry select adjust end
3636 bind .sendpanel.entry <KeyPress-Return> {
3637 pd [concat $send_textvariable \;]
3638 after 50 {destroy .sendpanel}
3639 }
3640 focus .sendpanel.entry
3641}
3642
3643################## the "Quit" menu command #########################
3644proc menu_really_quit {} {pd {pd quit;}}
3645
3646proc menu_quit {} {pd {pd quit;}}
3647
3648######### the "Pd" menu command, which puts the Pd window on top ########
3649proc menu_pop_pd {} {raise .}
3650
3651######### the "audio" menu command ###############
3652proc menu_audio {flag} {pd [concat pd dsp $flag \;]}
3653
3654######### the "documentation" menu command ###############
3655
3656set doc_number 1
3657
3658proc menu_opentext {filename} {
3659 global doc_number
3660 global pd_guidir
3661 global pd_myversion
3662 set name [format ".help%d" $doc_number]
3663 toplevel $name
3664 text $name.text -fg black -relief raised -bd 2 -font -*-courier-bold--normal--12-* \
3665 -yscrollcommand "$name.scroll set" -background white
3666 scrollbar $name.scroll -command "$name.text yview"
3667 pack $name.scroll -side right -fill y
3668 pack $name.text -side left -fill both -expand 1
3669
3670 set f [open $filename]
3671 while {![eof $f]} {
3672 set bigstring [read $f 1000]
3673 regsub -all PD_BASEDIR $bigstring $pd_guidir bigstring2
3674 regsub -all PD_VERSION $bigstring2 $pd_myversion bigstring3
3675 $name.text insert end $bigstring3
3676 }
3677 close $f
3678 set doc_number [expr $doc_number + 1]
3679}
3680
3681set help_directory $pd_guidir/doc
3682
3683proc menu_documentation {} {
3684 global help_directory
3685 global pd_nt
3686
3687 set filename [tk_getOpenFile -defaultextension .pd \
3688 -filetypes { {{documentation} {.pd .txt .htm}} } \
3689 -initialdir $help_directory]
3690
3691 if {$filename != ""} {
3692 if {[string first .txt $filename] >= 0} {
3693 menu_opentext $filename
3694 } elseif {[string first .htm $filename] >= 0} {
3695 if {$pd_nt == 0} {
3696 exec sh -c \
3697 [format "mozilla file:%s || netscape file:%s &\n" \
3698 $filename $filename]
3699 } elseif {$pd_nt == 2} {
3700 puts stderr [format "open %s" $filename]
3701 exec sh -c \
3702 [format "open %s" $filename]
3703 } else {
3704 exec rundll32 url.dll,FileProtocolHandler \
3705 [format "file:%s" $filename] &
3706 }
3707 } else {
3708 set help_directory [string range $filename 0 \
3709 [expr [string last / $filename ] - 1]]
3710 set basename [string range $filename \
3711 [expr [string last / $filename ] + 1] end]
3712 pd [concat pd open [pdtk_enquote $basename] \
3713 [pdtk_enquote $help_directory] \;]
3714 }
3715 }
3716}
3717
3718proc menu_doc_open {subdir basename} {
3719 global pd_guidir
3720
3721 set dirname $pd_guidir/$subdir
3722
3723 if {[string first .txt $basename] >= 0} {
3724 menu_opentext $dirname/$basename
3725 } else {
3726 pd [concat pd open [pdtk_enquote $basename] \
3727 [pdtk_enquote $dirname] \;]
3728 }
3729}
3730
3731############# routine to add audio and help menus ###############
3732
3733proc menu_addstd {mbar} {
3734 global pd_apilist
3735# the "Audio" menu
3736 $mbar.audio add command -label {audio ON} -accelerator [accel_munge "Ctrl+/"] \
3737 -command {menu_audio 1}
3738 $mbar.audio add command -label {audio OFF} -accelerator [accel_munge "Ctrl+."] \
3739 -command {menu_audio 0}
3740 for {set x 0} {$x<[llength $pd_apilist]} {incr x} {
3741 $mbar.audio add radiobutton -label [lindex [lindex $pd_apilist $x] 0] \
3742 -command {menu_audio 0} -variable pd_whichapi \
3743 -value [lindex [lindex $pd_apilist $x] 1]\
3744 -command {pd [concat pd audio-setapi $pd_whichapi \;]}
3745 }
3746 $mbar.audio add command -label {Audio settings...} \
3747 -command {pd pd audio-properties \;}
3748
3749 $mbar.audio add command -label {MIDI settings...} \
3750 -command {pd pd midi-properties \;}
3751 $mbar.audio add command -label {Test Audio and MIDI} \
3752 -command {menu_doc_open doc/7.stuff/tools testtone.pd}
3753 $mbar.audio add command -label {Load Meter} \
3754 -command {menu_doc_open doc/7.stuff/tools load-meter.pd}
3755
3756
3757 $mbar.audio add checkbutton -label "Show Menubar" \
3758 -indicatoron true -selectcolor grey85 \
3759 -variable menubar
3760
3761# the "Help" menu
3762 $mbar.help add command -label {About Pd} \
3763 -command {menu_doc_open doc/1.manual 1.introduction.txt}
3764 $mbar.help add command -label {Pure Documentation...} \
3765 -command {menu_documentation}
3766}
3767
3768#################### the "File" menu for the Pd window ##############
3769
3770.mbar.file add command -label New -command {menu_new} \
3771 -accelerator [accel_munge "Ctrl+n"]
3772.mbar.file add command -label Open -command {menu_open} \
3773 -accelerator [accel_munge "Ctrl+o"]
3774.mbar.file add separator
3775.mbar.file add command -label Message -command {menu_send} \
3776 -accelerator [accel_munge "Ctrl+m"]
3777.mbar.file add command -label Path... \
3778 -command {pd pd start-path-dialog \;}
3779.mbar.file add separator
3780.mbar.file add command -label Quit -command {menu_quit} \
3781 -accelerator [accel_munge "Ctrl+q"]
3782
3783#################### the "Find" menu for the Pd window ##############
3784.mbar.find add command -label {last error?} -command {menu_finderror}
3785
3786########### functions for menu functions on document windows ########
3787
3788proc menu_save {name} {
3789 pdtk_canvas_checkgeometry $name
3790 pd [concat $name menusave \;]
3791}
3792
3793proc menu_saveas {name} {
3794 pdtk_canvas_checkgeometry $name
3795 pd [concat $name menusaveas \;]
3796}
3797
3798proc menu_print {name} {
3799 set filename [tk_getSaveFile -initialfile pd.ps \
3800 -defaultextension .ps \
3801 -filetypes { {{postscript} {.ps}} }]
3802
3803 if {$filename != ""} {
3804 $name.c postscript -file $filename
3805 }
3806}
3807
3808proc menu_close {name} {
3809 pd [concat $name menuclose \;]
3810}
3811
3812proc menu_undo {name} {
3813 global pd_undoaction
3814 global pd_redoaction
3815 global pd_undocanvas
3816 if {$name == $pd_undocanvas && $pd_undoaction != "no"} {
3817 pd [concat $name undo \;]
3818 }
3819}
3820
3821proc menu_redo {name} {
3822 global pd_undoaction
3823 global pd_redoaction
3824 global pd_undocanvas
3825 if {$name == $pd_undocanvas && $pd_redoaction != "no"} {
3826 pd [concat $name redo \;]
3827 }
3828}
3829
3830proc menu_cut {name} {
3831 pd [concat $name cut \;]
3832}
3833
3834proc menu_copy {name} {
3835 pd [concat $name copy \;]
3836}
3837
3838proc menu_paste {name} {
3839 pd [concat $name paste \;]
3840}
3841
3842proc menu_duplicate {name} {
3843 pd [concat $name duplicate \;]
3844}
3845
3846proc menu_selectall {name} {
3847 pd [concat $name selectall \;]
3848}
3849
3850proc menu_texteditor {name} {
3851 pd [concat $name texteditor \;]
3852}
3853
3854proc menu_font {name} {
3855 pd [concat $name menufont \;]
3856}
3857
3858proc menu_tidyup {name} {
3859 pd [concat $name tidy \;]
3860}
3861
3862proc menu_editmode {name} {
3863 pd [concat $name editmode 0 \;]
3864}
3865
3866proc menu_object {name accel} {
3867 pd [concat $name obj $accel \;]
3868}
3869
3870proc menu_message {name accel} {
3871 pd [concat $name msg $accel \;]
3872}
3873
3874proc menu_floatatom {name accel} {
3875 pd [concat $name floatatom $accel \;]
3876}
3877
3878proc menu_symbolatom {name accel} {
3879 pd [concat $name symbolatom $accel \;]
3880}
3881
3882proc menu_comment {name accel} {
3883 pd [concat $name text $accel \;]
3884}
3885
3886proc menu_graph {name} {
3887 pd [concat $name graph \;]
3888}
3889
3890proc menu_array {name} {
3891 pd [concat $name menuarray \;]
3892}
3893
3894############iemlib##################
3895proc menu_bng {name accel} {
3896 pd [concat $name bng $accel \;]
3897}
3898
3899proc menu_toggle {name accel} {
3900 pd [concat $name toggle $accel \;]
3901}
3902
3903proc menu_numbox {name accel} {
3904 pd [concat $name numbox $accel \;]
3905}
3906
3907proc menu_vslider {name accel} {
3908 pd [concat $name vslider $accel \;]
3909}
3910
3911proc menu_hslider {name accel} {
3912 pd [concat $name hslider $accel \;]
3913}
3914
3915proc menu_hradio {name accel} {
3916 pd [concat $name hradio $accel \;]
3917}
3918
3919proc menu_vradio {name accel} {
3920 pd [concat $name vradio $accel \;]
3921}
3922
3923proc menu_vumeter {name accel} {
3924 pd [concat $name vumeter $accel \;]
3925}
3926
3927proc menu_mycnv {name accel} {
3928 pd [concat $name mycnv $accel \;]
3929}
3930
3931############iemlib##################
3932
3933# correct edit menu, enabling or disabling undo/redo
3934# LATER also cut/copy/paste
3935proc menu_fixeditmenu {name} {
3936 global pd_undoaction
3937 global pd_redoaction
3938 global pd_undocanvas
3939# puts stderr [concat menu_fixeditmenu $name $pd_undocanvas $pd_undoaction]
3940 if {$name == $pd_undocanvas && $pd_undoaction != "no"} {
3941 $name.m.edit entryconfigure "Undo*" -state normal \
3942 -label [concat "Undo " $pd_undoaction]
3943 } else {
3944 $name.m.edit entryconfigure "Undo*" -state disabled -label "Undo"
3945 }
3946 if {$name == $pd_undocanvas && $pd_redoaction != "no"} {
3947 $name.m.edit entryconfigure "Redo*" -state normal\
3948 -label [concat "Redo " $pd_redoaction]
3949 } else {
3950 $name.m.edit entryconfigure "Redo*" -state disabled
3951 }
3952}
3953
3954# message from Pd to update the currently available undo/redo action
3955proc pdtk_undomenu {name undoaction redoaction} {
3956 global pd_undoaction
3957 global pd_redoaction
3958 global pd_undocanvas
3959# puts stderr [concat pdtk_undomenu $name $undoaction $redoaction]
3960 set pd_undocanvas $name
3961 set pd_undoaction $undoaction
3962 set pd_redoaction $redoaction
3963 if {$name != "nobody"} {
3964# unpleasant way of avoiding a more unpleasant bug situation --atl 2002.11.25
3965 menu_fixeditmenu $name
3966 }
3967}
3968
3969proc menu_windowparent {name} {
3970 pd [concat $name findparent \;]
3971}
3972
3973proc menu_findagain {name} {
3974 pd [concat $name findagain \;]
3975}
3976
3977proc menu_finderror {} {
3978 pd [concat pd finderror \;]
3979}
3980
3981proc menu_domenuwindow {i} {
3982 raise $i
3983}
3984
3985proc menu_fixwindowmenu {name} {
3986 global menu_windowlist
3987 global pd_tearoff
3988 global menubar
3989
3990 if { $menubar == 1 } {
3991 $name.m.windows add command
3992 if $pd_tearoff {
3993 $name.m.windows delete 4 end
3994 } else {
3995 $name.m.windows delete 3 end
3996 }
3997 foreach i $menu_windowlist {
3998 $name.m.windows add command -label [lindex $i 0] \
3999 -command [concat menu_domenuwindow [lindex $i 1]]
4000 }
4001 }
4002}
4003
4004################## the "find" menu item ###################
4005
4006set find_canvas nobody
4007set find_string ""
4008set find_count 1
4009
4010proc find_apply {name} {
4011 global find_string
4012 global find_canvas
4013 regsub -all \; $find_string " _semi_ " find_string2
4014 regsub -all \, $find_string2 " _comma_ " find_string3
4015# puts stderr [concat $find_canvas find $find_string3 \
4016# \;]
4017 pd [concat $find_canvas find $find_string3 \
4018 \;]
4019 after 50 destroy $name
4020}
4021
4022proc find_cancel {name} {
4023 after 50 destroy $name
4024}
4025
4026proc menu_findobject {canvas} {
4027 global find_string
4028 global find_canvas
4029 global find_count
4030
4031 set name [format ".find%d" $find_count]
4032 set find_count [expr $find_count + 1]
4033
4034 set find_canvas $canvas
4035
4036 toplevel $name
4037
4038 label $name.label -text {find...}
4039 pack $name.label -side top
4040
4041 entry $name.entry -textvariable find_string
4042 pack $name.entry -side top
4043
4044 frame $name.buttonframe
4045 pack $name.buttonframe -side bottom -fill x -pady 2m
4046 button $name.buttonframe.cancel -text {Cancel}\
4047 -command "find_cancel $name"
4048 button $name.buttonframe.ok -text {OK}\
4049 -command "find_apply $name"
4050 pack $name.buttonframe.cancel -side left -expand 1
4051 pack $name.buttonframe.ok -side left -expand 1
4052
4053 $name.entry select from 0
4054 $name.entry select adjust end
4055 bind $name.entry <KeyPress-Return> [ concat find_apply $name]
4056 focus $name.entry
4057}
4058
4059
4060
4061proc pdtk_canvas_menubar {name width height geometry editable} {
4062 global pd_opendir
4063 global pd_tearoff
4064 global pd_nt
4065
4066 global File Edit Find Put Windows Media Help
4067
4068
4069 menu $name.m.file -tearoff $pd_tearoff
4070 $name.m add cascade -label "$File" -menu $name.m.file
4071
4072 $name.m.file add command -label New -command {menu_new} \
4073 -accelerator [accel_munge "Ctrl+n"]
4074
4075 $name.m.file add command -label Open -command {menu_open} \
4076 -accelerator [accel_munge "Ctrl+o"]
4077
4078 $name.m.file add separator
4079 $name.m.file add command -label Message -command {menu_send} \
4080 -accelerator [accel_munge "Ctrl+m"]
4081
4082 $name.m.file add command -label Path... \
4083 -command {pd pd start-path-dialog \;}
4084
4085 $name.m.file add separator
4086 $name.m.file add command -label Close \
4087 -command [concat menu_close $name] \
4088 -accelerator [accel_munge "Ctrl+w"]
4089
4090 $name.m.file add command -label Save -command [concat menu_save $name] \
4091 -accelerator [accel_munge "Ctrl+s"]
4092
4093 $name.m.file add command -label "Save as..." \
4094 -command [concat menu_saveas $name] \
4095 -accelerator [accel_munge "Ctrl+S"]
4096
4097 $name.m.file add command -label Print -command [concat menu_print $name] \
4098 -accelerator [accel_munge "Ctrl+p"]
4099
4100 $name.m.file add separator
4101
4102 $name.m.file add command -label Quit -command {menu_quit} \
4103 -accelerator [accel_munge "Ctrl+q"]
4104
4105# the edit menu
4106 menu $name.m.edit -postcommand [concat menu_fixeditmenu $name] -tearoff $pd_tearoff
4107 $name.m add cascade -label $Edit -menu $name.m.edit
4108
4109 $name.m.edit add command -label Undo -command [concat menu_undo $name] \
4110 -accelerator [accel_munge "Ctrl+z"]
4111
4112 $name.m.edit add command -label Redo -command [concat menu_redo $name] \
4113 -accelerator [accel_munge "Ctrl+Z"]
4114
4115 $name.m.edit add separator
4116
4117 $name.m.edit add command -label Cut -command [concat menu_cut $name] \
4118 -accelerator [accel_munge "Ctrl+x"]
4119
4120 $name.m.edit add command -label Copy -command [concat menu_copy $name] \
4121 -accelerator [accel_munge "Ctrl+c"]
4122
4123 $name.m.edit add command -label Paste \
4124 -command [concat menu_paste $name] \
4125 -accelerator [accel_munge "Ctrl+v"]
4126
4127 $name.m.edit add command -label Duplicate \
4128 -command [concat menu_duplicate $name] \
4129 -accelerator [accel_munge "Ctrl+d"]
4130
4131 $name.m.edit add command -label {Select all} \
4132 -command [concat menu_selectall $name] \
4133 -accelerator [accel_munge "Ctrl+a"]
4134
4135 $name.m.edit add separator
4136
4137 $name.m.edit add command -label {Text Editor} \
4138 -command [concat menu_texteditor $name] \
4139 -accelerator [accel_munge "Ctrl+t"]
4140
4141 $name.m.edit add command -label Font \
4142 -command [concat menu_font $name]
4143
4144 $name.m.edit add command -label {Tidy Up} \
4145 -command [concat menu_tidyup $name]
4146
4147 $name.m.edit add separator
4148
4149############iemlib##################
4150# instead of "red = #BC3C60" we take "grey85", so there is no difference,
4151# if widget is selected or not.
4152
4153 $name.m.edit add checkbutton -label "Edit mode" \
4154 -indicatoron true -selectcolor grey85 \
4155 -command [concat menu_editmode $name] \
4156 -accelerator [accel_munge "Ctrl+e"]
4157
4158 if { $editable == 0 } {
4159 $name.m.edit entryconfigure "Edit mode" -indicatoron false }
4160
4161############iemlib##################
4162
4163# the put menu
4164 menu $name.m.put -tearoff $pd_tearoff
4165 $name.m add cascade -label $Put -menu $name.m.put
4166
4167 $name.m.put add command -label Object \
4168 -command [concat menu_object $name 0] \
4169 -accelerator [accel_munge "Ctrl+1"]
4170
4171 $name.m.put add command -label Message \
4172 -command [concat menu_message $name 0] \
4173 -accelerator [accel_munge "Ctrl+2"]
4174
4175 $name.m.put add command -label Number \
4176 -command [concat menu_floatatom $name 0] \
4177 -accelerator [accel_munge "Ctrl+3"]
4178
4179 $name.m.put add command -label Symbol \
4180 -command [concat menu_symbolatom $name 0] \
4181 -accelerator [accel_munge "Ctrl+4"]
4182
4183 $name.m.put add command -label Comment \
4184 -command [concat menu_comment $name 0] \
4185 -accelerator [accel_munge "Ctrl+5"]
4186
4187 $name.m.put add separator
4188
4189############iemlib##################
4190
4191 $name.m.put add command -label Bang \
4192 -command [concat menu_bng $name 0] \
4193 -accelerator [accel_munge "Alt+b"]
4194
4195 $name.m.put add command -label Toggle \
4196 -command [concat menu_toggle $name 0] \
4197 -accelerator [accel_munge "Alt+t"]
4198
4199 $name.m.put add command -label Number2 \
4200 -command [concat menu_numbox $name 0] \
4201 -accelerator [accel_munge "Alt+n"]
4202
4203 $name.m.put add command -label Vslider \
4204 -command [concat menu_vslider $name 0] \
4205 -accelerator [accel_munge "Alt+v"]
4206
4207 $name.m.put add command -label Hslider \
4208 -command [concat menu_hslider $name 0] \
4209 -accelerator [accel_munge "Alt+h"]
4210
4211 $name.m.put add command -label Vradio \
4212 -command [concat menu_vradio $name 0] \
4213 -accelerator [accel_munge "Alt+d"]
4214
4215 $name.m.put add command -label Hradio \
4216 -command [concat menu_hradio $name 0] \
4217 -accelerator [accel_munge "Alt+i"]
4218
4219 $name.m.put add command -label VU \
4220 -command [concat menu_vumeter $name 0] \
4221 -accelerator [accel_munge "Alt+u"]
4222
4223 $name.m.put add command -label Canvas \
4224 -command [concat menu_mycnv $name 0] \
4225 -accelerator [accel_munge "Alt+c"]
4226
4227############iemlib##################
4228
4229 $name.m.put add separator
4230
4231 $name.m.put add command -label Graph \
4232 -command [concat menu_graph $name]
4233
4234 $name.m.put add command -label Array \
4235 -command [concat menu_array $name]
4236
4237# the find menu
4238 menu $name.m.find -tearoff $pd_tearoff
4239 $name.m add cascade -label "$Find" -menu $name.m.find
4240
4241 $name.m.find add command -label {Find...} \
4242 -accelerator [accel_munge "Ctrl+f"] \
4243 -command [concat menu_findobject $name]
4244 $name.m.find add command -label {Find Again} \
4245 -accelerator [accel_munge "Ctrl+g"] \
4246 -command [concat menu_findagain $name]
4247 $name.m.find add command -label {Find last error} \
4248 -command [concat menu_finderror]
4249
4250# the window menu
4251 menu $name.m.windows -postcommand [concat menu_fixwindowmenu $name] \
4252 -tearoff $pd_tearoff
4253
4254 $name.m.windows add command -label {parent window}\
4255 -command [concat menu_windowparent $name]
4256 $name.m.windows add command -label {Pd window} -command menu_pop_pd
4257 $name.m.windows add separator
4258
4259# the audio menu
4260 menu $name.m.audio -tearoff $pd_tearoff
4261
4262 if {$pd_nt != 2} {
4263 $name.m add cascade -label $Windows -menu $name.m.windows
4264 $name.m add cascade -label $Media -menu $name.m.audio
4265 } else {
4266 $name.m add cascade -label $Media -menu $name.m.audio
4267 $name.m add cascade -label $Windows -menu $name.m.windows
4268 }
4269
4270# the help menu
4271 menu $name.m.help -tearoff $pd_tearoff
4272 $name.m add cascade -label $Help -menu $name.m.help
4273
4274 menu_addstd $name.m
4275}
4276
4277
4278############# pdtk_canvas_new -- create a new canvas ###############
4279proc pdtk_canvas_new {name width height geometry editable} {
4280 global pd_opendir
4281 global pd_tearoff
4282 global pd_nt
4283 global menubar
4284
4285 toplevel $name -menu $name.m
4286# puts stderr [concat geometry: $geometry]
4287 wm geometry $name $geometry
4288 wm minsize $name 1 1
4289
4290 canvas $name.c -width $width -height $height -background white \
4291 -yscrollcommand "$name.scrollvert set" \
4292 -xscrollcommand "$name.scrollhort set" \
4293 -scrollregion [concat 0 0 $width $height]
4294
4295
4296 scrollbar $name.scrollvert -command "$name.c yview" -width 7
4297 scrollbar $name.scrollhort -command "$name.c xview" \
4298 -orient horizontal -width 7
4299
4300 pack $name.scrollhort -side bottom -fill x
4301 pack $name.scrollvert -side right -fill y
4302 pack $name.c -side left -expand 1 -fill both
4303
4304# the menubar
4305
4306 menu $name.m
4307
4308 if { $menubar == 1 } {
4309 pdtk_canvas_menubar $name $width $height $geometry $editable
4310 }
4311
4312# the popup menu
4313 menu $name.popup -tearoff false
4314 $name.popup add command -label {Properties} \
4315 -command [concat popup_action $name 0]
4316 $name.popup add command -label {Open} \
4317 -command [concat popup_action $name 1]
4318 $name.popup add command -label {Help} \
4319 -command [concat popup_action $name 2]
4320
4321# WM protocol
4322 wm protocol $name WM_DELETE_WINDOW [concat menu_close $name]
4323
4324# bindings.
4325# this is idiotic -- how do you just sense what mod keys are down and
4326# pass them on? I can't find it anywhere.
4327# Here we encode shift as 1, control 2, alt 4, in agreement
4328# with definitions in g_canvas.c. The third button gets "8" but we don't
4329# bother with modifiers there.
4330# We don't handle multiple clicks yet.
4331
4332 bind $name.c <Button> {pdtk_canvas_click %W %x %y %b 0}
4333 bind $name.c <Shift-Button> {pdtk_canvas_click %W %x %y %b 1}
4334 bind $name.c <Control-Shift-Button> {pdtk_canvas_click %W %x %y %b 3}
4335 bind $name.c <Alt-Button> {pdtk_canvas_click %W %x %y %b 4}
4336 bind $name.c <Alt-Shift-Button> {pdtk_canvas_click %W %x %y %b 5}
4337 bind $name.c <Alt-Control-Button> {pdtk_canvas_click %W %x %y %b 6}
4338 bind $name.c <Alt-Control-Shift-Button> {pdtk_canvas_click %W %x %y %b 7}
4339 global pd_nt
4340 if {$pd_nt == 2} {
4341 bind $name.c <Button-2> {pdtk_canvas_click %W %x %y %b 8}
4342 bind $name.c <Control-Button> {pdtk_canvas_click %W %x %y %b 8}
4343 } else {
4344 bind $name.c <Button-3> {pdtk_canvas_click %W %x %y %b 8}
4345 bind $name.c <Control-Button> {pdtk_canvas_click %W %x %y %b 2}
4346 }
4347# change mac to right-click, not middle click -atl 2002.09.02
4348
4349 bind $name.c <ButtonRelease> {pdtk_canvas_mouseup %W %x %y %b}
4350 bind $name.c <Control-Key> {pdtk_canvas_ctrlkey %W %K 0}
4351 bind $name.c <Control-Shift-Key> {pdtk_canvas_ctrlkey %W %K 1}
4352 bind $name.c <Alt-Key> {pdtk_canvas_altkey %W %K %A}
4353# bind $name.c <Mod1-Key> {puts stderr [concat mod1 %W %K %A]}
4354 if {$pd_nt == 2} {
4355 bind $name.c <Mod1-Key> {pdtk_canvas_ctrlkey %W %K 0}
4356 bind $name.c <Mod1-Shift-Key> {pdtk_canvas_ctrlkey %W %K 1}
4357 }
4358 bind $name.c <Key> {pdtk_canvas_key %W %K %A 0}
4359 bind $name.c <Shift-Key> {pdtk_canvas_key %W %K %A 1}
4360 bind $name.c <KeyRelease> {pdtk_canvas_keyup %W %K %A}
4361 bind $name.c <Motion> {pdtk_canvas_motion %W %x %y 0}
4362 bind $name.c <Alt-Motion> {pdtk_canvas_motion %W %x %y 4}
4363 bind $name.c <Map> {pdtk_canvas_map %W}
4364 bind $name.c <Unmap> {pdtk_canvas_unmap %W}
4365 focus $name.c
4366# puts stderr "all done"
4367# after 1 [concat raise $name]
4368}
4369
4370#################### event binding procedures ################
4371
4372#get the name of the toplevel window for a canvas; this is also
4373#the name of the canvas object in Pd.
4374
4375proc canvastosym {name} {
4376 string range $name 0 [expr [string length $name] - 3]
4377}
4378
4379set pdtk_lastcanvasconfigured ""
4380set pdtk_lastcanvasconfiguration ""
4381
4382proc pdtk_canvas_checkgeometry {topname} {
4383 set boo [winfo geometry $topname.c]
4384 set boo2 [wm geometry $topname]
4385 global pdtk_lastcanvasconfigured
4386 global pdtk_lastcanvasconfiguration
4387 if {$topname != $pdtk_lastcanvasconfigured || \
4388 $boo != $pdtk_lastcanvasconfiguration} {
4389 set pdtk_lastcanvasconfigured $topname
4390 set pdtk_lastcanvasconfiguration $boo
4391 pd $topname relocate $boo $boo2 \;
4392 }
4393}
4394
4395proc pdtk_canvas_click {name x y b f} {
4396# puts stderr [concat got $f]
4397 pd [canvastosym $name] mouse [$name canvasx $x] [$name canvasy $y] $b $f \;
4398}
4399
4400proc pdtk_canvas_shiftclick {name x y b} {
4401 pd [canvastosym $name] mouse [$name canvasx $x] [$name canvasy $y] $b 1 \;
4402}
4403
4404proc pdtk_canvas_ctrlclick {name x y b} {
4405 pd [canvastosym $name] mouse [$name canvasx $x] [$name canvasy $y] $b 2 \;
4406}
4407
4408proc pdtk_canvas_altclick {name x y b} {
4409 pd [canvastosym $name] mouse [$name canvasx $x] [$name canvasy $y] $b 3 \;
4410}
4411
4412proc pdtk_canvas_dblclick {name x y b} {
4413 pd [canvastosym $name] mouse [$name canvasx $x] [$name canvasy $y] $b 4 \;
4414}
4415
4416set pdtk_canvas_mouseup_name 0
4417set pdtk_canvas_mouseup_xminval 0
4418set pdtk_canvas_mouseup_xmaxval 0
4419set pdtk_canvas_mouseup_yminval 0
4420set pdtk_canvas_mouseup_ymaxval 0
4421
4422proc pdtk_canvas_mouseup {name x y b} {
4423 pd [concat [canvastosym $name] mouseup [$name canvasx $x] \
4424 [$name canvasy $y] $b \;]
4425
4426# we use the mouseup event to update scrollbar ranges and recheck the
4427# geometry of the window since I haven't taken the time to figure out
4428# how to do it right.
4429
4430 global pdtk_canvas_mouseup_name
4431 global pdtk_canvas_mouseup_xminval
4432 global pdtk_canvas_mouseup_xmaxval
4433 global pdtk_canvas_mouseup_yminval
4434 global pdtk_canvas_mouseup_ymaxval
4435
4436 set size [$name bbox all]
4437 if {$size != ""} {
4438 set xminval 0
4439 set yminval 0
4440 set xmaxval 100
4441 set ymaxval 100
4442 set x1 [lindex $size 0]
4443 set x2 [lindex $size 2]
4444 set y1 [lindex $size 1]
4445 set y2 [lindex $size 3]
4446
4447 if {$x1 < 0} {set xminval $x1}
4448 if {$y1 < 0} {set yminval $y1}
4449
4450 if {$x2 > 100} {set xmaxval $x2}
4451 if {$y2 > 100} {set ymaxval $y2}
4452
4453 if {$pdtk_canvas_mouseup_name != $name || \
4454 $pdtk_canvas_mouseup_xminval != $xminval || \
4455 $pdtk_canvas_mouseup_xmaxval != $xmaxval || \
4456 $pdtk_canvas_mouseup_yminval != $yminval || \
4457 $pdtk_canvas_mouseup_ymaxval != $ymaxval } {
4458
4459 set newsize "$xminval $yminval $xmaxval $ymaxval"
4460 $name configure -scrollregion $newsize
4461 set pdtk_canvas_mouseup_name $name
4462 set pdtk_canvas_mouseup_xminval $xminval
4463 set pdtk_canvas_mouseup_xmaxval $xmaxval
4464 set pdtk_canvas_mouseup_yminval $yminval
4465 set pdtk_canvas_mouseup_ymaxval $ymaxval
4466 }
4467
4468 }
4469 pdtk_canvas_checkgeometry [canvastosym $name]
4470}
4471
4472proc pdtk_canvas_key {name key iso shift} {
4473# puts stderr [concat down key= $key iso= $iso]
4474# .controls.switches.meterbutton configure -text $key
4475# HACK for MAC OSX -- backspace seems different; I don't understand why.
4476# invesigate this LATER...
4477 global pd_nt
4478 if {$pd_nt == 2} {
4479 if {$key == "BackSpace"} {
4480 set key 8
4481 set keynum 8
4482 }
4483 if {$key == "Delete"} {
4484 set key 8
4485 set keynum 8
4486 }
4487 }
4488 if {$key == "KP_Delete"} {
4489 set key 127
4490 set keynum 127
4491 }
4492 if {$iso != ""} {
4493 scan $iso %c keynum
4494 pd [canvastosym $name] key 1 $keynum $shift\;
4495 } else {
4496 pd [canvastosym $name] key 1 $key $shift\;
4497 }
4498}
4499
4500proc pdtk_canvas_keyup {name key iso} {
4501# puts stderr [concat up key= $key iso= $iso]
4502 if {$iso != ""} {
4503 scan $iso %c keynum
4504 pd [canvastosym $name] key 0 $keynum 0 \;
4505 } else {
4506 pd [canvastosym $name] key 0 $key 0 \;
4507 }
4508}
4509
4510proc pdtk_canvas_altkey {name key iso} {
4511# puts stderr [concat alt-key $iso]
4512############iemlib##################
4513 set topname [string trimright $name .c]
4514 if {$key == "b" || $key == "B"} {menu_bng $topname 1}
4515 if {$key == "t" || $key == "T"} {menu_toggle $topname 1}
4516 if {$key == "n" || $key == "N"} {menu_numbox $topname 1}
4517 if {$key == "v" || $key == "V"} {menu_vslider $topname 1}
4518 if {$key == "h" || $key == "H"} {menu_hslider $topname 1}
4519 if {$key == "i" || $key == "I"} {menu_hradio $topname 1}
4520 if {$key == "d" || $key == "D"} {menu_vradio $topname 1}
4521 if {$key == "u" || $key == "U"} {menu_vumeter $topname 1}
4522 if {$key == "c" || $key == "C"} {menu_mycnv $topname 1}
4523############iemlib##################
4524}
4525
4526proc pdtk_canvas_ctrlkey {name key shift} {
4527# first get rid of ".c" suffix; we'll refer to the toplevel instead
4528 set topname [string trimright $name .c]
4529# puts stderr [concat ctrl-key $key $topname]
4530
4531 if {$key == "n" || $key == "N"} {menu_new}
4532 if {$key == "o" || $key == "O"} {menu_open}
4533 if {$key == "m" || $key == "M"} {menu_send}
4534 if {$key == "q" || $key == "Q"} {
4535 if {$shift == 1} {menu_really_quit} else {menu_quit}
4536 }
4537 if {$key == "s" || $key == "S"} {
4538 if {$shift == 1} {menu_saveas $topname} else {menu_save $topname}
4539 }
4540 if {$key == "z" || $key == "Z"} {
4541 if {$shift == 1} {menu_redo $topname} else {menu_undo $topname}
4542 }
4543 if {$key == "w" || $key == "W"} {menu_close $topname}
4544 if {$key == "p" || $key == "P"} {menu_print $topname}
4545 if {$key == "x" || $key == "X"} {menu_cut $topname}
4546 if {$key == "c" || $key == "C"} {menu_copy $topname}
4547 if {$key == "v" || $key == "V"} {menu_paste $topname}
4548 if {$key == "d" || $key == "D"} {menu_duplicate $topname}
4549 if {$key == "a" || $key == "A"} {menu_selectall $topname}
4550 if {$key == "t" || $key == "T"} {menu_texteditor $topname}
4551 if {$key == "f" || $key == "F"} {menu_findobject $topname}
4552 if {$key == "g" || $key == "G"} {menu_findagain $topname}
4553 if {$key == "1"} {menu_object $topname 1}
4554 if {$key == "2"} {menu_message $topname 1}
4555 if {$key == "3"} {menu_floatatom $topname 1}
4556 if {$key == "4"} {menu_symbolatom $topname 1}
4557 if {$key == "5"} {menu_comment $topname 1}
4558 if {$key == "slash"} {menu_audio 1}
4559 if {$key == "period"} {menu_audio 0}
4560 if {$key == "e" || $key == "E"} {menu_editmode $topname}
4561}
4562
4563proc pdtk_canvas_motion {name x y mods} {
4564# puts stderr [concat [canvastosym $name] $name $x $y]
4565 pd [canvastosym $name] motion [$name canvasx $x] [$name canvasy $y] $mods \;
4566}
4567
4568# "map" event tells us when the canvas becomes visible (arg is "0") or
4569# invisible (arg is ""). Invisibility means the Window Manager has minimized
4570# us. We don't get a final "unmap" event when we destroy the window.
4571proc pdtk_canvas_map {name} {
4572# puts stderr [concat map $name]
4573 pd [canvastosym $name] map 1 \;
4574}
4575
4576proc pdtk_canvas_unmap {name} {
4577# puts stderr [concat unmap $name]
4578 pd [canvastosym $name] map 0 \;
4579}
4580
4581set saveas_dir nowhere
4582
4583############ pdtk_canvas_saveas -- run a saveas dialog ##############
4584
4585proc pdtk_canvas_saveas {name initfile initdir} {
4586 set filename [tk_getSaveFile -initialfile $initfile \
4587 -initialdir $initdir -defaultextension .pd \
4588 -filetypes { {{pd files} {.pd}} {{max files} {.pat}} }]
4589
4590 if {$filename != ""} {
4591 set directory [string range $filename 0 \
4592 [expr [string last / $filename ] - 1]]
4593 set basename [string range $filename \
4594 [expr [string last / $filename ] + 1] end]
4595 pd [concat $name savetofile [pdtk_enquote $basename] \
4596 [pdtk_enquote $directory] \;]
4597# pd [concat $name savetofile $basename $directory \;]
4598 }
4599}
4600
4601############ pdtk_canvas_dofont -- run a font and resize dialog #########
4602
4603set fontsize 0
4604set stretchval 0
4605set whichstretch 0
4606
4607proc dofont_apply {name} {
4608 global fontsize
4609 global stretchval
4610 global whichstretch
4611 set cmd [concat $name font $fontsize $stretchval $whichstretch \;]
4612# puts stderr $cmd
4613 pd $cmd
4614}
4615
4616proc dofont_cancel {name} {
4617 set cmd [concat $name cancel \;]
4618# puts stderr $cmd
4619 pd $cmd
4620}
4621
4622proc pdtk_canvas_dofont {name initsize} {
4623
4624 global fontsize
4625 set fontsize $initsize
4626
4627 global stretchval
4628 set stretchval 100
4629
4630 global whichstretch
4631 set whichstretch 1
4632
4633 toplevel $name
4634 wm title $name {FONT BOMB}
4635 wm protocol $name WM_DELETE_WINDOW [concat dofont_cancel $name]
4636
4637 frame $name.buttonframe
4638 pack $name.buttonframe -side bottom -fill x -pady 2m
4639 button $name.buttonframe.cancel -text {Cancel}\
4640 -command "dofont_cancel $name"
4641 button $name.buttonframe.ok -text {Do it}\
4642 -command "dofont_apply $name"
4643 pack $name.buttonframe.cancel -side left -expand 1
4644 pack $name.buttonframe.ok -side left -expand 1
4645
4646 frame $name.radiof
4647 pack $name.radiof -side left
4648
4649 label $name.radiof.label -text {Font Size:}
4650 pack $name.radiof.label -side top
4651
4652 radiobutton $name.radiof.radio8 -value 8 -variable fontsize -text "8"
4653 radiobutton $name.radiof.radio10 -value 10 -variable fontsize -text "10"
4654 radiobutton $name.radiof.radio12 -value 12 -variable fontsize -text "12"
4655 radiobutton $name.radiof.radio16 -value 16 -variable fontsize -text "16"
4656 radiobutton $name.radiof.radio24 -value 24 -variable fontsize -text "24"
4657 radiobutton $name.radiof.radio36 -value 36 -variable fontsize -text "36"
4658 pack $name.radiof.radio8 -side top -anchor w
4659 pack $name.radiof.radio10 -side top -anchor w
4660 pack $name.radiof.radio12 -side top -anchor w
4661 pack $name.radiof.radio16 -side top -anchor w
4662 pack $name.radiof.radio24 -side top -anchor w
4663 pack $name.radiof.radio36 -side top -anchor w
4664
4665 frame $name.stretchf
4666 pack $name.stretchf -side left
4667
4668 label $name.stretchf.label -text {Stretch:}
4669 pack $name.stretchf.label -side top
4670
4671 entry $name.stretchf.entry -textvariable stretchval -width 5
4672 pack $name.stretchf.entry -side left
4673
4674 radiobutton $name.stretchf.radio1 \
4675 -value 1 -variable whichstretch -text "X and Y"
4676 radiobutton $name.stretchf.radio2 \
4677 -value 2 -variable whichstretch -text "X only"
4678 radiobutton $name.stretchf.radio3 \
4679 -value 3 -variable whichstretch -text "Y only"
4680
4681 pack $name.stretchf.radio1 -side top -anchor w
4682 pack $name.stretchf.radio2 -side top -anchor w
4683 pack $name.stretchf.radio3 -side top -anchor w
4684
4685}
4686
4687############ pdtk_gatom_dialog -- run a gatom dialog #########
4688
4689# see graph_apply, etc., for comments about handling variable names here...
4690
4691proc gatom_escape {sym} {
4692 if {[string length $sym] == 0} {
4693 set ret "-"
4694# puts stderr [concat escape1 $sym $ret]
4695 } else {
4696 if {[string equal -length 1 $sym "-"]} {
4697 set ret [string replace $sym 0 0 "--"]
4698# puts stderr [concat escape $sym $ret]
4699 } else {
4700 if {[string equal -length 1 $sym "$"]} {
4701 set ret [string replace $sym 0 0 "#"]
4702# puts stderr [concat unescape $sym $ret]
4703 } else {
4704 set ret $sym
4705# puts stderr [concat escape $sym "no change"]
4706 }
4707 }
4708 }
4709 concat $ret
4710}
4711
4712proc gatom_unescape {sym} {
4713 if {[string equal -length 1 $sym "-"]} {
4714 set ret [string replace $sym 0 0 ""]
4715# puts stderr [concat unescape $sym $ret]
4716 } else {
4717 if {[string equal -length 1 $sym "#"]} {
4718 set ret [string replace $sym 0 0 "$"]
4719# puts stderr [concat unescape $sym $ret]
4720 } else {
4721 set ret $sym
4722# puts stderr [concat unescape $sym "no change"]
4723 }
4724 }
4725 concat $ret
4726}
4727
4728proc dogatom_apply {id} {
4729 set vid [string trimleft $id .]
4730
4731 set var_gatomwidth [concat gatomwidth_$vid]
4732 global $var_gatomwidth
4733 set var_gatomlo [concat gatomlo_$vid]
4734 global $var_gatomlo
4735 set var_gatomhi [concat gatomhi_$vid]
4736 global $var_gatomhi
4737 set var_gatomwherelabel [concat gatomwherelabel_$vid]
4738 global $var_gatomwherelabel
4739 set var_gatomlabel [concat gatomlabel_$vid]
4740 global $var_gatomlabel
4741 set var_gatomsymfrom [concat gatomsymfrom_$vid]
4742 global $var_gatomsymfrom
4743 set var_gatomsymto [concat gatomsymto_$vid]
4744 global $var_gatomsymto
4745
4746# set cmd [concat $id param $gatomwidth $gatomlo $gatomhi \;]
4747
4748 set cmd [concat $id param \
4749 [eval concat $$var_gatomwidth] \
4750 [eval concat $$var_gatomlo] \
4751 [eval concat $$var_gatomhi] \
4752 [eval gatom_escape $$var_gatomlabel] \
4753 [eval concat $$var_gatomwherelabel] \
4754 [eval gatom_escape $$var_gatomsymfrom] \
4755 [eval gatom_escape $$var_gatomsymto] \
4756 \;]
4757
4758# puts stderr $cmd
4759 pd $cmd
4760}
4761
4762proc dogatom_cancel {name} {
4763 set cmd [concat $name cancel \;]
4764# puts stderr $cmd
4765 pd $cmd
4766}
4767
4768proc dogatom_ok {name} {
4769 dogatom_apply $name
4770 dogatom_cancel $name
4771}
4772
4773proc pdtk_gatom_dialog {id initwidth initlo inithi \
4774 wherelabel label symfrom symto} {
4775
4776 set vid [string trimleft $id .]
4777
4778 set var_gatomwidth [concat gatomwidth_$vid]
4779 global $var_gatomwidth
4780 set var_gatomlo [concat gatomlo_$vid]
4781 global $var_gatomlo
4782 set var_gatomhi [concat gatomhi_$vid]
4783 global $var_gatomhi
4784 set var_gatomwherelabel [concat gatomwherelabel_$vid]
4785 global $var_gatomwherelabel
4786 set var_gatomlabel [concat gatomlabel_$vid]
4787 global $var_gatomlabel
4788 set var_gatomsymfrom [concat gatomsymfrom_$vid]
4789 global $var_gatomsymfrom
4790 set var_gatomsymto [concat gatomsymto_$vid]
4791 global $var_gatomsymto
4792
4793 set $var_gatomwidth $initwidth
4794 set $var_gatomlo $initlo
4795 set $var_gatomhi $inithi
4796 set $var_gatomwherelabel $wherelabel
4797 set $var_gatomlabel [gatom_unescape $label]
4798 set $var_gatomsymfrom [gatom_unescape $symfrom]
4799 set $var_gatomsymto [gatom_unescape $symto]
4800
4801 toplevel $id
4802 wm title $id {Atom}
4803 wm protocol $id WM_DELETE_WINDOW [concat dogatom_cancel $id]
4804
4805 frame $id.buttonframe
4806 pack $id.buttonframe -side bottom -fill x -pady 2m
4807 button $id.buttonframe.cancel -text {Cancel}\
4808 -command "dogatom_cancel $id"
4809 button $id.buttonframe.apply -text {Apply}\
4810 -command "dogatom_apply $id"
4811 button $id.buttonframe.ok -text {OK}\
4812 -command "dogatom_ok $id"
4813 pack $id.buttonframe.cancel -side left -expand 1
4814 pack $id.buttonframe.apply -side left -expand 1
4815 pack $id.buttonframe.ok -side left -expand 1
4816
4817 frame $id.paramsymto
4818 pack $id.paramsymto -side bottom
4819 label $id.paramsymto.entryname -text {send symbol}
4820 entry $id.paramsymto.entry -textvariable $var_gatomsymto -width 20
4821 pack $id.paramsymto.entryname $id.paramsymto.entry -side left
4822
4823 frame $id.paramsymfrom
4824 pack $id.paramsymfrom -side bottom
4825 label $id.paramsymfrom.entryname -text {receive symbol}
4826 entry $id.paramsymfrom.entry -textvariable $var_gatomsymfrom -width 20
4827 pack $id.paramsymfrom.entryname $id.paramsymfrom.entry -side left
4828
4829 frame $id.radio
4830 pack $id.radio -side bottom
4831 label $id.radio.label -text {show label on:}
4832 frame $id.radio.l
4833 frame $id.radio.r
4834 pack $id.radio.label -side top
4835 pack $id.radio.l $id.radio.r -side left
4836 radiobutton $id.radio.l.radio0 -value 0 \
4837 -variable $var_gatomwherelabel \
4838 -text "left"
4839 radiobutton $id.radio.l.radio1 -value 1 \
4840 -variable $var_gatomwherelabel \
4841 -text "right"
4842 radiobutton $id.radio.r.radio2 -value 2 \
4843 -variable $var_gatomwherelabel \
4844 -text "top"
4845 radiobutton $id.radio.r.radio3 -value 3 \
4846 -variable $var_gatomwherelabel \
4847 -text "bottom"
4848 pack $id.radio.l.radio0 $id.radio.l.radio1 -side top -anchor w
4849 pack $id.radio.r.radio2 $id.radio.r.radio3 -side top -anchor w
4850
4851
4852 frame $id.paramlabel
4853 pack $id.paramlabel -side bottom
4854 label $id.paramlabel.entryname -text label
4855 entry $id.paramlabel.entry -textvariable $var_gatomlabel -width 20
4856 pack $id.paramlabel.entryname $id.paramlabel.entry -side left
4857
4858 frame $id.paramhi
4859 pack $id.paramhi -side bottom
4860 label $id.paramhi.entryname -text "upper limit"
4861 entry $id.paramhi.entry -textvariable $var_gatomhi -width 8
4862 pack $id.paramhi.entryname $id.paramhi.entry -side left
4863
4864 frame $id.paramlo
4865 pack $id.paramlo -side bottom
4866 label $id.paramlo.entryname -text "lower limit"
4867 entry $id.paramlo.entry -textvariable $var_gatomlo -width 8
4868 pack $id.paramlo.entryname $id.paramlo.entry -side left
4869
4870 frame $id.params
4871 pack $id.params -side bottom
4872 label $id.params.entryname -text width
4873 entry $id.params.entry -textvariable $var_gatomwidth -width 4
4874 pack $id.params.entryname $id.params.entry -side left
4875
4876
4877
4878 bind $id.paramhi.entry <KeyPress-Return> [concat dogatom_ok $id]
4879 bind $id.paramlo.entry <KeyPress-Return> [concat dogatom_ok $id]
4880 bind $id.params.entry <KeyPress-Return> [concat dogatom_ok $id]
4881 $id.params.entry select from 0
4882 $id.params.entry select adjust end
4883 focus $id.params.entry
4884}
4885
4886############ pdtk_canvas_popup -- popup menu for canvas #########
4887
4888set popup_xpix 0
4889set popup_ypix 0
4890
4891proc popup_action {name action} {
4892 global popup_xpix popup_ypix
4893 set cmd [concat $name done-popup $action $popup_xpix $popup_ypix \;]
4894# puts stderr $cmd
4895 pd $cmd
4896}
4897
4898proc pdtk_canvas_popup {name xpix ypix canprop canopen} {
4899 global popup_xpix popup_ypix
4900 set popup_xpix $xpix
4901 set popup_ypix $ypix
4902 if {$canprop == 0} {$name.popup entryconfigure 0 -state disabled}
4903 if {$canprop == 1} {$name.popup entryconfigure 0 -state active}
4904 if {$canopen == 0} {$name.popup entryconfigure 1 -state disabled}
4905 if {$canopen == 1} {$name.popup entryconfigure 1 -state active}
4906 tk_popup $name.popup [expr $xpix + [winfo rootx $name.c]] \
4907 [expr $ypix + [winfo rooty $name.c]] 0
4908}
4909
4910############ pdtk_graph_dialog -- dialog window for graphs #########
4911
4912# the graph and array dialogs can come up in many copies; but in TK the easiest
4913# way to get data from an "entry", etc., is to set an associated variable
4914# name. This is especially true for grouped "radio buttons". So we have
4915# to synthesize variable names for each instance of the dialog. The dialog
4916# gets a TK pathname $id, from which it strips the leading "." to make a
4917# variable suffix $vid. Then you can get the actual value out by asking for
4918# [eval concat $$variablename]. There should be an easier way but I don't see
4919# it yet.
4920
4921proc graph_apply {id} {
4922# strip "." from the TK id to make a variable name suffix
4923 set vid [string trimleft $id .]
4924# for each variable, make a local variable to hold its name...
4925 set var_graph_x1 [concat graph_x1_$vid]
4926 global $var_graph_x1
4927 set var_graph_x2 [concat graph_x2_$vid]
4928 global $var_graph_x2
4929 set var_graph_xpix [concat graph_xpix_$vid]
4930 global $var_graph_xpix
4931 set var_graph_y1 [concat graph_y1_$vid]
4932 global $var_graph_y1
4933 set var_graph_y2 [concat graph_y2_$vid]
4934 global $var_graph_y2
4935 set var_graph_ypix [concat graph_ypix_$vid]
4936 global $var_graph_ypix
4937
4938 pd [concat $id dialog \
4939 [eval concat $$var_graph_x1] \
4940 [eval concat $$var_graph_y1] \
4941 [eval concat $$var_graph_x2] \
4942 [eval concat $$var_graph_y2] \
4943 [eval concat $$var_graph_xpix] \
4944 [eval concat $$var_graph_ypix] \
4945 \;]
4946}
4947
4948proc graph_cancel {id} {
4949 set cmd [concat $id cancel \;]
4950# puts stderr $cmd
4951 pd $cmd
4952}
4953
4954proc graph_ok {id} {
4955 graph_apply $id
4956 graph_cancel $id
4957}
4958
4959proc pdtk_graph_dialog {id x1 y1 x2 y2 xpix ypix} {
4960 set vid [string trimleft $id .]
4961 set var_graph_x1 [concat graph_x1_$vid]
4962 global $var_graph_x1
4963 set var_graph_x2 [concat graph_x2_$vid]
4964 global $var_graph_x2
4965 set var_graph_xpix [concat graph_xpix_$vid]
4966 global $var_graph_xpix
4967 set var_graph_y1 [concat graph_y1_$vid]
4968 global $var_graph_y1
4969 set var_graph_y2 [concat graph_y2_$vid]
4970 global $var_graph_y2
4971 set var_graph_ypix [concat graph_ypix_$vid]
4972 global $var_graph_ypix
4973
4974 set $var_graph_x1 $x1
4975 set $var_graph_x2 $x2
4976 set $var_graph_xpix $xpix
4977 set $var_graph_y1 $y1
4978 set $var_graph_y2 $y2
4979 set $var_graph_ypix $ypix
4980
4981 toplevel $id
4982 wm title $id {graph}
4983 wm protocol $id WM_DELETE_WINDOW [concat graph_cancel $id]
4984
4985 label $id.label -text {GRAPH BOUNDS}
4986 pack $id.label -side top
4987
4988 frame $id.buttonframe
4989 pack $id.buttonframe -side bottom -fill x -pady 2m
4990 button $id.buttonframe.cancel -text {Cancel}\
4991 -command "graph_cancel $id"
4992 button $id.buttonframe.apply -text {Apply}\
4993 -command "graph_apply $id"
4994 button $id.buttonframe.ok -text {OK}\
4995 -command "graph_ok $id"
4996 pack $id.buttonframe.cancel -side left -expand 1
4997 pack $id.buttonframe.apply -side left -expand 1
4998 pack $id.buttonframe.ok -side left -expand 1
4999
5000 frame $id.xrangef
5001 pack $id.xrangef -side top
5002
5003 label $id.xrangef.l1 -text "X from:"
5004 entry $id.xrangef.x1 -textvariable $var_graph_x1 -width 7
5005 label $id.xrangef.l2 -text "to:"
5006 entry $id.xrangef.x2 -textvariable $var_graph_x2 -width 7
5007 label $id.xrangef.l3 -text "screen width:"
5008 entry $id.xrangef.xpix -textvariable $var_graph_xpix -width 7
5009 pack $id.xrangef.l1 $id.xrangef.x1 \
5010 $id.xrangef.l2 $id.xrangef.x2 \
5011 $id.xrangef.l3 $id.xrangef.xpix -side left
5012
5013 frame $id.yrangef
5014 pack $id.yrangef -side top
5015
5016# dig in the following that the upper bound is labeled y1 but the variable is
5017# y2, etc. This is to deal with the inconsistent use of "upper and lower"
5018# graph bounds... in the dialog the upper Y bound is the lower valued Y pixel.
5019 label $id.yrangef.l1 -text "Y from:"
5020 entry $id.yrangef.y1 -textvariable $var_graph_y2 -width 7
5021 label $id.yrangef.l2 -text "to:"
5022 entry $id.yrangef.y2 -textvariable $var_graph_y1 -width 7
5023 label $id.yrangef.l3 -text "screen height:"
5024 entry $id.yrangef.ypix -textvariable $var_graph_ypix -width 7
5025 pack $id.yrangef.l1 $id.yrangef.y1 \
5026 $id.yrangef.l2 $id.yrangef.y2 \
5027 $id.yrangef.l3 $id.yrangef.ypix -side left
5028
5029 bind $id.xrangef.x1 <KeyPress-Return> [concat graph_ok $id]
5030 bind $id.xrangef.x2 <KeyPress-Return> [concat graph_ok $id]
5031 bind $id.xrangef.xpix <KeyPress-Return> [concat graph_ok $id]
5032 bind $id.yrangef.y1 <KeyPress-Return> [concat graph_ok $id]
5033 bind $id.yrangef.y2 <KeyPress-Return> [concat graph_ok $id]
5034 bind $id.yrangef.ypix <KeyPress-Return> [concat graph_ok $id]
5035 $id.xrangef.x2 select from 0
5036 $id.xrangef.x2 select adjust end
5037 focus $id.xrangef.x2
5038}
5039
5040# begin of change "iemlib"
5041############ pdtk_iemgui_dialog -- dialog window for iem guis #########
5042
5043set iemgui_define_min_flashhold 50
5044set iemgui_define_min_flashbreak 10
5045set iemgui_define_min_fontsize 4
5046
5047proc iemgui_clip_dim {id} {
5048 set vid [string trimleft $id .]
5049
5050 set var_iemgui_wdt [concat iemgui_wdt_$vid]
5051 global $var_iemgui_wdt
5052 set var_iemgui_min_wdt [concat iemgui_min_wdt_$vid]
5053 global $var_iemgui_min_wdt
5054 set var_iemgui_hgt [concat iemgui_hgt_$vid]
5055 global $var_iemgui_hgt
5056 set var_iemgui_min_hgt [concat iemgui_min_hgt_$vid]
5057 global $var_iemgui_min_hgt
5058
5059 if {[eval concat $$var_iemgui_wdt] < [eval concat $$var_iemgui_min_wdt]} {
5060 set $var_iemgui_wdt [eval concat $$var_iemgui_min_wdt]
5061 $id.dim.w_ent configure -textvariable $var_iemgui_wdt
5062 }
5063 if {[eval concat $$var_iemgui_hgt] < [eval concat $$var_iemgui_min_hgt]} {
5064 set $var_iemgui_hgt [eval concat $$var_iemgui_min_hgt]
5065 $id.dim.h_ent configure -textvariable $var_iemgui_hgt
5066 }
5067}
5068
5069proc iemgui_clip_num {id} {
5070 set vid [string trimleft $id .]
5071
5072 set var_iemgui_num [concat iemgui_num_$vid]
5073 global $var_iemgui_num
5074
5075 if {[eval concat $$var_iemgui_num] > 2000} {
5076 set $var_iemgui_num 2000
5077 $id.para.num_ent configure -textvariable $var_iemgui_num
5078 }
5079 if {[eval concat $$var_iemgui_num] < 1} {
5080 set $var_iemgui_num 1
5081 $id.para.num_ent configure -textvariable $var_iemgui_num
5082 }
5083}
5084
5085proc iemgui_sched_rng {id} {
5086 set vid [string trimleft $id .]
5087
5088 set var_iemgui_min_rng [concat iemgui_min_rng_$vid]
5089 global $var_iemgui_min_rng
5090 set var_iemgui_max_rng [concat iemgui_max_rng_$vid]
5091 global $var_iemgui_max_rng
5092 set var_iemgui_rng_sch [concat iemgui_rng_sch_$vid]
5093 global $var_iemgui_rng_sch
5094
5095 global iemgui_define_min_flashhold
5096 global iemgui_define_min_flashbreak
5097
5098 if {[eval concat $$var_iemgui_rng_sch] == 2} {
5099 if {[eval concat $$var_iemgui_max_rng] < [eval concat $$var_iemgui_min_rng]} {
5100 set hhh [eval concat $$var_iemgui_min_rng]
5101 set $var_iemgui_min_rng [eval concat $$var_iemgui_max_rng]
5102 set $var_iemgui_max_rng $hhh
5103 $id.rng.max_ent configure -textvariable $var_iemgui_max_rng
5104 $id.rng.min_ent configure -textvariable $var_iemgui_min_rng }
5105 if {[eval concat $$var_iemgui_max_rng] < $iemgui_define_min_flashhold} {
5106 set $var_iemgui_max_rng $iemgui_define_min_flashhold
5107 $id.rng.max_ent configure -textvariable $var_iemgui_max_rng
5108 }
5109 if {[eval concat $$var_iemgui_min_rng] < $iemgui_define_min_flashbreak} {
5110 set $var_iemgui_min_rng $iemgui_define_min_flashbreak
5111 $id.rng.min_ent configure -textvariable $var_iemgui_min_rng
5112 }
5113 }
5114 if {[eval concat $$var_iemgui_rng_sch] == 1} {
5115 if {[eval concat $$var_iemgui_min_rng] == 0.0} {
5116 set $var_iemgui_min_rng 1.0
5117 $id.rng.min_ent configure -textvariable $var_iemgui_min_rng
5118 }
5119 }
5120}
5121
5122proc iemgui_verify_rng {id} {
5123 set vid [string trimleft $id .]
5124
5125 set var_iemgui_min_rng [concat iemgui_min_rng_$vid]
5126 global $var_iemgui_min_rng
5127 set var_iemgui_max_rng [concat iemgui_max_rng_$vid]
5128 global $var_iemgui_max_rng
5129 set var_iemgui_lin0_log1 [concat iemgui_lin0_log1_$vid]
5130 global $var_iemgui_lin0_log1
5131
5132 if {[eval concat $$var_iemgui_lin0_log1] == 1} {
5133 if {[eval concat $$var_iemgui_max_rng] == 0.0 && [eval concat $$var_iemgui_min_rng] == 0.0} {
5134 set $var_iemgui_max_rng 1.0
5135 $id.rng.max_ent configure -textvariable $var_iemgui_max_rng
5136 }
5137 if {[eval concat $$var_iemgui_max_rng] > 0} {
5138 if {[eval concat $$var_iemgui_min_rng] <= 0} {
5139 set $var_iemgui_min_rng [expr [eval concat $$var_iemgui_max_rng] * 0.01]
5140 $id.rng.min_ent configure -textvariable $var_iemgui_min_rng
5141 }
5142 } else {
5143 if {[eval concat $$var_iemgui_min_rng] > 0} {
5144 set $var_iemgui_max_rng [expr [eval concat $$var_iemgui_min_rng] * 0.01]
5145 $id.rng.max_ent configure -textvariable $var_iemgui_max_rng
5146 }
5147 }
5148 }
5149}
5150
5151proc iemgui_clip_fontsize {id} {
5152 set vid [string trimleft $id .]
5153
5154 set var_iemgui_gn_fs [concat iemgui_gn_fs_$vid]
5155 global $var_iemgui_gn_fs
5156
5157 global iemgui_define_min_fontsize
5158
5159 if {[eval concat $$var_iemgui_gn_fs] < $iemgui_define_min_fontsize} {
5160 set $var_iemgui_gn_fs $iemgui_define_min_fontsize
5161 $id.gnfs.fs_ent configure -textvariable $var_iemgui_gn_fs
5162 }
5163}
5164
5165proc iemgui_set_col_example {id} {
5166 set vid [string trimleft $id .]
5167
5168 set var_iemgui_bcol [concat iemgui_bcol_$vid]
5169 global $var_iemgui_bcol
5170 set var_iemgui_fcol [concat iemgui_fcol_$vid]
5171 global $var_iemgui_fcol
5172 set var_iemgui_lcol [concat iemgui_lcol_$vid]
5173 global $var_iemgui_lcol
5174
5175 $id.col_example_choose.lb_bk configure \
5176 -background [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
5177 -activebackground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
5178 -foreground [format "#%6.6x" [eval concat $$var_iemgui_lcol]] \
5179 -activeforeground [format "#%6.6x" [eval concat $$var_iemgui_lcol]]
5180
5181 if { [eval concat $$var_iemgui_fcol] >= 0 } {
5182 $id.col_example_choose.fr_bk configure \
5183 -background [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
5184 -activebackground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
5185 -foreground [format "#%6.6x" [eval concat $$var_iemgui_fcol]] \
5186 -activeforeground [format "#%6.6x" [eval concat $$var_iemgui_fcol]]
5187 } else {
5188 $id.col_example_choose.fr_bk configure \
5189 -background [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
5190 -activebackground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
5191 -foreground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
5192 -activeforeground [format "#%6.6x" [eval concat $$var_iemgui_bcol]]}
5193}
5194
5195proc iemgui_preset_col {id presetcol} {
5196 set vid [string trimleft $id .]
5197
5198 set var_iemgui_l2_f1_b0 [concat iemgui_l2_f1_b0_$vid]
5199 global $var_iemgui_l2_f1_b0
5200 set var_iemgui_bcol [concat iemgui_bcol_$vid]
5201 global $var_iemgui_bcol
5202 set var_iemgui_fcol [concat iemgui_fcol_$vid]
5203 global $var_iemgui_fcol
5204 set var_iemgui_lcol [concat iemgui_lcol_$vid]
5205 global $var_iemgui_lcol
5206
5207 if { [eval concat $$var_iemgui_l2_f1_b0] == 0 } { set $var_iemgui_bcol $presetcol }
5208 if { [eval concat $$var_iemgui_l2_f1_b0] == 1 } { set $var_iemgui_fcol $presetcol }
5209 if { [eval concat $$var_iemgui_l2_f1_b0] == 2 } { set $var_iemgui_lcol $presetcol }
5210 iemgui_set_col_example $id
5211}
5212
5213proc iemgui_choose_col_bkfrlb {id} {
5214 set vid [string trimleft $id .]
5215
5216 set var_iemgui_l2_f1_b0 [concat iemgui_l2_f1_b0_$vid]
5217 global $var_iemgui_l2_f1_b0
5218 set var_iemgui_bcol [concat iemgui_bcol_$vid]
5219 global $var_iemgui_bcol
5220 set var_iemgui_fcol [concat iemgui_fcol_$vid]
5221 global $var_iemgui_fcol
5222 set var_iemgui_lcol [concat iemgui_lcol_$vid]
5223 global $var_iemgui_lcol
5224
5225 if {[eval concat $$var_iemgui_l2_f1_b0] == 0} {
5226 set $var_iemgui_bcol [expr [eval concat $$var_iemgui_bcol] & 0xFCFCFC]
5227 set helpstring [tk_chooseColor -title "Background-Color" -initialcolor [format "#%6.6x" [eval concat $$var_iemgui_bcol]]]
5228 if { $helpstring != "" } {
5229 set $var_iemgui_bcol [string replace $helpstring 0 0 "0x"]
5230 set $var_iemgui_bcol [expr [eval concat $$var_iemgui_bcol] & 0xFCFCFC] }
5231 }
5232 if {[eval concat $$var_iemgui_l2_f1_b0] == 1} {
5233 set $var_iemgui_fcol [expr [eval concat $$var_iemgui_fcol] & 0xFCFCFC]
5234 set helpstring [tk_chooseColor -title "Front-Color" -initialcolor [format "#%6.6x" [eval concat $$var_iemgui_fcol]]]
5235 if { $helpstring != "" } {
5236 set $var_iemgui_fcol [string replace $helpstring 0 0 "0x"]
5237 set $var_iemgui_fcol [expr [eval concat $$var_iemgui_fcol] & 0xFCFCFC] }
5238 }
5239 if {[eval concat $$var_iemgui_l2_f1_b0] == 2} {
5240 set $var_iemgui_lcol [expr [eval concat $$var_iemgui_lcol] & 0xFCFCFC]
5241 set helpstring [tk_chooseColor -title "Label-Color" -initialcolor [format "#%6.6x" [eval concat $$var_iemgui_lcol]]]
5242 if { $helpstring != "" } {
5243 set $var_iemgui_lcol [string replace $helpstring 0 0 "0x"]
5244 set $var_iemgui_lcol [expr [eval concat $$var_iemgui_lcol] & 0xFCFCFC] }
5245 }
5246 iemgui_set_col_example $id
5247}
5248
5249proc iemgui_lilo {id} {
5250 set vid [string trimleft $id .]
5251
5252 set var_iemgui_lin0_log1 [concat iemgui_lin0_log1_$vid]
5253 global $var_iemgui_lin0_log1
5254 set var_iemgui_lilo0 [concat iemgui_lilo0_$vid]
5255 global $var_iemgui_lilo0
5256 set var_iemgui_lilo1 [concat iemgui_lilo1_$vid]
5257 global $var_iemgui_lilo1
5258
5259 iemgui_sched_rng $id
5260
5261 if {[eval concat $$var_iemgui_lin0_log1] == 0} {
5262 set $var_iemgui_lin0_log1 1
5263 $id.para.lilo configure -text [eval concat $$var_iemgui_lilo1]
5264 iemgui_verify_rng $id
5265 iemgui_sched_rng $id
5266 } else {
5267 set $var_iemgui_lin0_log1 0
5268 $id.para.lilo configure -text [eval concat $$var_iemgui_lilo0]
5269 }
5270}
5271
5272proc iemgui_toggle_font {id} {
5273 set vid [string trimleft $id .]
5274
5275 set var_iemgui_gn_f [concat iemgui_gn_f_$vid]
5276 global $var_iemgui_gn_f
5277
5278 set $var_iemgui_gn_f [expr [eval concat $$var_iemgui_gn_f] + 1]
5279 if {[eval concat $$var_iemgui_gn_f] > 2} {set $var_iemgui_gn_f 0}
5280 if {[eval concat $$var_iemgui_gn_f] == 0} {$id.gnfs.fb configure -text "courier" -font {courier 10 bold}}
5281 if {[eval concat $$var_iemgui_gn_f] == 1} {$id.gnfs.fb configure -text "helvetica" -font {helvetica 10 bold}}
5282 if {[eval concat $$var_iemgui_gn_f] == 2} {$id.gnfs.fb configure -text "times" -font {times 10 bold}}
5283}
5284
5285proc iemgui_lb {id} {
5286 set vid [string trimleft $id .]
5287
5288 set var_iemgui_loadbang [concat iemgui_loadbang_$vid]
5289 global $var_iemgui_loadbang
5290
5291 if {[eval concat $$var_iemgui_loadbang] == 0} {
5292 set $var_iemgui_loadbang 1
5293 $id.para.lb configure -text "init"
5294 } else {
5295 set $var_iemgui_loadbang 0
5296 $id.para.lb configure -text "no init"
5297 }
5298}
5299
5300proc iemgui_stdy_jmp {id} {
5301 set vid [string trimleft $id .]
5302
5303 set var_iemgui_steady [concat iemgui_steady_$vid]
5304 global $var_iemgui_steady
5305
5306 if {[eval concat $$var_iemgui_steady]} {
5307 set $var_iemgui_steady 0
5308 $id.para.stdy_jmp configure -text "jump on click"
5309 } else {
5310 set $var_iemgui_steady 1
5311 $id.para.stdy_jmp configure -text "steady on click"
5312 }
5313}
5314
5315proc iemgui_apply {id} {
5316 set vid [string trimleft $id .]
5317
5318 set var_iemgui_wdt [concat iemgui_wdt_$vid]
5319 global $var_iemgui_wdt
5320 set var_iemgui_min_wdt [concat iemgui_min_wdt_$vid]
5321 global $var_iemgui_min_wdt
5322 set var_iemgui_hgt [concat iemgui_hgt_$vid]
5323 global $var_iemgui_hgt
5324 set var_iemgui_min_hgt [concat iemgui_min_hgt_$vid]
5325 global $var_iemgui_min_hgt
5326 set var_iemgui_min_rng [concat iemgui_min_rng_$vid]
5327 global $var_iemgui_min_rng
5328 set var_iemgui_max_rng [concat iemgui_max_rng_$vid]
5329 global $var_iemgui_max_rng
5330 set var_iemgui_lin0_log1 [concat iemgui_lin0_log1_$vid]
5331 global $var_iemgui_lin0_log1
5332 set var_iemgui_lilo0 [concat iemgui_lilo0_$vid]
5333 global $var_iemgui_lilo0
5334 set var_iemgui_lilo1 [concat iemgui_lilo1_$vid]
5335 global $var_iemgui_lilo1
5336 set var_iemgui_loadbang [concat iemgui_loadbang_$vid]
5337 global $var_iemgui_loadbang
5338 set var_iemgui_num [concat iemgui_num_$vid]
5339 global $var_iemgui_num
5340 set var_iemgui_steady [concat iemgui_steady_$vid]
5341 global $var_iemgui_steady
5342 set var_iemgui_snd [concat iemgui_snd_$vid]
5343 global $var_iemgui_snd
5344 set var_iemgui_rcv [concat iemgui_rcv_$vid]
5345 global $var_iemgui_rcv
5346 set var_iemgui_gui_nam [concat iemgui_gui_nam_$vid]
5347 global $var_iemgui_gui_nam
5348 set var_iemgui_gn_dx [concat iemgui_gn_dx_$vid]
5349 global $var_iemgui_gn_dx
5350 set var_iemgui_gn_dy [concat iemgui_gn_dy_$vid]
5351 global $var_iemgui_gn_dy
5352 set var_iemgui_gn_f [concat iemgui_gn_f_$vid]
5353 global $var_iemgui_gn_f
5354 set var_iemgui_gn_fs [concat iemgui_gn_fs_$vid]
5355 global $var_iemgui_gn_fs
5356 set var_iemgui_bcol [concat iemgui_bcol_$vid]
5357 global $var_iemgui_bcol
5358 set var_iemgui_fcol [concat iemgui_fcol_$vid]
5359 global $var_iemgui_fcol
5360 set var_iemgui_lcol [concat iemgui_lcol_$vid]
5361 global $var_iemgui_lcol
5362
5363 iemgui_clip_dim $id
5364 iemgui_clip_num $id
5365 iemgui_sched_rng $id
5366 iemgui_verify_rng $id
5367 iemgui_sched_rng $id
5368 iemgui_clip_fontsize $id
5369
5370 if {[eval concat $$var_iemgui_snd] == ""} {set hhhsnd "empty"} else {set hhhsnd [eval concat $$var_iemgui_snd]}
5371 if {[eval concat $$var_iemgui_rcv] == ""} {set hhhrcv "empty"} else {set hhhrcv [eval concat $$var_iemgui_rcv]}
5372 if {[eval concat $$var_iemgui_gui_nam] == ""} {set hhhgui_nam "empty"
5373 } else {
5374 set hhhgui_nam [eval concat $$var_iemgui_gui_nam]}
5375
5376 if {[string index $hhhsnd 0] == "$"} {
5377 set hhhsnd [string replace $hhhsnd 0 0 #] }
5378 if {[string index $hhhrcv 0] == "$"} {
5379 set hhhrcv [string replace $hhhrcv 0 0 #] }
5380 if {[string index $hhhgui_nam 0] == "$"} {
5381 set hhhgui_nam [string replace $hhhgui_nam 0 0 #] }
5382
5383 set hhhsnd [string map {" " _} $hhhsnd]
5384 set hhhrcv [string map {" " _} $hhhrcv]
5385 set hhhgui_nam [string map {" " _} $hhhgui_nam]
5386
5387 pd [concat $id dialog \
5388 [eval concat $$var_iemgui_wdt] \
5389 [eval concat $$var_iemgui_hgt] \
5390 [eval concat $$var_iemgui_min_rng] \
5391 [eval concat $$var_iemgui_max_rng] \
5392 [eval concat $$var_iemgui_lin0_log1] \
5393 [eval concat $$var_iemgui_loadbang] \
5394 [eval concat $$var_iemgui_num] \
5395 $hhhsnd \
5396 $hhhrcv \
5397 $hhhgui_nam \
5398 [eval concat $$var_iemgui_gn_dx] \
5399 [eval concat $$var_iemgui_gn_dy] \
5400 [eval concat $$var_iemgui_gn_f] \
5401 [eval concat $$var_iemgui_gn_fs] \
5402 [eval concat $$var_iemgui_bcol] \
5403 [eval concat $$var_iemgui_fcol] \
5404 [eval concat $$var_iemgui_lcol] \
5405 [eval concat $$var_iemgui_steady] \
5406 \;]
5407}
5408
5409proc iemgui_cancel {id} {pd [concat $id cancel \;]}
5410
5411proc iemgui_ok {id} {
5412 iemgui_apply $id
5413 iemgui_cancel $id
5414}
5415
5416proc pdtk_iemgui_dialog {id mainheader \
5417 dim_header wdt min_wdt wdt_label hgt min_hgt hgt_label \
5418 rng_header min_rng min_rng_label max_rng max_rng_label rng_sched \
5419 lin0_log1 lilo0_label lilo1_label loadbang steady num_label num \
5420 snd rcv \
5421 gui_name \
5422 gn_dx gn_dy \
5423 gn_f gn_fs \
5424 bcol fcol lcol} {
5425
5426 set vid [string trimleft $id .]
5427
5428 set var_iemgui_wdt [concat iemgui_wdt_$vid]
5429 global $var_iemgui_wdt
5430 set var_iemgui_min_wdt [concat iemgui_min_wdt_$vid]
5431 global $var_iemgui_min_wdt
5432 set var_iemgui_hgt [concat iemgui_hgt_$vid]
5433 global $var_iemgui_hgt
5434 set var_iemgui_min_hgt [concat iemgui_min_hgt_$vid]
5435 global $var_iemgui_min_hgt
5436 set var_iemgui_min_rng [concat iemgui_min_rng_$vid]
5437 global $var_iemgui_min_rng
5438 set var_iemgui_max_rng [concat iemgui_max_rng_$vid]
5439 global $var_iemgui_max_rng
5440 set var_iemgui_rng_sch [concat iemgui_rng_sch_$vid]
5441 global $var_iemgui_rng_sch
5442 set var_iemgui_lin0_log1 [concat iemgui_lin0_log1_$vid]
5443 global $var_iemgui_lin0_log1
5444 set var_iemgui_lilo0 [concat iemgui_lilo0_$vid]
5445 global $var_iemgui_lilo0
5446 set var_iemgui_lilo1 [concat iemgui_lilo1_$vid]
5447 global $var_iemgui_lilo1
5448 set var_iemgui_loadbang [concat iemgui_loadbang_$vid]
5449 global $var_iemgui_loadbang
5450 set var_iemgui_num [concat iemgui_num_$vid]
5451 global $var_iemgui_num
5452 set var_iemgui_steady [concat iemgui_steady_$vid]
5453 global $var_iemgui_steady
5454 set var_iemgui_snd [concat iemgui_snd_$vid]
5455 global $var_iemgui_snd
5456 set var_iemgui_rcv [concat iemgui_rcv_$vid]
5457 global $var_iemgui_rcv
5458 set var_iemgui_gui_nam [concat iemgui_gui_nam_$vid]
5459 global $var_iemgui_gui_nam
5460 set var_iemgui_gn_dx [concat iemgui_gn_dx_$vid]
5461 global $var_iemgui_gn_dx
5462 set var_iemgui_gn_dy [concat iemgui_gn_dy_$vid]
5463 global $var_iemgui_gn_dy
5464 set var_iemgui_gn_f [concat iemgui_gn_f_$vid]
5465 global $var_iemgui_gn_f
5466 set var_iemgui_gn_fs [concat iemgui_gn_fs_$vid]
5467 global $var_iemgui_gn_fs
5468 set var_iemgui_l2_f1_b0 [concat iemgui_l2_f1_b0_$vid]
5469 global $var_iemgui_l2_f1_b0
5470 set var_iemgui_bcol [concat iemgui_bcol_$vid]
5471 global $var_iemgui_bcol
5472 set var_iemgui_fcol [concat iemgui_fcol_$vid]
5473 global $var_iemgui_fcol
5474 set var_iemgui_lcol [concat iemgui_lcol_$vid]
5475 global $var_iemgui_lcol
5476
5477 set $var_iemgui_wdt $wdt
5478 set $var_iemgui_min_wdt $min_wdt
5479 set $var_iemgui_hgt $hgt
5480 set $var_iemgui_min_hgt $min_hgt
5481 set $var_iemgui_min_rng $min_rng
5482 set $var_iemgui_max_rng $max_rng
5483 set $var_iemgui_rng_sch $rng_sched
5484 set $var_iemgui_lin0_log1 $lin0_log1
5485 set $var_iemgui_lilo0 $lilo0_label
5486 set $var_iemgui_lilo1 $lilo1_label
5487 set $var_iemgui_loadbang $loadbang
5488 set $var_iemgui_num $num
5489 set $var_iemgui_steady $steady
5490 if {$snd == "empty"} {set $var_iemgui_snd [format ""]
5491 } else {set $var_iemgui_snd [format "%s" $snd]}
5492 if {$rcv == "empty"} {set $var_iemgui_rcv [format ""]
5493 } else {set $var_iemgui_rcv [format "%s" $rcv]}
5494 if {$gui_name == "empty"} {set $var_iemgui_gui_nam [format ""]
5495 } else {set $var_iemgui_gui_nam [format "%s" $gui_name]}
5496
5497 if {[string index [eval concat $$var_iemgui_snd] 0] == "#"} {
5498 set $var_iemgui_snd [string replace [eval concat $$var_iemgui_snd] 0 0 $] }
5499 if {[string index [eval concat $$var_iemgui_rcv] 0] == "#"} {
5500 set $var_iemgui_rcv [string replace [eval concat $$var_iemgui_rcv] 0 0 $] }
5501 if {[string index [eval concat $$var_iemgui_gui_nam] 0] == "#"} {
5502 set $var_iemgui_gui_nam [string replace [eval concat $$var_iemgui_gui_nam] 0 0 $] }
5503 set $var_iemgui_gn_dx $gn_dx
5504 set $var_iemgui_gn_dy $gn_dy
5505 set $var_iemgui_gn_f $gn_f
5506 set $var_iemgui_gn_fs $gn_fs
5507
5508 set $var_iemgui_bcol $bcol
5509 set $var_iemgui_fcol $fcol
5510 set $var_iemgui_lcol $lcol
5511
5512 set $var_iemgui_l2_f1_b0 0
5513
5514 toplevel $id
5515 wm title $id [format "%s-PROPERTIES" $mainheader]
5516 wm protocol $id WM_DELETE_WINDOW [concat iemgui_cancel $id]
5517
5518 frame $id.dim
5519 pack $id.dim -side top
5520 label $id.dim.head -text $dim_header
5521 label $id.dim.w_lab -text $wdt_label -width 6
5522 entry $id.dim.w_ent -textvariable $var_iemgui_wdt -width 5
5523 label $id.dim.dummy1 -text " " -width 10
5524 label $id.dim.h_lab -text $hgt_label -width 6
5525 entry $id.dim.h_ent -textvariable $var_iemgui_hgt -width 5
5526 pack $id.dim.head -side top
5527 pack $id.dim.w_lab $id.dim.w_ent $id.dim.dummy1 -side left
5528 if { $hgt_label != "empty" } {
5529 pack $id.dim.h_lab $id.dim.h_ent -side left}
5530
5531 frame $id.rng
5532 pack $id.rng -side top
5533 label $id.rng.head -text $rng_header
5534 label $id.rng.min_lab -text $min_rng_label -width 6
5535 entry $id.rng.min_ent -textvariable $var_iemgui_min_rng -width 9
5536 label $id.rng.dummy1 -text " " -width 1
5537 label $id.rng.max_lab -text $max_rng_label -width 8
5538 entry $id.rng.max_ent -textvariable $var_iemgui_max_rng -width 9
5539 if { $rng_header != "empty" } {
5540 pack $id.rng.head -side top
5541 if { $min_rng_label != "empty" } {
5542 pack $id.rng.min_lab $id.rng.min_ent -side left}
5543 if { $max_rng_label != "empty" } {
5544 pack $id.rng.dummy1 \
5545 $id.rng.max_lab $id.rng.max_ent -side left} }
5546
5547 if { [eval concat $$var_iemgui_lin0_log1] >= 0 || [eval concat $$var_iemgui_loadbang] >= 0 || [eval concat $$var_iemgui_num] > 0 || [eval concat $$var_iemgui_steady] >= 0 } {
5548 label $id.space1 -text "---------------------------------"
5549 pack $id.space1 -side top }
5550
5551 frame $id.para
5552 pack $id.para -side top
5553 label $id.para.dummy2 -text "" -width 1
5554 label $id.para.dummy3 -text "" -width 1
5555 if {[eval concat $$var_iemgui_lin0_log1] == 0} {
5556 button $id.para.lilo -text [eval concat $$var_iemgui_lilo0] -width 5 -command "iemgui_lilo $id" }
5557 if {[eval concat $$var_iemgui_lin0_log1] == 1} {
5558 button $id.para.lilo -text [eval concat $$var_iemgui_lilo1] -width 5 -command "iemgui_lilo $id" }
5559 if {[eval concat $$var_iemgui_loadbang] == 0} {
5560 button $id.para.lb -text "no init" -width 5 -command "iemgui_lb $id" }
5561 if {[eval concat $$var_iemgui_loadbang] == 1} {
5562 button $id.para.lb -text "init" -width 5 -command "iemgui_lb $id" }
5563 label $id.para.num_lab -text $num_label -width 9
5564 entry $id.para.num_ent -textvariable $var_iemgui_num -width 4
5565 if {[eval concat $$var_iemgui_steady] == 0} {
5566 button $id.para.stdy_jmp -text "jump on click" -width 11 -command "iemgui_stdy_jmp $id" }
5567 if {[eval concat $$var_iemgui_steady] == 1} {
5568 button $id.para.stdy_jmp -text "steady on click" -width 11 -command "iemgui_stdy_jmp $id" }
5569 if {[eval concat $$var_iemgui_lin0_log1] >= 0} {
5570 pack $id.para.lilo -side left -expand 1}
5571 if {[eval concat $$var_iemgui_loadbang] >= 0} {
5572 pack $id.para.dummy2 $id.para.lb -side left -expand 1}
5573 if {[eval concat $$var_iemgui_num] > 0} {
5574 pack $id.para.dummy3 $id.para.num_lab $id.para.num_ent -side left -expand 1}
5575 if {[eval concat $$var_iemgui_steady] >= 0} {
5576 pack $id.para.dummy3 $id.para.stdy_jmp -side left -expand 1}
5577 if { $snd != "nosndno" || $rcv != "norcvno" } {
5578 label $id.space2 -text "---------------------------------"
5579 pack $id.space2 -side top }
5580
5581 frame $id.snd
5582 pack $id.snd -side top
5583 label $id.snd.dummy1 -text "" -width 2
5584 label $id.snd.lab -text "send-symbol:" -width 12
5585 entry $id.snd.ent -textvariable $var_iemgui_snd -width 20
5586 if { $snd != "nosndno" } {
5587 pack $id.snd.dummy1 $id.snd.lab $id.snd.ent -side left}
5588
5589 frame $id.rcv
5590 pack $id.rcv -side top
5591 label $id.rcv.lab -text "receive-symbol:" -width 15
5592 entry $id.rcv.ent -textvariable $var_iemgui_rcv -width 20
5593 if { $rcv != "norcvno" } {
5594 pack $id.rcv.lab $id.rcv.ent -side left}
5595
5596 frame $id.gnam
5597 pack $id.gnam -side top
5598 label $id.gnam.head -text "--------------label:---------------"
5599 label $id.gnam.dummy1 -text "" -width 1
5600 label $id.gnam.lab -text "name:" -width 6
5601 entry $id.gnam.ent -textvariable $var_iemgui_gui_nam -width 29
5602 label $id.gnam.dummy2 -text "" -width 1
5603 pack $id.gnam.head -side top
5604 pack $id.gnam.dummy1 $id.gnam.lab $id.gnam.ent $id.gnam.dummy2 -side left
5605
5606 frame $id.gnxy
5607 pack $id.gnxy -side top
5608 label $id.gnxy.x_lab -text "x_off:" -width 6
5609 entry $id.gnxy.x_ent -textvariable $var_iemgui_gn_dx -width 5
5610 label $id.gnxy.dummy1 -text " " -width 10
5611 label $id.gnxy.y_lab -text "y_off:" -width 6
5612 entry $id.gnxy.y_ent -textvariable $var_iemgui_gn_dy -width 5
5613 pack $id.gnxy.x_lab $id.gnxy.x_ent $id.gnxy.dummy1 \
5614 $id.gnxy.y_lab $id.gnxy.y_ent -side left
5615
5616 frame $id.gnfs
5617 pack $id.gnfs -side top
5618 label $id.gnfs.f_lab -text "font:" -width 6
5619 if {[eval concat $$var_iemgui_gn_f] == 0} {
5620 button $id.gnfs.fb -text "courier" -font {courier 10 bold} -width 7 -command "iemgui_toggle_font $id" }
5621 if {[eval concat $$var_iemgui_gn_f] == 1} {
5622 button $id.gnfs.fb -text "helvetica" -font {helvetica 10 bold} -width 7 -command "iemgui_toggle_font $id" }
5623 if {[eval concat $$var_iemgui_gn_f] == 2} {
5624 button $id.gnfs.fb -text "times" -font {times 10 bold} -width 7 -command "iemgui_toggle_font $id" }
5625 label $id.gnfs.dummy1 -text "" -width 1
5626 label $id.gnfs.fs_lab -text "fontsize:" -width 8
5627 entry $id.gnfs.fs_ent -textvariable $var_iemgui_gn_fs -width 5
5628 pack $id.gnfs.f_lab $id.gnfs.fb $id.gnfs.dummy1 \
5629 $id.gnfs.fs_lab $id.gnfs.fs_ent -side left
5630
5631 label $id.col_head -text "--------------colors:--------------"
5632 pack $id.col_head -side top
5633
5634 frame $id.col_select
5635 pack $id.col_select -side top
5636 radiobutton $id.col_select.radio0 -value 0 -variable $var_iemgui_l2_f1_b0 \
5637 -text "backgd" -width 5
5638 radiobutton $id.col_select.radio1 -value 1 -variable $var_iemgui_l2_f1_b0 \
5639 -text "front" -width 5
5640 radiobutton $id.col_select.radio2 -value 2 -variable $var_iemgui_l2_f1_b0 \
5641 -text "label" -width 5
5642 if { [eval concat $$var_iemgui_fcol] >= 0 } {
5643 pack $id.col_select.radio0 $id.col_select.radio1 $id.col_select.radio2 -side left
5644 } else {pack $id.col_select.radio0 $id.col_select.radio2 -side left}
5645
5646 frame $id.col_example_choose
5647 pack $id.col_example_choose -side top
5648 button $id.col_example_choose.but -text "compose color" -width 10 \
5649 -command "iemgui_choose_col_bkfrlb $id"
5650 label $id.col_example_choose.dummy1 -text "" -width 1
5651 if { [eval concat $$var_iemgui_fcol] >= 0 } {
5652 button $id.col_example_choose.fr_bk -text "o=||=o" -width 5 \
5653 -background [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
5654 -activebackground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
5655 -foreground [format "#%6.6x" [eval concat $$var_iemgui_fcol]] \
5656 -activeforeground [format "#%6.6x" [eval concat $$var_iemgui_fcol]] -pady 2
5657 } else {
5658 button $id.col_example_choose.fr_bk -text "o=||=o" -width 5 \
5659 -background [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
5660 -activebackground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
5661 -foreground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
5662 -activeforeground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] -pady 2}
5663 button $id.col_example_choose.lb_bk -text "testlabel" -width 7 \
5664 -background [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
5665 -activebackground [format "#%6.6x" [eval concat $$var_iemgui_bcol]] \
5666 -foreground [format "#%6.6x" [eval concat $$var_iemgui_lcol]] \
5667 -activeforeground [format "#%6.6x" [eval concat $$var_iemgui_lcol]] -pady 2
5668
5669 pack $id.col_example_choose.but $id.col_example_choose.dummy1 \
5670 $id.col_example_choose.fr_bk $id.col_example_choose.lb_bk -side left
5671
5672 label $id.space3 -text "------or click color preset:-------"
5673 pack $id.space3 -side top
5674
5675 frame $id.bcol
5676 pack $id.bcol -side top
5677 foreach i { 0 1 2 3 4 5 6 7 8 9 } hexcol { 16579836 14737632 12369084 \
5678 16572640 16572608 16579784 14220504 14220540 14476540 16308476 } {
5679 button $id.bcol.c$i -background [format "#%6.6x" $hexcol] \
5680 -activebackground [format "#%6.6x" $hexcol] \
5681 -font {courier 2 normal} -padx 7 -pady 6 \
5682 -command [format "iemgui_preset_col %s %d" $id $hexcol] }
5683 pack $id.bcol.c0 $id.bcol.c1 $id.bcol.c2 $id.bcol.c3 $id.bcol.c4 \
5684 $id.bcol.c5 $id.bcol.c6 $id.bcol.c7 $id.bcol.c8 $id.bcol.c9 -side left
5685
5686 frame $id.fcol
5687 pack $id.fcol -side top
5688 foreach i { 0 1 2 3 4 5 6 7 8 9 } hexcol { 10526880 8158332 6316128 \
5689 16525352 16559172 15263784 1370132 2684148 3952892 16003312 } {
5690 button $id.fcol.c$i -background [format "#%6.6x" $hexcol] \
5691 -activebackground [format "#%6.6x" $hexcol] \
5692 -font {courier 2 normal} -padx 7 -pady 6 \
5693 -command [format "iemgui_preset_col %s %d" $id $hexcol] }
5694 pack $id.fcol.c0 $id.fcol.c1 $id.fcol.c2 $id.fcol.c3 $id.fcol.c4 \
5695 $id.fcol.c5 $id.fcol.c6 $id.fcol.c7 $id.fcol.c8 $id.fcol.c9 -side left
5696
5697 frame $id.lcol
5698 pack $id.lcol -side top
5699 foreach i { 0 1 2 3 4 5 6 7 8 9 } hexcol { 4210752 2105376 0 \
5700 9177096 5779456 7874580 2641940 17488 5256 5767248 } {
5701 button $id.lcol.c$i -background [format "#%6.6x" $hexcol] \
5702 -activebackground [format "#%6.6x" $hexcol] \
5703 -font {courier 2 normal} -padx 7 -pady 6 \
5704 -command [format "iemgui_preset_col %s %d" $id $hexcol] }
5705 pack $id.lcol.c0 $id.lcol.c1 $id.lcol.c2 $id.lcol.c3 $id.lcol.c4 \
5706 $id.lcol.c5 $id.lcol.c6 $id.lcol.c7 $id.lcol.c8 $id.lcol.c9 -side left
5707
5708
5709 label $id.space4 -text "---------------------------------"
5710 pack $id.space4 -side top
5711
5712 frame $id.cao
5713 pack $id.cao -side top
5714 button $id.cao.cancel -text {Cancel} -width 6 \
5715 -command "iemgui_cancel $id"
5716 label $id.cao.dummy1 -text "" -width 3
5717 button $id.cao.apply -text {Apply} -width 6 \
5718 -command "iemgui_apply $id"
5719 label $id.cao.dummy2 -text "" -width 3
5720 button $id.cao.ok -text {OK} -width 6 \
5721 -command "iemgui_ok $id"
5722 pack $id.cao.cancel $id.cao.dummy1 \
5723 $id.cao.apply $id.cao.dummy2 \
5724 $id.cao.ok -side left
5725
5726 label $id.space5 -text ""
5727 pack $id.space5 -side top
5728
5729 if {[info tclversion] < 8.4} {
5730 bind $id <Key-Tab> {tkTabToWindow [tk_focusNext %W]}
5731 bind $id <<PrevWindow>> {tkTabToWindow [tk_focusPrev %W]}
5732 } else {
5733 bind $id <Key-Tab> {tk::TabToWindow [tk_focusNext %W]}
5734 bind $id <<PrevWindow>> {tk::TabToWindow [tk_focusPrev %W]}
5735 }
5736
5737 bind $id.dim.w_ent <KeyPress-Return> [concat iemgui_ok $id]
5738 bind $id.dim.h_ent <KeyPress-Return> [concat iemgui_ok $id]
5739 bind $id.rng.min_ent <KeyPress-Return> [concat iemgui_ok $id]
5740 bind $id.rng.max_ent <KeyPress-Return> [concat iemgui_ok $id]
5741 bind $id.para.num_ent <KeyPress-Return> [concat iemgui_ok $id]
5742 bind $id.snd.ent <KeyPress-Return> [concat iemgui_ok $id]
5743 bind $id.rcv.ent <KeyPress-Return> [concat iemgui_ok $id]
5744 bind $id.gnam.ent <KeyPress-Return> [concat iemgui_ok $id]
5745 bind $id.gnxy.x_ent <KeyPress-Return> [concat iemgui_ok $id]
5746 bind $id.gnxy.y_ent <KeyPress-Return> [concat iemgui_ok $id]
5747 bind $id.gnfs.fs_ent <KeyPress-Return> [concat iemgui_ok $id]
5748 bind $id.cao.ok <KeyPress-Return> [concat iemgui_ok $id]
5749
5750 $id.dim.w_ent select from 0
5751 $id.dim.w_ent select adjust end
5752 focus $id.dim.w_ent
5753}
5754# end of change "iemlib"
5755
5756############ pdtk_array_dialog -- dialog window for arrays #########
5757proc array_apply {id} {
5758# strip "." from the TK id to make a variable name suffix
5759 set vid [string trimleft $id .]
5760# for each variable, make a local variable to hold its name...
5761 set var_array_name [concat array_name_$vid]
5762 global $var_array_name
5763 set var_array_n [concat array_n_$vid]
5764 global $var_array_n
5765 set var_array_saveit [concat array_saveit_$vid]
5766 global $var_array_saveit
5767 set var_array_otherflag [concat array_otherflag_$vid]
5768 global $var_array_otherflag
5769 set mofo [eval concat $$var_array_name]
5770 if {[string index $mofo 0] == "$"} {
5771 set mofo [string replace $mofo 0 0 #] }
5772
5773 pd [concat $id arraydialog $mofo \
5774 [eval concat $$var_array_n] \
5775 [eval concat $$var_array_saveit] \
5776 [eval concat $$var_array_otherflag] \
5777 \;]
5778}
5779
5780proc array_cancel {id} {
5781 set cmd [concat $id cancel \;]
5782 pd $cmd
5783}
5784
5785proc array_ok {id} {
5786 array_apply $id
5787 array_cancel $id
5788}
5789
5790proc pdtk_array_dialog {id name n saveit newone} {
5791 set vid [string trimleft $id .]
5792
5793 set var_array_name [concat array_name_$vid]
5794 global $var_array_name
5795 set var_array_n [concat array_n_$vid]
5796 global $var_array_n
5797 set var_array_saveit [concat array_saveit_$vid]
5798 global $var_array_saveit
5799 set var_array_otherflag [concat array_otherflag_$vid]
5800 global $var_array_otherflag
5801
5802 set $var_array_name $name
5803 set $var_array_n $n
5804 set $var_array_saveit $saveit
5805 set $var_array_otherflag 0
5806
5807 toplevel $id
5808 wm title $id {array}
5809 wm protocol $id WM_DELETE_WINDOW [concat array_cancel $id]
5810
5811 frame $id.name
5812 pack $id.name -side top
5813 label $id.name.label -text "name"
5814 entry $id.name.entry -textvariable $var_array_name
5815 pack $id.name.label $id.name.entry -side left
5816
5817 frame $id.n
5818 pack $id.n -side top
5819 label $id.n.label -text "size"
5820 entry $id.n.entry -textvariable $var_array_n
5821 pack $id.n.label $id.n.entry -side left
5822
5823 checkbutton $id.saveme -text {save contents} -variable $var_array_saveit \
5824 -anchor w
5825 pack $id.saveme -side top
5826
5827 if {$newone != 0} {
5828 frame $id.radio
5829 pack $id.radio -side top
5830 radiobutton $id.radio.radio0 -value 0 \
5831 -variable $var_array_otherflag \
5832 -text "in new graph"
5833 radiobutton $id.radio.radio1 -value 1 \
5834 -variable $var_array_otherflag \
5835 -text "in last graph"
5836 pack $id.radio.radio0 -side top -anchor w
5837 pack $id.radio.radio1 -side top -anchor w
5838 } else {
5839 checkbutton $id.deleteme -text {delete me} \
5840 -variable $var_array_otherflag -anchor w
5841 pack $id.deleteme -side top
5842 }
5843 frame $id.buttonframe
5844 pack $id.buttonframe -side bottom -fill x -pady 2m
5845 button $id.buttonframe.cancel -text {Cancel}\
5846 -command "array_cancel $id"
5847 if {$newone == 0} {button $id.buttonframe.apply -text {Apply}\
5848 -command "array_apply $id"}
5849 button $id.buttonframe.ok -text {OK}\
5850 -command "array_ok $id"
5851 pack $id.buttonframe.cancel -side left -expand 1
5852 if {$newone == 0} {pack $id.buttonframe.apply -side left -expand 1}
5853 pack $id.buttonframe.ok -side left -expand 1
5854
5855 bind $id.name.entry <KeyPress-Return> [concat array_ok $id]
5856 bind $id.n.entry <KeyPress-Return> [concat array_ok $id]
5857 $id.name.entry select from 0
5858 $id.name.entry select adjust end
5859 focus $id.name.entry
5860}
5861
5862############ pdtk_canvas_dialog -- dialog window for canvass #########
5863proc canvas_apply {id} {
5864# strip "." from the TK id to make a variable name suffix
5865 set vid [string trimleft $id .]
5866# for each variable, make a local variable to hold its name...
5867 set var_canvas_xscale [concat canvas_xscale_$vid]
5868 global $var_canvas_xscale
5869 set var_canvas_yscale [concat canvas_yscale_$vid]
5870 global $var_canvas_yscale
5871 set var_canvas_graphme [concat canvas_graphme_$vid]
5872 global $var_canvas_graphme
5873# set var_canvas_stretch [concat canvas_stretch_$vid]
5874# global $var_canvas_stretch
5875 pd [concat $id donecanvasdialog \
5876 [eval concat $$var_canvas_xscale] \
5877 [eval concat $$var_canvas_yscale] \
5878 [eval concat $$var_canvas_graphme] \
5879 \;]
5880}
5881
5882proc canvas_cancel {id} {
5883 set cmd [concat $id cancel \;]
5884 pd $cmd
5885}
5886
5887proc canvas_ok {id} {
5888 canvas_apply $id
5889 canvas_cancel $id
5890}
5891
5892proc pdtk_canvas_dialog {id xscale yscale graphme stretch} {
5893 set vid [string trimleft $id .]
5894
5895 set var_canvas_xscale [concat canvas_xscale_$vid]
5896 global $var_canvas_xscale
5897 set var_canvas_yscale [concat canvas_yscale_$vid]
5898 global $var_canvas_yscale
5899 set var_canvas_graphme [concat canvas_graphme_$vid]
5900 global $var_canvas_graphme
5901# set var_canvas_stretch [concat canvas_stretch_$vid]
5902# global $var_canvas_stretch
5903
5904 set $var_canvas_xscale $xscale
5905 set $var_canvas_yscale $yscale
5906 set $var_canvas_graphme $graphme
5907# set $var_canvas_stretch $stretch
5908
5909 toplevel $id
5910 wm title $id {canvas}
5911 wm protocol $id WM_DELETE_WINDOW [concat canvas_cancel $id]
5912
5913 frame $id.xscale
5914 pack $id.xscale -side top
5915 label $id.xscale.label -text "X units per pixel"
5916 entry $id.xscale.entry -textvariable $var_canvas_xscale -width 10
5917 pack $id.xscale.label $id.xscale.entry -side left
5918
5919 frame $id.yscale
5920 pack $id.yscale -side top
5921 label $id.yscale.label -text "Y units per pixel"
5922 entry $id.yscale.entry -textvariable $var_canvas_yscale -width 10
5923 pack $id.yscale.label $id.yscale.entry -side left
5924
5925 checkbutton $id.graphme -text {graph on parent} \
5926 -variable $var_canvas_graphme -anchor w
5927 pack $id.graphme -side top
5928
5929# checkbutton $id.stretch -text {stretch on resize} \
5930# -variable $var_canvas_stretch -anchor w
5931# pack $id.stretch -side top
5932
5933
5934 frame $id.buttonframe
5935 pack $id.buttonframe -side bottom -fill x -pady 2m
5936 button $id.buttonframe.cancel -text {Cancel}\
5937 -command "canvas_cancel $id"
5938 button $id.buttonframe.apply -text {Apply}\
5939 -command "canvas_apply $id"
5940 button $id.buttonframe.ok -text {OK}\
5941 -command "canvas_ok $id"
5942 pack $id.buttonframe.cancel -side left -expand 1
5943 pack $id.buttonframe.apply -side left -expand 1
5944 pack $id.buttonframe.ok -side left -expand 1
5945
5946 bind $id.xscale.entry <KeyPress-Return> [concat canvas_ok $id]
5947 bind $id.yscale.entry <KeyPress-Return> [concat canvas_ok $id]
5948 $id.xscale.entry select from 0
5949 $id.xscale.entry select adjust end
5950 focus $id.xscale.entry
5951}
5952
5953############ pdtk_data_dialog -- run a data dialog #########
5954proc dodata_send {name} {
5955# puts stderr [$name.text get 0.0 end]
5956
5957 for {set i 1} {[$name.text compare [concat $i.0 + 3 chars] < end]} \
5958 {incr i 1} {
5959# puts stderr [concat it's [$name.text get $i.0 [expr $i + 1].0]]
5960 set cmd [concat $name data [$name.text get $i.0 [expr $i + 1].0] \;]
5961# puts stderr $cmd
5962 pd $cmd
5963 }
5964 set cmd [concat $name end \;]
5965# puts stderr $cmd
5966 pd $cmd
5967}
5968
5969proc dodata_cancel {name} {
5970 set cmd [concat $name cancel \;]
5971# puts stderr $cmd
5972 pd $cmd
5973}
5974
5975proc dodata_ok {name} {
5976 dodata_send $name
5977 dodata_cancel $name
5978}
5979
5980proc pdtk_data_dialog {name stuff} {
5981
5982 toplevel $name
5983 wm title $name {Atom}
5984 wm protocol $name WM_DELETE_WINDOW [concat dodata_cancel $name]
5985
5986 frame $name.buttonframe
5987 pack $name.buttonframe -side bottom -fill x -pady 2m
5988 button $name.buttonframe.send -text {Send (Ctrl s)}\
5989 -command [concat dodata_send $name]
5990 button $name.buttonframe.ok -text {OK (Ctrl t)}\
5991 -command [concat dodata_ok $name]
5992 pack $name.buttonframe.send -side left -expand 1
5993 pack $name.buttonframe.ok -side left -expand 1
5994
5995 text $name.text -relief raised -bd 2 -height 40 -width 60 \
5996 -yscrollcommand "$name.scroll set" -font -*-courier-bold--normal--12-*
5997 scrollbar $name.scroll -command "$name.text yview"
5998 pack $name.scroll -side right -fill y
5999 pack $name.text -side left -fill both -expand 1
6000 $name.text insert end $stuff
6001 focus $name.text
6002 bind $name.text <Control-t> [concat dodata_ok $name]
6003 bind $name.text <Control-s> [concat dodata_send $name]
6004}
6005
6006############ check or uncheck the "edit" menu item ##############
6007#####################iemlib#######################
6008proc pdtk_canvas_editval {name value} {
6009 if { $value } {
6010 $name.m.edit entryconfigure "Edit mode" -indicatoron true
6011 } else {
6012 $name.m.edit entryconfigure "Edit mode" -indicatoron false
6013 }
6014}
6015#####################iemlib#######################
6016
6017############ pdtk_text_new -- create a new text object #2###########
6018proc pdtk_text_new {canvasname myname x y text font color} {
6019# if {$font < 13} {set fontname [format -*-courier-bold----%d-* $font]}
6020# if {$font >= 13} {set fontname [format -*-courier-----%d-* $font]}
6021 $canvasname create text $x $y \
6022 -font [format -*-courier-bold--normal--%d-* $font] \
6023 -tags $myname -text $text -fill $color -anchor nw
6024# pd [concat $myname size [$canvasname bbox $myname] \;]
6025}
6026
6027################ pdtk_text_set -- change the text ##################
6028proc pdtk_text_set {canvasname myname text} {
6029 $canvasname itemconfig $myname -text $text
6030# pd [concat $myname size [$canvasname bbox $myname] \;]
6031}
6032
6033############### event binding procedures for Pd window ################
6034
6035proc pdtk_pd_ctrlkey {name key shift} {
6036# puts stderr [concat key $key shift $shift]
6037# .dummy itemconfig goo -text [concat ---> control-key event $key];
6038 if {$key == "n" || $key == "N"} {menu_new}
6039 if {$key == "o" || $key == "O"} {menu_open}
6040 if {$key == "m" || $key == "M"} {menu_send}
6041 if {$key == "q" || $key == "Q"} {
6042 if {$shift == 1} {menu_really_quit} else {menu_quit}
6043 }
6044 if {$key == "slash"} {menu_audio 1}
6045 if {$key == "period"} {menu_audio 0}
6046}
6047
6048######### startup function. ##############
6049# Tell pd the current directory; this is used in case the command line
6050# asked pd to open something. Also, get character width and height for
6051# font sizes 8, 10, 12, 14, 16, and 24.
6052
6053proc pdtk_pd_startup {version apilist} {
6054 global pd_myversion pd_apilist
6055 set pd_myversion $version
6056 set pd_apilist $apilist
6057
6058 set width1 [font measure -*-courier-bold--normal--8-* x]
6059 set height1 [lindex [font metrics -*-courier-bold--normal--8-*] 5]
6060
6061 set width2 [font measure -*-courier-bold--normal--10-* x]
6062 set height2 [lindex [font metrics -*-courier-bold--normal--10-*] 5]
6063
6064 set width3 [font measure -*-courier-bold--normal--12-* x]
6065 set height3 [lindex [font metrics -*-courier-bold--normal--12-*] 5]
6066
6067 set width4 [font measure -*-courier-bold--normal--14-* x]
6068 set height4 [lindex [font metrics -*-courier-bold--normal--14-*] 5]
6069
6070 set width5 [font measure -*-courier-bold--normal--16-* x]
6071 set height5 [lindex [font metrics -*-courier-bold--normal--16-*] 5]
6072
6073 set width6 [font measure -*-courier-bold--normal--24-* x]
6074 set height6 [lindex [font metrics -*-courier-bold--normal--24-*] 5]
6075
6076 set width7 [font measure -*-courier-bold--normal--36-* x]
6077 set height7 [lindex [font metrics -*-courier-bold--normal--36-*] 5]
6078
6079 set tclpatch [info patchlevel]
6080 if {$tclpatch == "8.3.0" || \
6081 $tclpatch == "8.3.1" || \
6082 $tclpatch == "8.3.2" || \
6083 $tclpatch == "8.3.3" } {
6084 set oldtclversion 1
6085 } else {
6086 set oldtclversion 0
6087 }
6088 pd [concat pd init [pdtk_enquote [pwd]] \
6089 8 $width1 $height1 \
6090 10 $width2 $height2 \
6091 12 $width3 $height3 \
6092 14 $width4 $height4 \
6093 16 $width5 $height5 \
6094 24 $width6 $height6 \
6095 36 $width7 $height7 \
6096 $oldtclversion \;];
6097
6098 # add the audio and help menus to the Pd window. We delayed this
6099 # so that we'd know the value of "apilist".
6100 menu_addstd .mbar
6101
6102}
6103
6104##################### DSP ON/OFF, METERS, DIO ERROR ###################
6105proc pdtk_pd_dsp {value} {
6106 global ctrls_audio_on
6107 if {$value == "ON"} {set ctrls_audio_on 1} else {set ctrls_audio_on 0}
6108# puts stderr [concat its $ctrls_audio_on]
6109}
6110
6111proc pdtk_pd_meters {indb outdb inclip outclip} {
6112# puts stderr [concat meters $indb $outdb $inclip $outclip]
6113 global ctrls_inlevel ctrls_outlevel
6114 set ctrls_inlevel $indb
6115 if {$inclip == 1} {
6116 .controls.inout.in.clip configure -background red
6117 } else {
6118 .controls.inout.in.clip configure -background grey
6119 }
6120 set ctrls_outlevel $outdb
6121 if {$outclip == 1} {
6122 .controls.inout.out.clip configure -background red
6123 } else {
6124 .controls.inout.out.clip configure -background grey
6125 }
6126
6127}
6128
6129proc pdtk_pd_dio {red} {
6130# puts stderr [concat dio $red]
6131 if {$red == 1} {
6132 .controls.dio configure -background red -activebackground red
6133 } else {
6134 .controls.dio configure -background grey -activebackground lightgrey
6135 }
6136
6137}
6138
6139############# text editing from the "edit" menu ###################
6140set edit_number 1
6141
6142proc texteditor_send {name} {
6143 set topname [string trimright $name .text]
6144 for {set i 0} \
6145 {[$name compare [concat 0.0 + [expr $i + 1] chars] < end]} \
6146 {incr i 1} {
6147 set cha [$name get [concat 0.0 + $i chars]]
6148 scan $cha %c keynum
6149 pd [concat pd key 1 $keynum 0 \;]
6150 }
6151}
6152
6153proc texteditor_ok {name} {
6154 set topname [string trimright $name .text]
6155 texteditor_send $name
6156 destroy $topname
6157}
6158
6159
6160proc pdtk_pd_texteditor {stuff} {
6161 global edit_number
6162 set name [format ".text%d" $edit_number]
6163 set edit_number [expr $edit_number + 1]
6164
6165 toplevel $name
6166 wm title $name {TEXT}
6167
6168 frame $name.buttons
6169 pack $name.buttons -side bottom -fill x -pady 2m
6170 button $name.buttons.send -text {Send (Ctrl s)}\
6171 -command "texteditor_send $name.text"
6172 button $name.buttons.ok -text {OK (Ctrl t)}\
6173 -command "texteditor_ok $name.text"
6174 pack $name.buttons.send -side left -expand 1
6175 pack $name.buttons.ok -side left -expand 1
6176
6177 text $name.text -relief raised -bd 2 -height 12 -width 60 \
6178 -yscrollcommand "$name.scroll set" -font -*-courier-bold--normal--12-*
6179 scrollbar $name.scroll -command "$name.text yview"
6180 pack $name.scroll -side right -fill y
6181 pack $name.text -side left -fill both -expand 1
6182 $name.text insert end $stuff
6183 focus $name.text
6184 bind $name.text <Control-t> {texteditor_ok %W}
6185 bind $name.text <Control-s> {texteditor_send %W}
6186}
6187
6188############# open and save dialogs for objects in Pd ##########
6189
6190proc pdtk_openpanel {target} {
6191 global pd_opendir
6192 set filename [tk_getOpenFile \
6193 -initialdir $pd_opendir]
6194 if {$filename != ""} {
6195 set directory [string range $filename 0 \
6196 [expr [string last / $filename ] - 1]]
6197 set pd_opendir $directory
6198
6199 pd [concat $target symbol [pdtk_enquote $filename] \;]
6200 }
6201}
6202
6203proc pdtk_savepanel {target} {
6204 set filename [tk_getSaveFile]
6205 if {$filename != ""} {
6206 pd [concat $target symbol [pdtk_enquote $filename] \;]
6207 }
6208}
6209
6210########################### comport hack ########################
6211
6212set com1 0
6213set com2 0
6214set com3 0
6215set com4 0
6216
6217proc com1_open {} {
6218 global com1
6219 set com1 [open com1 w]
6220 .dummy itemconfig goo -text $com1
6221 fconfigure $com1 -buffering none
6222 fconfigure $com1 -mode 19200,e,8,2
6223}
6224
6225proc com1_send {str} {
6226 global com1
6227 puts -nonewline $com1 $str
6228}
6229
6230
6231############# start a polling process to watch the socket ##############
6232# this is needed for nt, and presumably for Mac as well.
6233# in UNIX this is handled by a tcl callback (set up in t_tkcmd.c)
6234
6235if {$pd_nt == 1} {
6236 proc polleofloop {} {
6237 pd_pollsocket
6238 after 20 polleofloop
6239 }
6240
6241 polleofloop
6242}
6243
6244####################### audio dialog ##################3
6245
6246proc audio_apply {id} {
6247 global audio_indev1 audio_indev2 audio_indev3 audio_indev4
6248 global audio_inchan1 audio_inchan2 audio_inchan3 audio_inchan4
6249 global audio_outdev1 audio_outdev2 audio_outdev3 audio_outdev4
6250 global audio_outchan1 audio_outchan2 audio_outchan3 audio_outchan4
6251 global audio_sr audio_advance
6252
6253 pd [concat pd audio-dialog \
6254 $audio_indev1 \
6255 $audio_indev2 \
6256 $audio_indev3 \
6257 $audio_indev4 \
6258 $audio_inchan1 \
6259 $audio_inchan2 \
6260 $audio_inchan3 \
6261 $audio_inchan4 \
6262 $audio_outdev1 \
6263 $audio_outdev2 \
6264 $audio_outdev3 \
6265 $audio_outdev4 \
6266 $audio_outchan1 \
6267 $audio_outchan2 \
6268 $audio_outchan3 \
6269 $audio_outchan4 \
6270 $audio_sr \
6271 $audio_advance \
6272 \;]
6273}
6274
6275proc audio_cancel {id} {
6276 pd [concat $id cancel \;]
6277}
6278
6279proc audio_ok {id} {
6280 audio_apply $id
6281 audio_cancel $id
6282}
6283
6284# callback from popup menu
6285proc audio_popup_action {buttonname varname devlist index} {
6286 global audio_indevlist audio_outdevlist $varname
6287 $buttonname configure -text [lindex $devlist $index]
6288# puts stderr [concat popup_action $buttonname $varname $index]
6289 set $varname $index
6290}
6291
6292# create a popup menu
6293proc audio_popup {name buttonname varname devlist} {
6294 if [winfo exists $name.popup] {destroy $name.popup}
6295 menu $name.popup -tearoff false
6296# puts stderr [concat $devlist ]
6297 for {set x 0} {$x<[llength $devlist]} {incr x} {
6298 $name.popup add command -label [lindex $devlist $x] \
6299 -command [list audio_popup_action \
6300 $buttonname $varname $devlist $x]
6301 }
6302 tk_popup $name.popup [winfo pointerx $name] [winfo pointery $name] 0
6303}
6304
6305# start a dialog window to select audio devices and settings. "multi"
6306# is 0 if only one device is allowed; 1 if one apiece may be specified for
6307# input and output; and 2 if we can select multiple devices. "longform"
6308# (which only makes sense if "multi" is 2) asks us to make controls for
6309# opening several devices; if not, we get an extra button to turn longform
6310# on and restart the dialog.
6311
6312proc pdtk_audio_dialog {id indevlist indev1 indev2 indev3 indev4 \
6313 inchan1 inchan2 inchan3 inchan4 \
6314 outdevlist outdev1 outdev2 outdev3 outdev4 \
6315 outchan1 outchan2 outchan3 outchan4 sr advance multi longform} {
6316 global audio_indev1 audio_indev2 audio_indev3 audio_indev4
6317 global audio_inchan1 audio_inchan2 audio_inchan3 audio_inchan4
6318 global audio_outdev1 audio_outdev2 audio_outdev3 audio_outdev4
6319 global audio_outchan1 audio_outchan2 audio_outchan3 audio_outchan4
6320 global audio_sr audio_advance
6321 global audio_indevlist audio_outdevlist
6322
6323 set audio_indev1 $indev1
6324 set audio_indev2 $indev2
6325 set audio_indev3 $indev3
6326 set audio_indev4 $indev4
6327 set audio_inchan1 $inchan1
6328 set audio_inchan2 $inchan2
6329 set audio_inchan3 $inchan3
6330 set audio_inchan4 $inchan4
6331 set audio_outdev1 $outdev1
6332 set audio_outdev2 $outdev2
6333 set audio_outdev3 $outdev3
6334 set audio_outdev4 $outdev4
6335 set audio_outchan1 $outchan1
6336 set audio_outchan2 $outchan2
6337 set audio_outchan3 $outchan3
6338 set audio_outchan4 $outchan4
6339 set audio_sr $sr
6340 set audio_advance $advance
6341 set audio_indevlist $indevlist
6342 set audio_outdevlist $outdevlist
6343
6344 toplevel $id
6345 wm title $id {audio}
6346 wm protocol $id WM_DELETE_WINDOW [concat audio_cancel $id]
6347
6348 frame $id.buttonframe
6349 pack $id.buttonframe -side bottom -fill x -pady 2m
6350 button $id.buttonframe.cancel -text {Cancel}\
6351 -command "audio_cancel $id"
6352 button $id.buttonframe.apply -text {Apply}\
6353 -command "audio_apply $id"
6354 button $id.buttonframe.ok -text {OK}\
6355 -command "audio_ok $id"
6356 pack $id.buttonframe.cancel -side left -expand 1
6357 pack $id.buttonframe.apply -side left -expand 1
6358 pack $id.buttonframe.ok -side left -expand 1
6359
6360 # sample rate and advance
6361 frame $id.srf
6362 pack $id.srf -side top
6363
6364 label $id.srf.l1 -text "sample rate:"
6365 entry $id.srf.x1 -textvariable audio_sr -width 7
6366 label $id.srf.l2 -text "delay (msec):"
6367 entry $id.srf.x2 -textvariable audio_advance -width 4
6368 pack $id.srf.l1 $id.srf.x1 $id.srf.l2 $id.srf.x2 -side left
6369
6370 # input device 1
6371 frame $id.in1f
6372 pack $id.in1f -side top
6373
6374 label $id.in1f.l1 -text "input device 1:"
6375 button $id.in1f.x1 -text [lindex $indevlist $audio_indev1] \
6376 -command [list audio_popup $id $id.in1f.x1 audio_indev1 $indevlist]
6377 label $id.in1f.l2 -text "channels:"
6378 entry $id.in1f.x2 -textvariable audio_inchan1 -width 3
6379 pack $id.in1f.l1 $id.in1f.x1 $id.in1f.l2 $id.in1f.x2 -side left
6380
6381 # input device 2
6382 if {$longform && $multi > 1 && [llength $indevlist] > 1} {
6383 frame $id.in2f
6384 pack $id.in2f -side top
6385
6386 label $id.in2f.l1 -text "input device 2:"
6387 button $id.in2f.x1 -text [lindex $indevlist $audio_indev2] \
6388 -command [list audio_popup $id $id.in2f.x1 audio_indev2 $indevlist]
6389 label $id.in2f.l2 -text "channels:"
6390 entry $id.in2f.x2 -textvariable audio_inchan2 -width 3
6391 pack $id.in2f.l1 $id.in2f.x1 $id.in2f.l2 $id.in2f.x2 -side left
6392 }
6393
6394 # input device 3
6395 if {$longform && $multi > 1 && [llength $indevlist] > 2} {
6396 frame $id.in3f
6397 pack $id.in3f -side top
6398
6399 label $id.in3f.l1 -text "input device 3:"
6400 button $id.in3f.x1 -text [lindex $indevlist $audio_indev3] \
6401 -command [list audio_popup $id $id.in3f.x1 audio_indev3 $indevlist]
6402 label $id.in3f.l2 -text "channels:"
6403 entry $id.in3f.x2 -textvariable audio_inchan3 -width 3
6404 pack $id.in3f.l1 $id.in3f.x1 $id.in3f.l2 $id.in3f.x2 -side left
6405 }
6406
6407 # input device 4
6408 if {$longform && $multi > 1 && [llength $indevlist] > 3} {
6409 frame $id.in4f
6410 pack $id.in4f -side top
6411
6412 label $id.in4f.l1 -text "input device 4:"
6413 button $id.in4f.x1 -text [lindex $indevlist $audio_indev4] \
6414 -command [list audio_popup $id $id.in4f.x1 audio_indev4 $indevlist]
6415 label $id.in4f.l2 -text "channels:"
6416 entry $id.in4f.x2 -textvariable audio_inchan4 -width 3
6417 pack $id.in4f.l1 $id.in4f.x1 $id.in4f.l2 $id.in4f.x2 -side left
6418 }
6419
6420 # output device 1
6421 frame $id.out1f
6422 pack $id.out1f -side top
6423
6424 if {$multi == 0} {
6425 label $id.out1f.l1 \
6426 -text "(output device same as input device) .............. "
6427 } else {
6428 label $id.out1f.l1 -text "output device 1:"
6429 button $id.out1f.x1 -text [lindex $outdevlist $audio_outdev1] \
6430 -command \
6431 [list audio_popup $id $id.out1f.x1 audio_outdev1 $outdevlist]
6432 }
6433 label $id.out1f.l2 -text "channels:"
6434 entry $id.out1f.x2 -textvariable audio_outchan1 -width 3
6435 if {$multi == 0} {
6436 pack $id.out1f.l1 $id.out1f.l2 $id.out1f.x2 -side left
6437 } else {
6438 pack $id.out1f.l1 $id.out1f.x1 $id.out1f.l2 $id.out1f.x2 -side left
6439 }
6440
6441 # output device 2
6442 if {$longform && $multi > 1 && [llength $indevlist] > 1} {
6443 frame $id.out2f
6444 pack $id.out2f -side top
6445 label $id.out2f.l1 -text "output device 2:"
6446 button $id.out2f.x1 -text [lindex $outdevlist $audio_outdev2] \
6447 -command \
6448 [list audio_popup $id $id.out2f.x1 audio_outdev2 $outdevlist]
6449 label $id.out2f.l2 -text "channels:"
6450 entry $id.out2f.x2 -textvariable audio_outchan2 -width 3
6451 pack $id.out2f.l1 $id.out2f.x1 $id.out2f.l2 $id.out2f.x2 -side left
6452 }
6453
6454 # output device 3
6455 if {$longform && $multi > 1 && [llength $indevlist] > 2} {
6456 frame $id.out3f
6457 pack $id.out3f -side top
6458 label $id.out3f.l1 -text "output device 3:"
6459 button $id.out3f.x1 -text [lindex $outdevlist $audio_outdev3] \
6460 -command \
6461 [list audio_popup $id $id.out3f.x1 audio_outdev3 $outdevlist]
6462 label $id.out3f.l2 -text "channels:"
6463 entry $id.out3f.x2 -textvariable audio_outchan3 -width 3
6464 pack $id.out3f.l1 $id.out3f.x1 $id.out3f.l2 $id.out3f.x2 -side left
6465 }
6466
6467 # output device 4
6468 if {$longform && $multi > 1 && [llength $indevlist] > 3} {
6469 frame $id.out4f
6470 pack $id.out4f -side top
6471 label $id.out4f.l1 -text "output device 4:"
6472 button $id.out4f.x1 -text [lindex $outdevlist $audio_outdev4] \
6473 -command \
6474 [list audio_popup $id $id.out4f.x1 audio_outdev4 $outdevlist]
6475 label $id.out4f.l2 -text "channels:"
6476 entry $id.out4f.x2 -textvariable audio_outchan4 -width 3
6477 pack $id.out4f.l1 $id.out4f.x1 $id.out4f.l2 $id.out4f.x2 -side left
6478 }
6479
6480 # if not the "long form" but if "multi" is 2, make a button to
6481 # restart with longform set.
6482
6483 if {$longform == 0 && $multi > 1} {
6484 frame $id.longbutton
6485 pack $id.longbutton -side top
6486 button $id.longbutton.b -text {use multiple devices} \
6487 -command {pd pd audio-properties 1 \;}
6488 pack $id.longbutton.b
6489 }
6490 bind $id.srf.x1 <KeyPress-Return> [concat audio_ok $id]
6491 bind $id.srf.x2 <KeyPress-Return> [concat audio_ok $id]
6492 bind $id.in1f.x2 <KeyPress-Return> [concat audio_ok $id]
6493 $id.srf.x1 select from 0
6494 $id.srf.x1 select adjust end
6495 focus $id.srf.x1
6496}
6497
6498####################### midi dialog ##################3
6499
6500proc midi_apply {id} {
6501 global midi_indev1 midi_indev2 midi_indev3 midi_indev4
6502 global midi_outdev1 midi_outdev2 midi_outdev3 midi_outdev4
6503
6504 pd [concat pd midi-dialog \
6505 $midi_indev1 \
6506 $midi_indev2 \
6507 $midi_indev3 \
6508 $midi_indev4 \
6509 $midi_outdev1 \
6510 $midi_outdev2 \
6511 $midi_outdev3 \
6512 $midi_outdev4 \
6513 \;]
6514}
6515
6516proc midi_cancel {id} {
6517 pd [concat $id cancel \;]
6518}
6519
6520proc midi_ok {id} {
6521 midi_apply $id
6522 midi_cancel $id
6523}
6524
6525# callback from popup menu
6526proc midi_popup_action {buttonname varname devlist index} {
6527 global midi_indevlist midi_outdevlist $varname
6528 $buttonname configure -text [lindex $devlist $index]
6529# puts stderr [concat popup_action $buttonname $varname $index]
6530 set $varname $index
6531}
6532
6533# create a popup menu
6534proc midi_popup {name buttonname varname devlist} {
6535 if [winfo exists $name.popup] {destroy $name.popup}
6536 menu $name.popup -tearoff false
6537# puts stderr [concat $devlist ]
6538 for {set x 0} {$x<[llength $devlist]} {incr x} {
6539 $name.popup add command -label [lindex $devlist $x] \
6540 -command [list midi_popup_action \
6541 $buttonname $varname $devlist $x]
6542 }
6543 tk_popup $name.popup [winfo pointerx $name] [winfo pointery $name] 0
6544}
6545
6546# start a dialog window to select midi devices. "longform" asks us to make
6547# controls for opening several devices; if not, we get an extra button to
6548# turn longform on and restart the dialog.
6549
6550proc pdtk_midi_dialog {id indevlist indev1 indev2 indev3 indev4 \
6551 outdevlist outdev1 outdev2 outdev3 outdev4 longform} {
6552 global midi_indev1 midi_indev2 midi_indev3 midi_indev4
6553 global midi_outdev1 midi_outdev2 midi_outdev3 midi_outdev4
6554 global midi_indevlist midi_outdevlist
6555
6556 set midi_indev1 $indev1
6557 set midi_indev2 $indev2
6558 set midi_indev3 $indev3
6559 set midi_indev4 $indev4
6560 set midi_outdev1 $outdev1
6561 set midi_outdev2 $outdev2
6562 set midi_outdev3 $outdev3
6563 set midi_outdev4 $outdev4
6564 set midi_indevlist $indevlist
6565 set midi_outdevlist $outdevlist
6566
6567 toplevel $id
6568 wm title $id {midi}
6569 wm protocol $id WM_DELETE_WINDOW [concat midi_cancel $id]
6570
6571 frame $id.buttonframe
6572 pack $id.buttonframe -side bottom -fill x -pady 2m
6573 button $id.buttonframe.cancel -text {Cancel}\
6574 -command "midi_cancel $id"
6575 button $id.buttonframe.apply -text {Apply}\
6576 -command "midi_apply $id"
6577 button $id.buttonframe.ok -text {OK}\
6578 -command "midi_ok $id"
6579 pack $id.buttonframe.cancel -side left -expand 1
6580 pack $id.buttonframe.apply -side left -expand 1
6581 pack $id.buttonframe.ok -side left -expand 1
6582
6583 # input device 1
6584 frame $id.in1f
6585 pack $id.in1f -side top
6586
6587 label $id.in1f.l1 -text "input device 1:"
6588 button $id.in1f.x1 -text [lindex $indevlist $midi_indev1] \
6589 -command [list midi_popup $id $id.in1f.x1 midi_indev1 $indevlist]
6590 pack $id.in1f.l1 $id.in1f.x1 -side left
6591
6592 # input device 2
6593 if {$longform && [llength $indevlist] > 2} {
6594 frame $id.in2f
6595 pack $id.in2f -side top
6596
6597 label $id.in2f.l1 -text "input device 2:"
6598 button $id.in2f.x1 -text [lindex $indevlist $midi_indev2] \
6599 -command [list midi_popup $id $id.in2f.x1 midi_indev2 $indevlist]
6600 pack $id.in2f.l1 $id.in2f.x1 -side left
6601 }
6602
6603 # input device 3
6604 if {$longform && [llength $indevlist] > 3} {
6605 frame $id.in3f
6606 pack $id.in3f -side top
6607
6608 label $id.in3f.l1 -text "input device 3:"
6609 button $id.in3f.x1 -text [lindex $indevlist $midi_indev3] \
6610 -command [list midi_popup $id $id.in3f.x1 midi_indev3 $indevlist]
6611 pack $id.in3f.l1 $id.in3f.x1 -side left
6612 }
6613
6614 # input device 4
6615 if {$longform && [llength $indevlist] > 4} {
6616 frame $id.in4f
6617 pack $id.in4f -side top
6618
6619 label $id.in4f.l1 -text "input device 4:"
6620 button $id.in4f.x1 -text [lindex $indevlist $midi_indev4] \
6621 -command [list midi_popup $id $id.in4f.x1 midi_indev4 $indevlist]
6622 pack $id.in4f.l1 $id.in4f.x1 -side left
6623 }
6624
6625 # output device 1
6626
6627 frame $id.out1f
6628 pack $id.out1f -side top
6629 label $id.out1f.l1 -text "output device 1:"
6630 button $id.out1f.x1 -text [lindex $outdevlist $midi_outdev1] \
6631 -command [list midi_popup $id $id.out1f.x1 midi_outdev1 $outdevlist]
6632 pack $id.out1f.l1 $id.out1f.x1 -side left
6633
6634 # output device 2
6635 if {$longform && [llength $indevlist] > 2} {
6636 frame $id.out2f
6637 pack $id.out2f -side top
6638 label $id.out2f.l1 -text "output device 2:"
6639 button $id.out2f.x1 -text [lindex $outdevlist $midi_outdev2] \
6640 -command \
6641 [list midi_popup $id $id.out2f.x1 midi_outdev2 $outdevlist]
6642 pack $id.out2f.l1 $id.out2f.x1 -side left
6643 }
6644
6645 # output device 3
6646 if {$longform && [llength $indevlist] > 3} {
6647 frame $id.out3f
6648 pack $id.out3f -side top
6649 label $id.out3f.l1 -text "output device 3:"
6650 button $id.out3f.x1 -text [lindex $outdevlist $midi_outdev3] \
6651 -command \
6652 [list midi_popup $id $id.out3f.x1 midi_outdev3 $outdevlist]
6653 pack $id.out3f.l1 $id.out3f.x1 -side left
6654 }
6655
6656 # output device 4
6657 if {$longform && [llength $indevlist] > 4} {
6658 frame $id.out4f
6659 pack $id.out4f -side top
6660 label $id.out4f.l1 -text "output device 4:"
6661 button $id.out4f.x1 -text [lindex $outdevlist $midi_outdev4] \
6662 -command \
6663 [list midi_popup $id $id.out4f.x1 midi_outdev4 $outdevlist]
6664 pack $id.out4f.l1 $id.out4f.x1 -side left
6665 }
6666
6667 # if not the "long form" make a button to
6668 # restart with longform set.
6669
6670 if {$longform == 0} {
6671 frame $id.longbutton
6672 pack $id.longbutton -side top
6673 button $id.longbutton.b -text {use multiple devices} \
6674 -command {pd pd midi-properties 1 \;}
6675 pack $id.longbutton.b
6676 }
6677}
6678
6679############ pdtk_path_dialog -- dialog window for search path #########
6680
6681proc path_apply {id} {
6682 global pd_path0 pd_path1 pd_path2 pd_path3 pd_path4
6683 global pd_path5 pd_path6 pd_path7 pd_path8 pd_path9
6684
6685 pd [concat pd path-dialog \
6686 $pd_path0 $pd_path1 $pd_path2 $pd_path3 $pd_path4 \
6687 $pd_path5 $pd_path6 $pd_path7 $pd_path8 $pd_path9 \
6688 \;]
6689}
6690
6691proc path_cancel {id} {
6692 pd [concat $id cancel \;]
6693}
6694
6695proc path_ok {id} {
6696 path_apply $id
6697 path_cancel $id
6698}
6699set pd_path0 sdfgh
6700
6701proc pdtk_path_dialog {id} {
6702 global pd_path0 pd_path1 pd_path2 pd_path3 pd_path4
6703 global pd_path5 pd_path6 pd_path7 pd_path8 pd_path9
6704
6705 toplevel $id
6706 wm title $id {PD search path for patches and other files}
6707 wm protocol $id WM_DELETE_WINDOW [concat path_cancel $id]
6708
6709 frame $id.buttonframe
6710 pack $id.buttonframe -side bottom -fill x -pady 2m
6711 button $id.buttonframe.cancel -text {Cancel}\
6712 -command "path_cancel $id"
6713 button $id.buttonframe.apply -text {Apply}\
6714 -command "path_apply $id"
6715 button $id.buttonframe.ok -text {OK}\
6716 -command "path_ok $id"
6717 pack $id.buttonframe.cancel -side left -expand 1
6718 pack $id.buttonframe.apply -side left -expand 1
6719 pack $id.buttonframe.ok -side left -expand 1
6720
6721 for {set x 0} {$x < 10} {incr x} {
6722 # input device 1
6723 entry $id.f$x -textvariable pd_path$x -width 80
6724 bind $id.f$x <KeyPress-Return> [concat path_ok $id]
6725 pack $id.f$x -side top
6726 }
6727
6728 focus $id.f0
6729}
6730
6731proc pd_set {var value} {
6732 global $var
6733 set $var $value
6734}