File: siod_est.cc

package info (click to toggle)
speech-tools 1:2.5.0-5
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 9,848 kB
  • sloc: cpp: 67,350; ansic: 12,175; sh: 4,047; java: 3,748; makefile: 1,109; lisp: 711; perl: 501; awk: 85; xml: 9
file content (453 lines) | stat: -rw-r--r-- 13,118 bytes parent folder | download | duplicates (7)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
/*************************************************************************/
/*                                                                       */
/*                Centre for Speech Technology Research                  */
/*                     University of Edinburgh, UK                       */
/*                      Copyright (c) 1996-1998                          */
/*                        All Rights Reserved.                           */
/*                                                                       */
/*  Permission is hereby granted, free of charge, to use and distribute  */
/*  this software and its documentation without restriction, including   */
/*  without limitation the rights to use, copy, modify, merge, publish,  */
/*  distribute, sublicense, and/or sell copies of this work, and to      */
/*  permit persons to whom this work is furnished to do so, subject to   */
/*  the following conditions:                                            */
/*   1. The code must retain the above copyright notice, this list of    */
/*      conditions and the following disclaimer.                         */
/*   2. Any modifications must be clearly marked as such.                */
/*   3. Original authors' names are not deleted.                         */
/*   4. The authors' names are not used to endorse or promote products   */
/*      derived from this software without specific prior written        */
/*      permission.                                                      */
/*                                                                       */
/*  THE UNIVERSITY OF EDINBURGH AND THE CONTRIBUTORS TO THIS WORK        */
/*  DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING      */
/*  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT   */
/*  SHALL THE UNIVERSITY OF EDINBURGH NOR THE CONTRIBUTORS BE LIABLE     */
/*  FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES    */
/*  WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN   */
/*  AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,          */
/*  ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF       */
/*  THIS SOFTWARE.                                                       */
/*                                                                       */
/*************************************************************************/
/*                     Author :  Alan W Black                            */
/*                     Date   :  February 1998                           */
/*-----------------------------------------------------------------------*/
/*                                                                       */
/* Functions to add Speech Tools basic objects to the SIOD LISP obj      */
/*                                                                       */
/* This offers non-intrusive support for arbitrary objects in LISP,      */
/* however because the deletion method are called this needs to access   */
/* Thus if you include siod_est_init(), you'll get Utterances, Nodes     */
/* Stream_Items, Waves and Tracks in your binary                         */
/*                                                                       */
/*=======================================================================*/
#include <iostream>
#include "siod.h"
#include "ling_class/EST_Utterance.h"
#include "ling_class/EST_Item.h"
#include "EST_THash.h"
#include "EST_Wave.h"
#include "EST_wave_aux.h"
#include "EST_Track.h"
#include "EST_track_aux.h"

Declare_TStringHash_Base(LISP,(LISP)0,NIL)

#if defined(INSTANTIATE_TEMPLATES)
#include "../base_class/EST_THash.cc"

Instantiate_TStringHash(LISP)

#endif

// To make garbage collection easy the following functions offer an index
// of arbitrary objects to LISP cells.  You can use this to return the
// same LISP cell for the same object.  This is used for utterance
// objects otherwise I'd need to add reference counts to the utterance
// itself
//
// This is implemented as a hash table of printed address
// This if fine for hundreds of things, but probably not
// for thousands of things
static EST_TStringHash<LISP> estobjs(100);

static void void_to_addrname(const void *v,EST_String &saddr)
{
    char addr[128];

    sprintf(addr,"%p",v);
    saddr = addr;
}

// The following are the types for EST objects in LISP, they are set when
// the objects are registered.  I don't think they should be required 
// out side this file so they are static functions like siod_utterance_p
// should be used elsewhere
static int tc_utt = -1;
static int tc_val = -1;

class EST_Utterance *utterance(LISP x)
{
    if (TYPEP(x,tc_utt))
	return (class EST_Utterance *)USERVAL(x);
    else
	err("wrong type of argument to get_c_utt",x);

    return NULL;  // err doesn't return but compilers don't know that
}

int utterance_p(LISP x)
{
    if (TYPEP(x,tc_utt))
	return TRUE;
    else
	return FALSE;
}

LISP siod(const class EST_Utterance *u)
{
    LISP utt;
    EST_String saddr;
    LISP cell;

    void_to_addrname(u,saddr);

    if ((cell = estobjs.val(saddr)) != NIL)
	return cell;

    // A new one 
    utt = siod_make_typed_cell(tc_utt,(void *)u);

    // Add to list
    estobjs.add_item(saddr,utt);

    return utt;
}

static void utt_free(LISP lutt)
{
    class EST_Utterance *u = utterance(lutt);
    EST_String saddr;

    void_to_addrname(u,saddr);

    // Mark it unused, this doesn't gc the extra data in the hash
    // table to hold the index, this might be a problem over very
    // long runs of the system (i.e. this should be fixed).
    estobjs.remove_item(saddr);
    delete u;
    

    USERVAL(lutt) = NULL;
}

LISP utt_mark(LISP utt)
{
    // Should mark all the LISP cells in it 
    // but at present we use the gc_(un)protect mechanism 
    return utt;
}

// EST_Vals (and everything else)
class EST_Val &val(LISP x)
{
    if (TYPEP(x,tc_val))
	return *((class EST_Val *)x->storage_as.val.v);

    else
	err("wrong type of argument to get_c_val",x);
    // sigh
    static EST_Val def;

    return def;
}

LISP val_equal(LISP a,LISP b)
{
    if (val(a) == val(b))
	return truth;
    else
	return NIL;
}

int val_p(LISP x)
{
    if (TYPEP(x,tc_val))
	return TRUE;
    else
	return FALSE;
}

LISP siod(const class EST_Val v)
{
    return siod_make_typed_cell(tc_val,new EST_Val(v));
}

static void val_free(LISP val)
{
    class EST_Val *v = (EST_Val *)USERVAL(val);
    delete v;
    USERVAL(val) = NULL;
}

static void val_prin1(LISP v, FILE *fd)
{
    char b[1024];
    fput_st(fd,"#<");
    fput_st(fd,val(v).type());
    sprintf(b," %p",val(v).internal_ptr());
    fput_st(fd,b);
    fput_st(fd,">");
}

static void val_print_string(LISP v, char *tkbuffer)
{
    sprintf(tkbuffer,"#<%s %p>",val(v).type(),val(v).internal_ptr());
}

SIOD_REGISTER_CLASS(item,EST_Item)
SIOD_REGISTER_CLASS(wave,EST_Wave)
SIOD_REGISTER_CLASS(track,EST_Track)
SIOD_REGISTER_CLASS(feats,EST_Features)

// This is an example of something that's a little scary and it
// would be better if we didn't have to do this.  Here we define
// support for LISP's as VAL, even though we've got VAL's a LISPs
// This allows arbitrary LISP objects to be held as VALs most
// likely as values in features or being returned by feature functions
// We have to do some special memory management to do this and 
// you can probably mess things up completely if you start using this
// arbitrarily
val_type val_type_scheme = "scheme";
struct obj_val {LISP l;};
LISP scheme(const EST_Val &v)
{
    if (v.type() == val_type_scheme)
	return ((obj_val *)v.internal_ptr())->l;
    else
	EST_error("val not of type val_type_scheme");
    return NULL;
}
static void val_delete_scheme(void *v)
{
    struct obj_val *ov = (struct obj_val *)v;
    gc_unprotect(&ov->l);
    wfree(ov);
}

EST_Val est_val(const obj *v)
{
    struct obj_val *ov = walloc(struct obj_val,1);
    ov->l = (LISP)(void *)v;
    gc_protect(&ov->l);
    return EST_Val(val_type_scheme,
		   (void *)ov,
		   val_delete_scheme);
}

LISP lisp_val(const EST_Val &pv)
{
    if (pv.type() == val_unset)
    {
	cerr << "EST_Val unset, can't build lisp value" << endl;
	siod_error();
	return NIL;
    }
    else if (pv.type() == val_int)
	return flocons(pv.Int());
    else if (pv.type() == val_float)
	return flocons(pv.Float());
    else if (pv.type() == val_string)
	return strintern(pv.string_only());
    else if (pv.type() == val_type_scheme)
	return scheme(pv);
    else if (pv.type() == val_type_feats)
	return features_to_lisp(*feats(pv));
    else
	return siod(pv);
}

static int feature_like(LISP v)
{
    // True if non nil and assoc like
    if ((v == NIL) || (!consp(v)))
	return FALSE;
    else
    {
	LISP p;
	for (p=v; p != NIL; p=cdr(p))
	{
	    if (!consp(p) || (!consp(car(p))) || (consp(car(car(p)))))
		return FALSE;
	}
	return TRUE;
    }
}

EST_Val val_lisp(LISP v)
{
    if (feature_like(v))
    {
	EST_Features *f = new EST_Features;
	lisp_to_features(v,*f);
	return est_val(f);
    }
    else if (FLONUMP(v))
	return EST_Val(get_c_float(v));
    else if (TYPEP(v,tc_val))
	return val(v);
    else if (TYPEP(v,tc_symbol) || (TYPEP(v,tc_string)))
	return EST_Val(EST_String(get_c_string(v)));
    else 
	return est_val(v);
}

LISP kvlss_to_lisp(const EST_TKVL<EST_String, EST_String> &kvl)
{
    LISP l = NIL;

    EST_TKVL<EST_String, EST_String>::Entries p;

    for(p.begin(kvl); p; ++p)
      {
	l=cons(cons(rintern(p->k),
		     cons(lisp_val(p->v),NIL)),
		l);
      }
    // reverse it to make it the same order as f, though that shouldn't matter
    return reverse(l);
}

void lisp_to_kvlss(LISP l, EST_TKVL<EST_String, EST_String> &kvl)
{
    LISP p;

    for (p=l; p; p = cdr(p))
	kvl.add_item(get_c_string(car(car(p))),
		     get_c_string(car(cdr(car(p)))));
}

LISP features_to_lisp(EST_Features &f)
{
    LISP lf = NIL;

    EST_Features::Entries p;

    for(p.begin(f); p; ++p)
      {
	lf=cons(cons(rintern(p->k),
		     cons(lisp_val(p->v),NIL)),
		lf);
      }
    // reverse it to make it the same order as f, though that shouldn't matter
    return reverse(lf);
}

void lisp_to_features(LISP lf,EST_Features &f)
{
    LISP p;

    for (p=lf; p; p = cdr(p))
	f.set_val(get_c_string(car(car(p))),
		  val_lisp(car(cdr(car(p)))));
}

static LISP feats_set(LISP lfeats, LISP fname, LISP val)
{
    // Probably should restrict what can be in fname, not : would be good
    LISP lf = lfeats;
    if (lfeats == NIL)
    {
	EST_Features *f = new EST_Features;
	lf = siod(f);
    }
    feats(lf)->set_path(get_c_string(fname),val_lisp(val));
    return lf;
}

static LISP feats_get(LISP f, LISP fname)
{
    return lisp_val(feats(f)->val_path(get_c_string(fname)));
}

static LISP feats_make()
{
    EST_Features *f = new EST_Features;
    return siod(f);
}

static LISP feats_tolisp(LISP lf)
{
    return features_to_lisp(*feats(lf));
}

static LISP feats_remove(LISP lf, LISP fname)
{
    EST_Features *f = feats(lf);
    f->remove(get_c_string(fname));
    return lf;
}

static LISP feats_present(LISP lf, LISP fname)
{
    EST_Features *f = feats(lf);
    if (f->present(get_c_string(fname)))
	return truth;
    else
	return NIL;
}

EST_Features &Param()
{
    EST_Features *f = feats(siod_get_lval("Param","No Param features set"));
    return *f;
}

void siod_est_init()
{
    // add EST specific objects as user types to LISP obj
    long kind;

    // In general to add a type
    // tc_TYPENAME = siod_register_user_type("TYPENAME");
    // define above 
    //    EST_TYPENAME *get_c_TYPENAME(LISP x) and
    //    int siod_TYPENAME_p(LISP x)
    //    LISP siod_make_utt(EST_TYPENAME *x)
    // you will often also need to define 
    //    TYPENAME_free(LISP x) too if you want the contents gc'd
    // other options to the set_*_hooks functions allow you to customize
    // the object's behaviour more

    tc_utt = siod_register_user_type("Utterance");
    set_gc_hooks(tc_utt, 0, NULL,utt_mark,NULL,utt_free,NULL,&kind);

    tc_val = siod_register_user_type("Val");
    set_gc_hooks(tc_val, 0, NULL,NULL,NULL,val_free,NULL,&kind);
    set_print_hooks(tc_val,val_prin1,val_print_string);
    set_type_hooks(tc_val,NULL,val_equal);

    init_subr_2("feats.get",feats_get,
    "(feats.get FEATS FEATNAME)\n\
   Return value of FEATNAME (which may be a simple feature name or a\n\
   pathname) in FEATS.  If FEATS is nil a new feature set is created");
    init_subr_3("feats.set",feats_set,
    "(feats.set FEATS FEATNAME VALUE)\n\
   Set FEATNAME to VALUE in FEATS.");
    init_subr_2("feats.remove",feats_remove,
    "(feats.remove FEATS FEATNAME)\n\
   Remove feature names FEATNAME from FEATS.");
    init_subr_2("feats.present",feats_present,
    "(feats.present FEATS FEATNAME)\n\
   Return t is FEATNAME is present in FEATS, nil otherwise.");
    init_subr_0("feats.make",feats_make,
    "(feats.make)\n\
   Return an new empty features object.");
    init_subr_1("feats.tolisp",feats_tolisp,
    "(feats.tolisp FEATS)\n\
   Gives a lisp representation of the features, this is a debug function\n\
   and may or may not exist tomorrow.");

}