Edinburgh Speech Tools 2.4-release
 
Loading...
Searching...
No Matches
siod_est.cc
1/*************************************************************************/
2/* */
3/* Centre for Speech Technology Research */
4/* University of Edinburgh, UK */
5/* Copyright (c) 1996-1998 */
6/* All Rights Reserved. */
7/* */
8/* Permission is hereby granted, free of charge, to use and distribute */
9/* this software and its documentation without restriction, including */
10/* without limitation the rights to use, copy, modify, merge, publish, */
11/* distribute, sublicense, and/or sell copies of this work, and to */
12/* permit persons to whom this work is furnished to do so, subject to */
13/* the following conditions: */
14/* 1. The code must retain the above copyright notice, this list of */
15/* conditions and the following disclaimer. */
16/* 2. Any modifications must be clearly marked as such. */
17/* 3. Original authors' names are not deleted. */
18/* 4. The authors' names are not used to endorse or promote products */
19/* derived from this software without specific prior written */
20/* permission. */
21/* */
22/* THE UNIVERSITY OF EDINBURGH AND THE CONTRIBUTORS TO THIS WORK */
23/* DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING */
24/* ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT */
25/* SHALL THE UNIVERSITY OF EDINBURGH NOR THE CONTRIBUTORS BE LIABLE */
26/* FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES */
27/* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN */
28/* AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, */
29/* ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF */
30/* THIS SOFTWARE. */
31/* */
32/*************************************************************************/
33/* Author : Alan W Black */
34/* Date : February 1998 */
35/*-----------------------------------------------------------------------*/
36/* */
37/* Functions to add Speech Tools basic objects to the SIOD LISP obj */
38/* */
39/* This offers non-intrusive support for arbitrary objects in LISP, */
40/* however because the deletion method are called this needs to access */
41/* Thus if you include siod_est_init(), you'll get Utterances, Nodes */
42/* Stream_Items, Waves and Tracks in your binary */
43/* */
44/*=======================================================================*/
45#include <iostream>
46#include "siod.h"
47#include "ling_class/EST_Utterance.h"
48#include "ling_class/EST_Item.h"
49#include "EST_THash.h"
50#include "EST_Wave.h"
51#include "EST_wave_aux.h"
52#include "EST_Track.h"
53#include "EST_track_aux.h"
54
55Declare_TStringHash_Base(LISP,(LISP)0,NIL)
56
57#if defined(INSTANTIATE_TEMPLATES)
58#include "../base_class/EST_THash.cc"
59
60Instantiate_TStringHash(LISP)
61
62#endif
63
64// To make garbage collection easy the following functions offer an index
65// of arbitrary objects to LISP cells. You can use this to return the
66// same LISP cell for the same object. This is used for utterance
67// objects otherwise I'd need to add reference counts to the utterance
68// itself
69//
70// This is implemented as a hash table of printed address
71// This if fine for hundreds of things, but probably not
72// for thousands of things
74
75static void void_to_addrname(const void *v,EST_String &saddr)
76{
77 char addr[128];
78
79 sprintf(addr,"%p",v);
80 saddr = addr;
81}
82
83// The following are the types for EST objects in LISP, they are set when
84// the objects are registered. I don't think they should be required
85// out side this file so they are static functions like siod_utterance_p
86// should be used elsewhere
87static int tc_utt = -1;
88static int tc_val = -1;
89
90class EST_Utterance *utterance(LISP x)
91{
92 if (TYPEP(x,tc_utt))
93 return (class EST_Utterance *)USERVAL(x);
94 else
95 err("wrong type of argument to get_c_utt",x);
96
97 return NULL; // err doesn't return but compilers don't know that
98}
99
100int utterance_p(LISP x)
101{
102 if (TYPEP(x,tc_utt))
103 return TRUE;
104 else
105 return FALSE;
106}
107
108LISP siod(const class EST_Utterance *u)
109{
110 LISP utt;
112 LISP cell;
113
114 void_to_addrname(u,saddr);
115
116 if ((cell = estobjs.val(saddr)) != NIL)
117 return cell;
118
119 // A new one
120 utt = siod_make_typed_cell(tc_utt,(void *)u);
121
122 // Add to list
123 estobjs.add_item(saddr,utt);
124
125 return utt;
126}
127
128static void utt_free(LISP lutt)
129{
130 class EST_Utterance *u = utterance(lutt);
132
133 void_to_addrname(u,saddr);
134
135 // Mark it unused, this doesn't gc the extra data in the hash
136 // table to hold the index, this might be a problem over very
137 // long runs of the system (i.e. this should be fixed).
138 estobjs.remove_item(saddr);
139 delete u;
140
141
142 USERVAL(lutt) = NULL;
143}
144
145LISP utt_mark(LISP utt)
146{
147 // Should mark all the LISP cells in it
148 // but at present we use the gc_(un)protect mechanism
149 return utt;
150}
151
152// EST_Vals (and everything else)
153class EST_Val &val(LISP x)
154{
155 if (TYPEP(x,tc_val))
156 return *((class EST_Val *)x->storage_as.val.v);
157
158 else
159 err("wrong type of argument to get_c_val",x);
160 // sigh
161 static EST_Val def;
162
163 return def;
164}
165
166LISP val_equal(LISP a,LISP b)
167{
168 if (val(a) == val(b))
169 return truth;
170 else
171 return NIL;
172}
173
174int val_p(LISP x)
175{
176 if (TYPEP(x,tc_val))
177 return TRUE;
178 else
179 return FALSE;
180}
181
182LISP siod(const class EST_Val v)
183{
184 return siod_make_typed_cell(tc_val,new EST_Val(v));
185}
186
187static void val_free(LISP val)
188{
189 class EST_Val *v = (EST_Val *)USERVAL(val);
190 delete v;
191 USERVAL(val) = NULL;
192}
193
194static void val_prin1(LISP v, FILE *fd)
195{
196 char b[1024];
197 fput_st(fd,"#<");
198 fput_st(fd,val(v).type());
199 sprintf(b," %p",val(v).internal_ptr());
200 fput_st(fd,b);
201 fput_st(fd,">");
202}
203
204static void val_print_string(LISP v, char *tkbuffer)
205{
206 sprintf(tkbuffer,"#<%s %p>",val(v).type(),val(v).internal_ptr());
207}
208
209SIOD_REGISTER_CLASS(item,EST_Item)
210SIOD_REGISTER_CLASS(wave,EST_Wave)
211SIOD_REGISTER_CLASS(track,EST_Track)
212SIOD_REGISTER_CLASS(feats,EST_Features)
213
214// This is an example of something that's a little scary and it
215// would be better if we didn't have to do this. Here we define
216// support for LISP's as VAL, even though we've got VAL's a LISPs
217// This allows arbitrary LISP objects to be held as VALs most
218// likely as values in features or being returned by feature functions
219// We have to do some special memory management to do this and
220// you can probably mess things up completely if you start using this
221// arbitrarily
222val_type val_type_scheme = "scheme";
223struct obj_val {LISP l;};
224LISP scheme(const EST_Val &v)
225{
226 if (v.type() == val_type_scheme)
227 return ((obj_val *)v.internal_ptr())->l;
228 else
229 EST_error("val not of type val_type_scheme");
230 return NULL;
231}
232static void val_delete_scheme(void *v)
233{
234 struct obj_val *ov = (struct obj_val *)v;
235 gc_unprotect(&ov->l);
236 wfree(ov);
237}
238
239EST_Val est_val(const obj *v)
240{
241 struct obj_val *ov = walloc(struct obj_val,1);
242 ov->l = (LISP)(void *)v;
243 gc_protect(&ov->l);
244 return EST_Val(val_type_scheme,
245 (void *)ov,
246 val_delete_scheme);
247}
248
249LISP lisp_val(const EST_Val &pv)
250{
251 if (pv.type() == val_unset)
252 {
253 cerr << "EST_Val unset, can't build lisp value" << endl;
254 siod_error();
255 return NIL;
256 }
257 else if (pv.type() == val_int)
258 return flocons(pv.Int());
259 else if (pv.type() == val_float)
260 return flocons(pv.Float());
261 else if (pv.type() == val_string)
262 return strintern(pv.string_only());
263 else if (pv.type() == val_type_scheme)
264 return scheme(pv);
265 else if (pv.type() == val_type_feats)
266 return features_to_lisp(*feats(pv));
267 else
268 return siod(pv);
269}
270
271static int feature_like(LISP v)
272{
273 // True if non nil and assoc like
274 if ((v == NIL) || (!consp(v)))
275 return FALSE;
276 else
277 {
278 LISP p;
279 for (p=v; p != NIL; p=cdr(p))
280 {
281 if (!consp(p) || (!consp(car(p))) || (consp(car(car(p)))))
282 return FALSE;
283 }
284 return TRUE;
285 }
286}
287
288EST_Val val_lisp(LISP v)
289{
290 if (feature_like(v))
291 {
292 EST_Features *f = new EST_Features;
293 lisp_to_features(v,*f);
294 return est_val(f);
295 }
296 else if (FLONUMP(v))
297 return EST_Val(get_c_float(v));
298 else if (TYPEP(v,tc_val))
299 return val(v);
300 else if (TYPEP(v,tc_symbol) || (TYPEP(v,tc_string)))
301 return EST_Val(EST_String(get_c_string(v)));
302 else
303 return est_val(v);
304}
305
306LISP kvlss_to_lisp(const EST_TKVL<EST_String, EST_String> &kvl)
307{
308 LISP l = NIL;
309
311
312 for(p.begin(kvl); p; ++p)
313 {
314 l=cons(cons(rintern(p->k),
315 cons(lisp_val(p->v),NIL)),
316 l);
317 }
318 // reverse it to make it the same order as f, though that shouldn't matter
319 return reverse(l);
320}
321
322void lisp_to_kvlss(LISP l, EST_TKVL<EST_String, EST_String> &kvl)
323{
324 LISP p;
325
326 for (p=l; p; p = cdr(p))
327 kvl.add_item(get_c_string(car(car(p))),
328 get_c_string(car(cdr(car(p)))));
329}
330
331LISP features_to_lisp(EST_Features &f)
332{
333 LISP lf = NIL;
334
336
337 for(p.begin(f); p; ++p)
338 {
339 lf=cons(cons(rintern(p->k),
340 cons(lisp_val(p->v),NIL)),
341 lf);
342 }
343 // reverse it to make it the same order as f, though that shouldn't matter
344 return reverse(lf);
345}
346
347void lisp_to_features(LISP lf,EST_Features &f)
348{
349 LISP p;
350
351 for (p=lf; p; p = cdr(p))
352 f.set_val(get_c_string(car(car(p))),
353 val_lisp(car(cdr(car(p)))));
354}
355
356static LISP feats_set(LISP lfeats, LISP fname, LISP val)
357{
358 // Probably should restrict what can be in fname, not : would be good
359 LISP lf = lfeats;
360 if (lfeats == NIL)
361 {
362 EST_Features *f = new EST_Features;
363 lf = siod(f);
364 }
365 feats(lf)->set_path(get_c_string(fname),val_lisp(val));
366 return lf;
367}
368
369static LISP feats_get(LISP f, LISP fname)
370{
371 return lisp_val(feats(f)->val_path(get_c_string(fname)));
372}
373
374static LISP feats_make()
375{
376 EST_Features *f = new EST_Features;
377 return siod(f);
378}
379
380static LISP feats_tolisp(LISP lf)
381{
382 return features_to_lisp(*feats(lf));
383}
384
385static LISP feats_remove(LISP lf, LISP fname)
386{
387 EST_Features *f = feats(lf);
388 f->remove(get_c_string(fname));
389 return lf;
390}
391
392static LISP feats_present(LISP lf, LISP fname)
393{
394 EST_Features *f = feats(lf);
395 if (f->present(get_c_string(fname)))
396 return truth;
397 else
398 return NIL;
399}
400
401EST_Features &Param()
402{
403 EST_Features *f = feats(siod_get_lval("Param","No Param features set"));
404 return *f;
405}
406
407void siod_est_init()
408{
409 // add EST specific objects as user types to LISP obj
410 long kind;
411
412 // In general to add a type
413 // tc_TYPENAME = siod_register_user_type("TYPENAME");
414 // define above
415 // EST_TYPENAME *get_c_TYPENAME(LISP x) and
416 // int siod_TYPENAME_p(LISP x)
417 // LISP siod_make_utt(EST_TYPENAME *x)
418 // you will often also need to define
419 // TYPENAME_free(LISP x) too if you want the contents gc'd
420 // other options to the set_*_hooks functions allow you to customize
421 // the object's behaviour more
422
423 tc_utt = siod_register_user_type("Utterance");
424 set_gc_hooks(tc_utt, 0, NULL,utt_mark,NULL,utt_free,NULL,&kind);
425
426 tc_val = siod_register_user_type("Val");
427 set_gc_hooks(tc_val, 0, NULL,NULL,NULL,val_free,NULL,&kind);
428 set_print_hooks(tc_val,val_prin1,val_print_string);
429 set_type_hooks(tc_val,NULL,val_equal);
430
431 init_subr_2("feats.get",feats_get,
432 "(feats.get FEATS FEATNAME)\n\
433 Return value of FEATNAME (which may be a simple feature name or a\n\
434 pathname) in FEATS. If FEATS is nil a new feature set is created");
435 init_subr_3("feats.set",feats_set,
436 "(feats.set FEATS FEATNAME VALUE)\n\
437 Set FEATNAME to VALUE in FEATS.");
438 init_subr_2("feats.remove",feats_remove,
439 "(feats.remove FEATS FEATNAME)\n\
440 Remove feature names FEATNAME from FEATS.");
441 init_subr_2("feats.present",feats_present,
442 "(feats.present FEATS FEATNAME)\n\
443 Return t is FEATNAME is present in FEATS, nil otherwise.");
444 init_subr_0("feats.make",feats_make,
445 "(feats.make)\n\
446 Return an new empty features object.");
447 init_subr_1("feats.tolisp",feats_tolisp,
448 "(feats.tolisp FEATS)\n\
449 Gives a lisp representation of the features, this is a debug function\n\
450 and may or may not exist tomorrow.");
451
452}
453
K k
The key.
Definition EST_THash.h:78
V v
The value.
Definition EST_THash.h:80
void begin(const Container &over)
Set the iterator ready to run over this container.
const val_type type(void) const
Definition EST_Val.h:126
EST_Val()
Definition EST_Val.h:88