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.tk3368
1 files changed, 0 insertions, 3368 deletions
diff --git a/apps/plugins/pdbox/PDa/src/u_main.tk b/apps/plugins/pdbox/PDa/src/u_main.tk
deleted file mode 100644
index e8d5702f32..0000000000
--- a/apps/plugins/pdbox/PDa/src/u_main.tk
+++ /dev/null
@@ -1,3368 +0,0 @@
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}
3368
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-22 23:29:28 +0000