1#!/bin/sh
2# the next line restarts using wish \
3exec wish8.3 "$0" "$@"
4
5package require -exact snack 2.2
6
7# there is no way (?) to find out from Tk if we can display UNICODE IPA
8# but it seems to be standard on windows installations
9if {[string match windows $tcl_platform(platform)]} {set UNICODE_IPA 1}
10
11switch $tcl_platform(platform) {
12 windows {
13  proc milliseconds { } {clock clicks}
14 }
15 unix {
16  proc milliseconds { } {expr {[clock clicks]/1000}}
17 }
18}
19
20
21set vowels(sw) {
22 O: u      300 600 2350 3250
23 O  \u028a 350 700 2600 3200
24 �: o      400 700 2450 3250
25 �  \u0254 500 850 2550 3250
26 A: \u0251 600 950 2550 3300
27 A  a      750 1250 2500 3350
28 I: i      250 2200 3150 3750
29 I  \u026a 350 2150 2750 3500
30 E: e      350 2250 2850 3550
31 E/� \u025b 500 1900 2550 3350
32 �3 \ue6   650 1700 2500 3450
33 Y: y      250 2050 2700 3300
34 Y  \u028f 300 2000 2400 3250
35 �: \uf8   400 1750 2300 3350
36 �  \u153  550 1550 2450 3300
37 �3 ""     550 1150 2450 3250
38 U: \u0289 300 1650 2250 2250
39 U  \u0275 450 1050 2300 3300
40}
41
42set vowels(us) {
43 i i 280 2250 2890 {}
44 I \u026a 400 1920 2560 {}
45 E \u025b 550 1770 2490 {}
46 @ \u00e 6690 1660 2490 {}
47 A \u0251 710 1100 2540 {}
48 > \u0254 590 880 2540 {}
49 U \u028a 450 1030 2380 {}
50 u u 310 870 2250 {}
51}
52
53set vowels(lang) us
54
55proc vok4Create {w {wid 200} {hei 200}} {
56 upvar #0 $w a
57 frame $w -width $wid -height $hei
58 pack [canvas $w.c -bg black] -fill both -expand 1
59 pack propagate $w 0
60 set a(xm) 20
61 set a(ym) 20
62 set a(F10) 800
63 set a(F11) 200
64 set a(F20) 2300
65 set a(F21) 500
66
67 $w.c create line 0 0 0 0 -fill white -tags axes -arrow both
68 $w.c create text 0 0 -anchor e -text F2 -fill yellow -tags ylabel
69 $w.c create text 0 0 -anchor n -text F1 -fill yellow -tags xlabel
70 menu $w.m -tearoff 0
71 $w.m add radiobutton -variable vowels(lang) -value sw \
72   -command [list vok4Config $w] -label "Swedish vowels (after Fant)"
73 $w.m add radiobutton -variable vowels(lang) -value us \
74   -command [list vok4Config $w] -label "American vowels (after Ladefoged)"
75 $w.m add radiobutton -variable vowels(lang) -value NIL \
76   -command [list vok4Config $w] -label "Don't display vowels"
77
78 # trailInit $w 10
79
80 bind $w.c <ButtonPress-1> "vok4Move $w %x %y;Play"
81 bind $w.c <B1-Motion> [list vok4Move $w %x %y]
82 bind $w.c <ButtonRelease-1> "Stop"
83 bind $w.c <Configure> [list vok4Config $w %w %h]
84 bind $w.c <ButtonPress-3> [list tk_popup $w.m %X %Y]
85 return $w
86}
87
88proc vok4Config {w {wid -1} {hei -1}} {
89 upvar #0 $w a
90
91 if {$wid==-1} {
92  set wid $a(width)
93  set hei $a(height)
94 } else {
95  set a(width) $wid
96  set a(height) $hei
97 }
98 set a(x0) $a(xm)
99 set a(x1) [expr $wid-$a(xm)]
100 set a(y0) [expr $hei-$a(ym)]
101 set a(y1) $a(ym)
102 $w.c coords axes $a(x0) $a(y1) \
103   $a(x1) $a(y1) $a(x1) $a(y0)
104 $w.c coords ylabel $a(x0) $a(y1)
105 $w.c coords xlabel $a(x1) $a(y0)
106
107 $w.c delete sym
108
109 set lang $::vowels(lang)
110 if [info exists ::vowels($lang)] {
111  foreach {ascii uni f1 f2 f3 f4} $::vowels($lang) {
112   if [info exists ::UNICODE_IPA] {set sym $uni} else {set sym $ascii}
113   set x [expr {$a(x0)+($a(x1)-$a(x0))*($f2-$a(F20))*1.0/($a(F21)-$a(F20))}]
114   set y [expr {$a(y0)+($a(y1)-$a(y0))*($f1-$a(F10))*1.0/($a(F11)-$a(F10))}]
115   $w.c create text $x $y -font "times 16" -anchor c -text $sym -fill gray -tags sym
116  }
117 }
118}
119
120proc vok4Move {w x y} {
121# puts [info level 0]
122 upvar #0 $w a
123
124 set f1 [expr {int($a(F10)+($a(F11)-$a(F10))*($y-$a(y0))*1.0/($a(y1)-$a(y0)))}]
125 set f2 [expr {int($a(F20)+($a(F21)-$a(F20))*($x-$a(x0))*1.0/($a(x1)-$a(x0)))}]
126 set ::v(f1) $f1
127 set ::v(f2) $f2
128 Config
129 set a(curx) $x
130 set a(cury) $y
131 #  trailUpdate $w
132 return ""
133}
134
135proc updatePreview {} {
136 $::v(pGen) configure \
137   $::v(g,freq) $::v(g,ampl) [expr 0.01*$::v(g,shape)] $::v(g,type) 1024
138 $::v(pF1) configure $::v(f1) $::v(b1)
139 $::v(pF2) configure $::v(f2) $::v(b2)
140 $::v(pF3) configure $::v(f3) $::v(b3)
141 $::v(pF4) configure $::v(f4) $::v(b4)
142
143 preview2 copy s
144 preview2 filter $::v(pAll)
145 preview1 copy s
146 preview1 filter $::v(pGen)
147
148 after cancel updatePreview
149 if {$::v(on) && $::v(g,type)=="noise"} {
150  after 100 updatePreview
151 }
152}
153
154proc Config {args} {
155 $::v(Gen) configure \
156   $::v(g,freq) $::v(g,ampl) [expr 0.01*$::v(g,shape)] $::v(g,type) -1
157 $::v(F1) configure $::v(f1) $::v(b1)
158 $::v(F2) configure $::v(f2) $::v(b2)
159 $::v(F3) configure $::v(f3) $::v(b3)
160 $::v(F4) configure $::v(f4) $::v(b4)
161 updatePreview
162}
163
164proc Play {} {
165 set ::v(on) 1
166 s stop
167 s play -filter $::v(All)
168 updatePreview
169 set ::v(tstart) [milliseconds]
170 #  updateTracks
171 .f1.b config -relief sunken
172}
173
174proc Stop {} {
175 s stop
176 set ::v(on) 0
177 .f1.b config -relief raised
178}
179
180proc Load {} {
181 set file [snack::getOpenFile]
182 if {$file != ""} {s read $file}
183}
184
185proc updateTracks {} {
186 set tt 50
187 set now [milliseconds]
188 set then $::v(tstart)
189 set dt [expr 1.0*([milliseconds]-$::v(tstart))]
190 #set ::v(g,freq) [expr 100+100*(1.0*$dt/$tt)*exp(-$dt/$tt)]
191 set ::v(g,freq) [expr {100+2*cos(2*3.1415*$dt/$tt)}]
192
193 Config
194
195 if $::v(on) {
196  after 50 updateTracks
197 }
198}
199
200proc labeledScale {w args} {
201 array set a {-valwidth 4 -labwidth 8}
202 array set a $args
203 catch {set a(-text) $a(-label)}
204
205 frame $w
206 pack [label $w.l -anchor w -width $a(-labwidth)] -side left
207 foreach opt {-text -bg -width -font} {
208  if [info exists a($opt)] {$w.l config $opt $a($opt)}
209 }
210 pack [scale $w.s -showvalue 0 -bd 1 -width 10] -side left -expand 1 -fill x
211 pack [label $w.v -textvariable $a(-variable) -width $a(-valwidth) -anchor w] -side left
212 foreach opt {-bg -font} {
213  if [info exists a($opt)] {$w.v config $opt $a($opt)}
214 }
215 foreach opt {-length -bg -from -to -variable -orient -resolution -command} {
216  if [info exists a($opt)] {$w.s config $opt $a($opt)}
217 }
218 return $w
219}
220
221proc About {} {
222 set w .about
223 catch {destroy $w}
224 toplevel $w
225 wm title $w "About: Formant Synthesis Demo"
226 set text " This application demonstrates formant-based synthesis
227 of vowels in real time, in the spirit of Gunnar Fant's
228 Orator Verbis Electris (OVE-1) synthesizer of 1953.
229
230 Set source and filter parameters at the top. Click and
231 drag in the \"vowel space\" to hear the vowels.
232 Right-click to select target language for vowel symbols.
233
234 Power spectrum of source (red) and output signal (green) are
235 to the right, waveforms are displayed at the bottom.
236
237 The source type \"sampled\" will use a sound file
238 containing a single period of a waveform as voice source.
239
240 Copyright � 2000 Jonas Beskow
241 Centre for Speech Technology
242 KTH, Stockholm"
243
244 label $w.l -text $text -relief groove -bd 2
245 button $w.b -text OK -command [list set about_done 1]
246 pack $w.l -side top -expand 1 -fill both -padx 5 -pady 5
247 pack $w.b -side top -padx 5 -pady 5
248 if [catch {::tk::PlaceWindow $w center}] {
249  wm geometry $w +[winfo rootx .]+[winfo rooty .]
250 }
251 vwait about_done
252 destroy $w
253}
254
255
256wm title . "Formant Synthesizer Demo"
257wm resizable . 0 0
258
259# Menu bar
260
261menu .m
262.m add cascade -label File -menu [menu .m.file -tearoff 0]
263.m add cascade -label Help -menu [menu .m.help -tearoff 0]
264.m.file add command -label "Load source waveform..." -command Load
265.m.file add separator
266.m.file add command -label Exit -command exit
267.m.help add command -label About... -command About
268. configure -menu .m
269
270# Generator GUI
271
272frame .f1 -relief groove -bd 2
273grid .f1 -row 0 -column 0 -sticky news -padx 5 -pady 5
274label .f1.l -text Source -bg red -anchor w
275tk_optionMenu .f1.gt v(g,type) rectangle triangle sine sampled noise
276button .f1.b -bitmap snackPlay -command Play
277button .f1.c -bitmap snackStop -command Stop
278
279labeledScale .f1.gf -label "Freq." -variable v(g,freq) -from 0.0 -to 1000 -resolution 1.0 -orient horiz -command Config
280labeledScale .f1.ga -label "Ampl." -variable v(g,ampl) -from 0.0 -to 6000 -resolution 1.0 -length 160 -orient horiz -command Config
281labeledScale .f1.gs -label "Shape" -variable v(g,shape) -from 0.0 -to 100 -resolution 1.0 -length 160 -orient horiz -command Config
282
283grid .f1.l .f1.gt .f1.b .f1.c -sticky we -padx 5
284grid .f1.gf -columnspan 4 -sticky we
285grid .f1.ga -columnspan 4 -sticky we
286grid .f1.gs -columnspan 4 -sticky we
287grid columnconfigure .f1 0 -weight 1
288grid rowconfigure .f1 4 -weight 1
289# Formant filter GUI
290
291frame .f2 -relief groove -bd 2
292grid .f2 -row 0 -column 1 -sticky news -padx 5 -pady 5
293label .f2.l -text "Formants" -bg green -anchor w
294grid .f2.l -columnspan 5 -sticky we -padx 5 -pady 5
295label .f2.lf -text "Frequency" -anchor w
296label .f2.lfu -text "Hz "
297label .f2.lb -text "Bandwidth" -anchor w
298label .f2.lbu -text "Hz "
299grid .f2.lf -row 1 -column 1 -sticky w
300grid .f2.lfu -row 1 -column 2 -sticky w
301grid .f2.lb -row 1 -column 3 -sticky w
302grid .f2.lbu -row 1 -column 4 -sticky w
303
304for {set i 1} {$i<=4} {incr i} {
305 label .f2.l0$i -text F$i -width 2
306 scale .f2.f$i -variable v(f$i) -from 0 -to 5000 -resolution 1.0 -orient horiz -command Config -showvalue 0 -bd 1 -width 10
307 label .f2.l1$i -textvariable v(f$i) -anchor w -width 4
308 scale .f2.b$i -variable v(b${i}) -from 1.0 -to 500 -resolution 1.0 -orient horiz -command Config -showvalue 0 -bd 1 -width 10 -length 80
309 label .f2.l2$i -textvariable v(b$i) -anchor w -width 3
310 grid .f2.l0$i .f2.f$i .f2.l1$i .f2.b$i .f2.l2$i -sticky news
311}
312grid columnconfigure .f2 1 -weight 1
313
314set vokh 250
315set vokw 275
316
317# Vowel space
318
319vok4Create .voc $vokw $vokh
320grid .voc -row 1 -column 0 -sticky news
321
322# Spectrum section preview
323
324snack::sound preview1
325snack::sound preview2
326
327set secw $vokw
328set sech $vokh
329
330canvas .c2 -bg black -height 100 -width $secw
331grid .c2 -row 1 -column 1  -sticky news
332.c2 create section 0 0 -sound preview1 -fill red -height $sech -topfrequency 4000 -width $secw -analysistype lpc -tags sect -maxvalue 30
333.c2 create section 0 0 -sound preview2 -fill green -height $sech -topfrequency 4000 -width $secw -analysistype lpc -tags sect -maxvalue 30
334
335foreach freq {1 2 3 4} {
336 set x [expr {$freq*$secw/4.0}]
337 .c2 create line $x 0 $x $sech -fill #999999
338 .c2 create text $x 0 -anchor ne -text $freq -fill #999999
339}
340.c2 create text 0 0 -anchor nw -text kHz -fill #999999
341.c2 raise sect
342
343# Waveforms preview
344
345set wavw 550
346set wavh 90
347
348canvas .c1 -bg black -height 100 -width $wavw
349grid .c1 -row 2 -columnspan 2 -sticky news
350.c1 create waveform 0 50 -anchor w -sound preview1 -fill red  -height $wavh -pixelspersecond 16000
351.c1 create waveform 0 50 -anchor w -sound preview2 -fill green  -height $wavh -pixelspersecond 16000
352
353# Default values
354
355set v(f1) 500
356set v(b1) 50
357set v(f2) 1500
358set v(b2) 75
359set v(f3) 2500
360set v(b3) 100
361set v(f4) 3500
362set v(b4) 150
363set v(g,freq) 75
364set v(g,ampl) 2500
365set v(g,shape) 10
366set v(g,type) rectangle
367
368# Create the filters
369set v(F1) [snack::filter formant $v(f1) $v(b1)]
370set v(F2) [snack::filter formant $v(f2) $v(b2)]
371set v(F3) [snack::filter formant $v(f3) $v(b3)]
372set v(F4) [snack::filter formant $v(f4) $v(b4)]
373set v(Gen) [snack::filter generator $v(g,freq)]
374set v(All) [snack::filter compose $v(Gen) $v(F1) $v(F2) $v(F3) $v(F4)]
375
376# Create spearate filters for the preview
377set v(pF1) [snack::filter formant $v(f1) $v(b1)]
378set v(pF2) [snack::filter formant $v(f2) $v(b2)]
379set v(pF3) [snack::filter formant $v(f3) $v(b3)]
380set v(pF4) [snack::filter formant $v(f4) $v(b4)]
381set v(pGen) [snack::filter generator $v(g,freq)]
382set v(pAll) [snack::filter compose $v(pGen) $v(pF1) $v(pF2) $v(pF3) $v(pF4)]
383
384set v(on) 0
385
386snack::sound s
387snack::createIcons
388
389set samples {135 1477 969 -524 -784 314 781 -19 -543 70 696 366 -141 154 694 484 -122 -179 199 290 136 229 429 293 0 48 326 321 44 -15 210 296 137 99 256 254 82 193 625 800 497 234 346 478 354 264 411 516 420 412 628 724 524 389 563 714 557 378 477 608 476 320 450 658 598 395 380 545 628 558 486 484 461 393 383 446 464 413 399 459 520 559 612 668 670 618 569 536 481 390 312 278 255 224 199 176 152 148 158 119 0 -130 -209 -275 -405 -594 -777 -922 -1046 -1187 -1420 -1822 -2267 -2179}
390s length [llength $samples]
391for {set i 0} {$i<[s length]} {incr i} {
392 s sample $i [lindex $samples $i]
393}
394
395trace variable v(g,type) w Config
396