« back to all changes in this revision
Viewing changes to src/ctl.c
- browse files at revision 4
- compare with another revision
- download diff
- download tarball
- view history from revision 4
- Committer: Bazaar Package Importer
- Author(s): Josselin Mouette
- Date: 2006-05-01 20:25:01 UTC
- mfrom: (1.1.2 upstream)
- Revision ID: james.westby@ubuntu.com-20060501202501-lytbmb3oevyoqzxi
Tags: 3.0.1-1
* New upstream release (closes: #361676).
* Major rework of the debian/ directory. Switch to cdbs.
* Migrate Scheme files to a versioned location to allow several
versions to be installed at once.
* Write a Makefile to put with the example.
* Update copyright, the library is now GPL.
* Use gfortran for the F77 wrappers.
* Standards-version is 3.7.0.
* Major rework of the debian/ directory. Switch to cdbs.
* Migrate Scheme files to a versioned location to allow several
versions to be installed at once.
* Write a Makefile to put with the example.
* Update copyright, the library is now GPL.
* Use gfortran for the F77 wrappers.
* Standards-version is 3.7.0.
added
removed
src/ctl.c
1
/* libctl: flexible Guile-based control files for scientific software
2
* Copyright (C) 1998, 1999, 2000, 2001, 2002, 2006, Steven G. Johnson
3
*
4
* This library is free software; you can redistribute it and/or
5
* modify it under the terms of the GNU Lesser General Public
6
* License as published by the Free Software Foundation; either
7
* version 2 of the License, or (at your option) any later version.
8
*
9
* This library is distributed in the hope that it will be useful,
10
* but WITHOUT ANY WARRANTY; without even the implied warranty of
11
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12
* Lesser General Public License for more details.
13
*
14
* You should have received a copy of the GNU Lesser General Public
15
* License along with this library; if not, write to the
16
* Free Software Foundation, Inc., 59 Temple Place - Suite 330,
17
* Boston, MA 02111-1307, USA.
18
*
19
* Steven G. Johnson can be contacted at stevenj@alum.mit.edu.
20
*/
21
22
#include <stdlib.h>
23
#include <stdio.h>
24
#include <string.h>
25
#include <math.h>
26
27
#include "ctl.h"
28
29
/**************************************************************************/
30
31
/* Functions missing from Guile 1.2: */
32
33
#ifndef HAVE_GH_BOOL2SCM
34
/* Guile 1.2 is missing gh_bool2scm for some reason; redefine: */
35
SCM bool2scm(boolean b) { return (b ? SCM_BOOL_T : SCM_BOOL_F); }
36
#endif
37
38
#ifndef HAVE_GH_LENGTH
39
#define gh_length gh_list_length
40
#endif
41
42
#ifndef HAVE_GH_LIST_REF
43
/* Guile 1.2 doesn't have the gh_list_ref function. Sigh. */
44
/* Note: index must be in [0,list_length(l) - 1]. We don't check! */
45
static SCM list_ref(list l, int index)
46
{
47
SCM cur = SCM_UNSPECIFIED, rest = l;
48
49
while (index >= 0) {
50
cur = gh_car(rest);
51
rest = gh_cdr(rest);
52
--index;
53
}
54
return cur;
55
}
56
57
#else /* HAVE_GH_LIST_REF */
58
#define list_ref(l,index) gh_list_ref(l,gh_int2scm(index))
59
#endif
60
61
#ifndef HAVE_GH_VECTOR_REF
62
#define gh_vector_ref gh_vref
63
#endif
64
65
/**************************************************************************/
66
67
/* Scheme file loading (don't use gh_load directly because subsequent
68
loads won't use the correct path name). Uses our "include" function
69
from include.scm, or defaults to gh_load if this function isn't
70
defined. */
71
72
void ctl_include(char *filename)
73
{
74
SCM include_proc = gh_lookup("include");
75
if (include_proc == SCM_UNDEFINED)
76
gh_load(filename);
77
else
78
gh_call1(include_proc, gh_str02scm(filename));
79
}
80
81
/* convert a pathname into one relative to the current include dir */
82
char *ctl_fix_path(const char *path)
83
{
84
char *newpath;
85
if (path[0] != '/') {
86
SCM include_dir = gh_lookup("include-dir");
87
if (include_dir != SCM_UNDEFINED) {
88
char *dir = gh_scm2newstr(include_dir, NULL);
89
newpath = (char *) malloc(sizeof(char) * (strlen(dir) +
90
strlen(path) + 2));
91
strcpy(newpath, dir);
92
free(dir);
93
if (newpath[0] && newpath[strlen(newpath)-1] != '/')
94
strcat(newpath, "/");
95
strcat(newpath, path);
96
return newpath;
97
}
98
}
99
newpath = (char *) malloc(sizeof(char) * (strlen(path) + 1));
100
strcpy(newpath, path);
101
return newpath;
102
}
103
104
/**************************************************************************/
105
106
/* vector3 and matrix3x3 utilities: */
107
108
number vector3_dot(vector3 v1,vector3 v2)
109
{
110
return (v1.x * v2.x + v1.y * v2.y + v1.z * v2.z);
111
}
112
113
number vector3_norm(vector3 v)
114
{
115
return (sqrt(vector3_dot(v,v)));
116
}
117
118
vector3 vector3_scale(number s, vector3 v)
119
{
120
vector3 vnew;
121
122
vnew.x = s * v.x;
123
vnew.y = s * v.y;
124
vnew.z = s * v.z;
125
return vnew;
126
}
127
128
vector3 unit_vector3(vector3 v)
129
{
130
number norm = vector3_norm(v);
131
if (norm == 0.0)
132
return v;
133
else
134
return vector3_scale(1.0/norm, v);
135
}
136
137
vector3 vector3_plus(vector3 v1,vector3 v2)
138
{
139
vector3 vnew;
140
141
vnew.x = v1.x + v2.x;
142
vnew.y = v1.y + v2.y;
143
vnew.z = v1.z + v2.z;
144
return vnew;
145
}
146
147
vector3 vector3_minus(vector3 v1,vector3 v2)
148
{
149
vector3 vnew;
150
151
vnew.x = v1.x - v2.x;
152
vnew.y = v1.y - v2.y;
153
vnew.z = v1.z - v2.z;
154
return vnew;
155
}
156
157
vector3 vector3_cross(vector3 v1,vector3 v2)
158
{
159
vector3 vnew;
160
161
vnew.x = v1.y * v2.z - v2.y * v1.z;
162
vnew.y = v1.z * v2.x - v2.z * v1.x;
163
vnew.z = v1.x * v2.y - v2.x * v1.y;
164
return vnew;
165
}
166
167
int vector3_equal(vector3 v1, vector3 v2)
168
{
169
return (v1.x == v2.x && v1.y == v2.y && v1.z == v2.z);
170
}
171
172
vector3 matrix3x3_vector3_mult(matrix3x3 m, vector3 v)
173
{
174
vector3 vnew;
175
176
vnew.x = m.c0.x * v.x + m.c1.x * v.y + m.c2.x * v.z;
177
vnew.y = m.c0.y * v.x + m.c1.y * v.y + m.c2.y * v.z;
178
vnew.z = m.c0.z * v.x + m.c1.z * v.y + m.c2.z * v.z;
179
return vnew;
180
}
181
182
vector3 matrix3x3_transpose_vector3_mult(matrix3x3 m, vector3 v)
183
{
184
vector3 vnew;
185
186
vnew.x = m.c0.x * v.x + m.c0.y * v.y + m.c0.z * v.z;
187
vnew.y = m.c1.x * v.x + m.c1.y * v.y + m.c1.z * v.z;
188
vnew.z = m.c2.x * v.x + m.c2.y * v.y + m.c2.z * v.z;
189
return vnew;
190
}
191
192
matrix3x3 matrix3x3_mult(matrix3x3 m1, matrix3x3 m2)
193
{
194
matrix3x3 m;
195
196
m.c0.x = m1.c0.x * m2.c0.x + m1.c1.x * m2.c0.y + m1.c2.x * m2.c0.z;
197
m.c0.y = m1.c0.y * m2.c0.x + m1.c1.y * m2.c0.y + m1.c2.y * m2.c0.z;
198
m.c0.z = m1.c0.z * m2.c0.x + m1.c1.z * m2.c0.y + m1.c2.z * m2.c0.z;
199
200
m.c1.x = m1.c0.x * m2.c1.x + m1.c1.x * m2.c1.y + m1.c2.x * m2.c1.z;
201
m.c1.y = m1.c0.y * m2.c1.x + m1.c1.y * m2.c1.y + m1.c2.y * m2.c1.z;
202
m.c1.z = m1.c0.z * m2.c1.x + m1.c1.z * m2.c1.y + m1.c2.z * m2.c1.z;
203
204
m.c2.x = m1.c0.x * m2.c2.x + m1.c1.x * m2.c2.y + m1.c2.x * m2.c2.z;
205
m.c2.y = m1.c0.y * m2.c2.x + m1.c1.y * m2.c2.y + m1.c2.y * m2.c2.z;
206
m.c2.z = m1.c0.z * m2.c2.x + m1.c1.z * m2.c2.y + m1.c2.z * m2.c2.z;
207
208
return m;
209
}
210
211
matrix3x3 matrix3x3_transpose(matrix3x3 m)
212
{
213
matrix3x3 mt;
214
215
mt.c0.x = m.c0.x;
216
mt.c1.x = m.c0.y;
217
mt.c2.x = m.c0.z;
218
mt.c0.y = m.c1.x;
219
mt.c1.y = m.c1.y;
220
mt.c2.y = m.c1.z;
221
mt.c0.z = m.c2.x;
222
mt.c1.z = m.c2.y;
223
mt.c2.z = m.c2.z;
224
return mt;
225
}
226
227
number matrix3x3_determinant(matrix3x3 m)
228
{
229
return(m.c0.x*m.c1.y*m.c2.z - m.c2.x*m.c1.y*m.c0.z +
230
m.c1.x*m.c2.y*m.c0.z + m.c0.y*m.c1.z*m.c2.x -
231
m.c1.x*m.c0.y*m.c2.z - m.c2.y*m.c1.z*m.c0.x);
232
}
233
234
matrix3x3 matrix3x3_inverse(matrix3x3 m)
235
{
236
matrix3x3 minv;
237
number detinv = matrix3x3_determinant(m);
238
239
if (detinv == 0.0) {
240
fprintf(stderr, "error: singular matrix in matrix3x3_inverse!\n");
241
exit(EXIT_FAILURE);
242
}
243
detinv = 1.0/detinv;
244
245
minv.c0.x = detinv * (m.c1.y * m.c2.z - m.c2.y * m.c1.z);
246
minv.c1.y = detinv * (m.c0.x * m.c2.z - m.c2.x * m.c0.z);
247
minv.c2.z = detinv * (m.c1.y * m.c0.x - m.c0.y * m.c1.x);
248
249
minv.c0.z = detinv * (m.c0.y * m.c1.z - m.c1.y * m.c0.z);
250
minv.c0.y = -detinv * (m.c0.y * m.c2.z - m.c2.y * m.c0.z);
251
minv.c1.z = -detinv * (m.c0.x * m.c1.z - m.c1.x * m.c0.z);
252
253
minv.c2.x = detinv * (m.c1.x * m.c2.y - m.c1.y * m.c2.x);
254
minv.c1.x = -detinv * (m.c1.x * m.c2.z - m.c1.z * m.c2.x);
255
minv.c2.y = -detinv * (m.c0.x * m.c2.y - m.c0.y * m.c2.x);
256
257
return minv;
258
}
259
260
int matrix3x3_equal(matrix3x3 m1, matrix3x3 m2)
261
{
262
return (vector3_equal(m1.c0, m2.c0)
263
&& vector3_equal(m1.c1, m2.c1)
264
&& vector3_equal(m1.c2, m2.c2));
265
}
266
267
vector3 matrix3x3_row1(matrix3x3 m)
268
{
269
vector3 v;
270
v.x = m.c0.x;
271
v.y = m.c1.x;
272
v.z = m.c2.x;
273
return v;
274
}
275
276
vector3 matrix3x3_row2(matrix3x3 m)
277
{
278
vector3 v;
279
v.x = m.c0.y;
280
v.y = m.c1.y;
281
v.z = m.c2.y;
282
return v;
283
}
284
285
vector3 matrix3x3_row3(matrix3x3 m)
286
{
287
vector3 v;
288
v.x = m.c0.z;
289
v.y = m.c1.z;
290
v.z = m.c2.z;
291
return v;
292
}
293
294
/**************************************************************************/
295
296
/* complex number utilities */
297
298
cnumber make_cnumber(number r, number i)
299
{
300
cnumber c;
301
c.re = r; c.im = i;
302
return c;
303
}
304
305
cnumber cnumber_conj(cnumber c)
306
{
307
return make_cnumber(c.re, -c.im);
308
}
309
310
int cnumber_equal(cnumber c1, cnumber c2)
311
{
312
return (c1.re == c2.re && c1.im == c2.im);
313
}
314
315
vector3 cvector3_re(cvector3 cv)
316
{
317
vector3 v;
318
v.x = cv.x.re; v.y = cv.y.re; v.z = cv.z.re;
319
return v;
320
}
321
322
vector3 cvector3_im(cvector3 cv)
323
{
324
vector3 v;
325
v.x = cv.x.im; v.y = cv.y.im; v.z = cv.z.im;
326
return v;
327
}
328
329
cvector3 make_cvector3(vector3 vr, vector3 vi)
330
{
331
cvector3 cv;
332
cv.x = make_cnumber(vr.x, vi.x);
333
cv.y = make_cnumber(vr.y, vi.y);
334
cv.z = make_cnumber(vr.z, vi.z);
335
return cv;
336
}
337
338
int cvector3_equal(cvector3 v1, cvector3 v2)
339
{
340
return (vector3_equal(cvector3_re(v1), cvector3_re(v2)) &&
341
vector3_equal(cvector3_im(v1), cvector3_im(v2)));
342
}
343
344
matrix3x3 cmatrix3x3_re(cmatrix3x3 cm)
345
{
346
matrix3x3 m;
347
m.c0 = cvector3_re(cm.c0);
348
m.c1 = cvector3_re(cm.c1);
349
m.c2 = cvector3_re(cm.c2);
350
return m;
351
}
352
353
matrix3x3 cmatrix3x3_im(cmatrix3x3 cm)
354
{
355
matrix3x3 m;
356
m.c0 = cvector3_im(cm.c0);
357
m.c1 = cvector3_im(cm.c1);
358
m.c2 = cvector3_im(cm.c2);
359
return m;
360
}
361
362
cmatrix3x3 make_cmatrix3x3(matrix3x3 mr, matrix3x3 mi)
363
{
364
cmatrix3x3 cm;
365
cm.c0 = make_cvector3(mr.c0, mi.c0);
366
cm.c1 = make_cvector3(mr.c1, mi.c1);
367
cm.c2 = make_cvector3(mr.c2, mi.c2);
368
return cm;
369
}
370
371
cmatrix3x3 make_hermitian_cmatrix3x3(number m00, number m11, number m22,
372
cnumber m01, cnumber m02, cnumber m12)
373
{
374
cmatrix3x3 cm;
375
cm.c0.x = make_cnumber(m00, 0);
376
cm.c1.y = make_cnumber(m11, 0);
377
cm.c2.z = make_cnumber(m22, 0);
378
cm.c1.x = m01; cm.c0.y = cnumber_conj(m01);
379
cm.c2.x = m02; cm.c0.z = cnumber_conj(m02);
380
cm.c2.y = m12; cm.c1.z = cnumber_conj(m12);
381
return cm;
382
}
383
384
int cmatrix3x3_equal(cmatrix3x3 m1, cmatrix3x3 m2)
385
{
386
return (matrix3x3_equal(cmatrix3x3_re(m1), cmatrix3x3_re(m2)) &&
387
matrix3x3_equal(cmatrix3x3_im(m1), cmatrix3x3_im(m2)));
388
}
389
390
/**************************************************************************/
391
392
/* type conversion */
393
394
vector3 scm2vector3(SCM sv)
395
{
396
vector3 v;
397
398
v.x = gh_scm2double(gh_vector_ref(sv,gh_int2scm(0)));
399
v.y = gh_scm2double(gh_vector_ref(sv,gh_int2scm(1)));
400
v.z = gh_scm2double(gh_vector_ref(sv,gh_int2scm(2)));
401
return v;
402
}
403
404
matrix3x3 scm2matrix3x3(SCM sm)
405
{
406
matrix3x3 m;
407
408
m.c0 = scm2vector3(gh_vector_ref(sm,gh_int2scm(0)));
409
m.c1 = scm2vector3(gh_vector_ref(sm,gh_int2scm(1)));
410
m.c2 = scm2vector3(gh_vector_ref(sm,gh_int2scm(2)));
411
return m;
412
}
413
414
static SCM make_vector3(SCM x, SCM y, SCM z)
415
{
416
SCM vscm, *data;
417
vscm = scm_c_make_vector(3, SCM_UNSPECIFIED);
418
data = SCM_VELTS(vscm);
419
data[0] = x;
420
data[1] = y;
421
data[2] = z;
422
return vscm;
423
}
424
425
SCM vector32scm(vector3 v)
426
{
427
return make_vector3(gh_double2scm(v.x),
428
gh_double2scm(v.y),
429
gh_double2scm(v.z));
430
}
431
432
SCM matrix3x32scm(matrix3x3 m)
433
{
434
return make_vector3(vector32scm(m.c0),
435
vector32scm(m.c1),
436
vector32scm(m.c2));
437
}
438
439
cnumber scm2cnumber(SCM sx)
440
{
441
#ifdef HAVE_SCM_COMPLEXP
442
if (scm_real_p(sx) && !(SCM_COMPLEXP(sx)))
443
return make_cnumber(gh_scm2double(sx), 0.0);
444
else
445
return make_cnumber(SCM_COMPLEX_REAL(sx), SCM_COMPLEX_IMAG(sx));
446
#else
447
if (scm_real_p(sx) && !(SCM_NIMP(sx) && SCM_INEXP(sx) && SCM_CPLXP(sx)))
448
return make_cnumber(gh_scm2double(sx), 0.0);
449
else
450
return make_cnumber(SCM_REALPART(sx), SCM_IMAG(sx));
451
#endif
452
}
453
454
SCM cnumber2scm(cnumber x)
455
{
456
#ifdef HAVE_SCM_MAKE_COMPLEX
457
return scm_make_complex(x.re, x.im); /* Guile 1.5 */
458
#else
459
if (x.im == 0.0)
460
return gh_double2scm(x.re);
461
else
462
return scm_makdbl(x.re, x.im);
463
#endif
464
}
465
466
cvector3 scm2cvector3(SCM sv)
467
{
468
cvector3 v;
469
470
v.x = scm2cnumber(gh_vector_ref(sv,gh_int2scm(0)));
471
v.y = scm2cnumber(gh_vector_ref(sv,gh_int2scm(1)));
472
v.z = scm2cnumber(gh_vector_ref(sv,gh_int2scm(2)));
473
return v;
474
}
475
476
cmatrix3x3 scm2cmatrix3x3(SCM sm)
477
{
478
cmatrix3x3 m;
479
480
m.c0 = scm2cvector3(gh_vector_ref(sm,gh_int2scm(0)));
481
m.c1 = scm2cvector3(gh_vector_ref(sm,gh_int2scm(1)));
482
m.c2 = scm2cvector3(gh_vector_ref(sm,gh_int2scm(2)));
483
return m;
484
}
485
486
SCM cvector32scm(cvector3 v)
487
{
488
return make_vector3(cnumber2scm(v.x),
489
cnumber2scm(v.y),
490
cnumber2scm(v.z));
491
}
492
493
SCM cmatrix3x32scm(cmatrix3x3 m)
494
{
495
return make_vector3(cvector32scm(m.c0),
496
cvector32scm(m.c1),
497
cvector32scm(m.c2));
498
}
499
500
/**************************************************************************/
501
502
/* variable get/set functions */
503
504
/**** Getters ****/
505
506
integer ctl_get_integer(char *identifier)
507
{
508
return(gh_scm2int(gh_lookup(identifier)));
509
}
510
511
number ctl_get_number(char *identifier)
512
{
513
return(gh_scm2double(gh_lookup(identifier)));
514
}
515
516
cnumber ctl_get_cnumber(char *identifier)
517
{
518
return(scm2cnumber(gh_lookup(identifier)));
519
}
520
521
boolean ctl_get_boolean(char *identifier)
522
{
523
return(gh_scm2bool(gh_lookup(identifier)));
524
}
525
526
char* ctl_get_string(char *identifier)
527
{
528
return(gh_scm2newstr(gh_lookup(identifier), NULL));
529
}
530
531
vector3 ctl_get_vector3(char *identifier)
532
{
533
return(scm2vector3(gh_lookup(identifier)));
534
}
535
536
matrix3x3 ctl_get_matrix3x3(char *identifier)
537
{
538
return(scm2matrix3x3(gh_lookup(identifier)));
539
}
540
541
cvector3 ctl_get_cvector3(char *identifier)
542
{
543
return(scm2cvector3(gh_lookup(identifier)));
544
}
545
546
cmatrix3x3 ctl_get_cmatrix3x3(char *identifier)
547
{
548
return(scm2cmatrix3x3(gh_lookup(identifier)));
549
}
550
551
list ctl_get_list(char *identifier)
552
{
553
return(gh_lookup(identifier));
554
}
555
556
object ctl_get_object(char *identifier)
557
{
558
return(gh_lookup(identifier));
559
}
560
561
function ctl_get_function(char *identifier)
562
{
563
return(gh_lookup(identifier));
564
}
565
566
SCM ctl_get_SCM(char *identifier)
567
{
568
return(gh_lookup(identifier));
569
}
570
571
/**** Setters ****/
572
573
/* UGLY hack alert! There doesn't seem to be any clean way of setting
574
Scheme variables from C in Guile (e.g. no gh_* interface).
575
576
One option is to use scm_symbol_set_x (symbol-set! in Scheme), but
577
I'm not sure how to get this to work in Guile 1.3 because of the
578
%&*@^-ing module system (I need to pass some module for the first
579
parameter, but I don't know what to pass).
580
581
Instead, I hacked together the following my_symbol_set_x routine,
582
using the functions scm_symbol_value0 and scm_symbol_set_x from the
583
Guile 1.3 sources. (scm_symbol_value0 has the virtue of looking in
584
the correct module somehow; I also used this function to replace
585
gh_lookup, which broke in Guile 1.3 as well...sigh.)
586
587
Note that I can't call "set!" because it is really a macro.
588
589
All the ugliness is confined to the set_value() routine, though.
590
591
Update: in Guile 1.5, we can call scm_variable_set_x (equivalent
592
to variable-set!) to set values of variables, which are looked up
593
via scm_c_lookup (which doesn't exist in Guile 1.3.x). */
594
595
#if !(defined(HAVE_SCM_VARIABLE_SET_X) && defined(HAVE_SCM_C_LOOKUP))
596
# define USE_MY_SYMBOL_SET_X 1 /* use the hack */
597
#endif
598
599
#ifdef USE_MY_SYMBOL_SET_X
600
static SCM my_symbol_set_x(char *name, SCM v)
601
{
602
/* code swiped from scm_symbol_value0 and scm_symbol_set_x */
603
SCM symbol = scm_intern_obarray_soft(name, strlen (name), scm_symhash, 0);
604
SCM vcell = scm_sym2vcell (SCM_CAR (symbol),
605
SCM_CDR (scm_top_level_lookup_closure_var),
606
SCM_BOOL_F);
607
if (SCM_FALSEP (vcell))
608
return SCM_UNDEFINED;
609
SCM_SETCDR (vcell, v);
610
return SCM_UNSPECIFIED;
611
}
612
#endif
613
614
static void set_value(char *identifier, SCM value)
615
{
616
#if defined(USE_SCM_SYMBOL_SET_X) /* worked in Guile 1.1, 1.2 */
617
scm_symbol_set_x(SCM_BOOL_F, gh_symbol2scm(identifier), value);
618
#elif defined(HAVE_SCM_VARIABLE_SET_X) && defined(HAVE_SCM_C_LOOKUP)
619
scm_variable_set_x(scm_c_lookup(identifier), value);
620
#elif defined(USE_MY_SYMBOL_SET_X)
621
my_symbol_set_x(identifier, value);
622
#endif
623
}
624
625
void ctl_set_integer(char *identifier, integer value)
626
{
627
set_value(identifier, gh_int2scm(value));
628
}
629
630
void ctl_set_number(char *identifier, number value)
631
{
632
set_value(identifier, gh_double2scm(value));
633
}
634
635
void ctl_set_cnumber(char *identifier, cnumber value)
636
{
637
set_value(identifier, cnumber2scm(value));
638
}
639
640
void ctl_set_boolean(char *identifier, boolean value)
641
{
642
set_value(identifier, gh_bool2scm(value));
643
}
644
645
void ctl_set_string(char *identifier, char *value)
646
{
647
set_value(identifier, gh_str02scm(value));
648
}
649
650
void ctl_set_vector3(char *identifier, vector3 value)
651
{
652
set_value(identifier, vector32scm(value));
653
}
654
655
void ctl_set_matrix3x3(char *identifier, matrix3x3 value)
656
{
657
set_value(identifier, matrix3x32scm(value));
658
}
659
660
void ctl_set_cvector3(char *identifier, cvector3 value)
661
{
662
set_value(identifier, cvector32scm(value));
663
}
664
665
void ctl_set_cmatrix3x3(char *identifier, cmatrix3x3 value)
666
{
667
set_value(identifier, cmatrix3x32scm(value));
668
}
669
670
void ctl_set_list(char *identifier, list value)
671
{
672
set_value(identifier, value);
673
}
674
675
void ctl_set_object(char *identifier, object value)
676
{
677
set_value(identifier, value);
678
}
679
680
void ctl_set_function(char *identifier, function value)
681
{
682
set_value(identifier, value);
683
}
684
685
void ctl_set_SCM(char *identifier, SCM value)
686
{
687
set_value(identifier, value);
688
}
689
690
/**************************************************************************/
691
692
/* list traversal */
693
694
int list_length(list l)
695
{
696
return(gh_length(l));
697
}
698
699
integer integer_list_ref(list l, int index)
700
{
701
return(gh_scm2int(list_ref(l,index)));
702
}
703
704
number number_list_ref(list l, int index)
705
{
706
return(gh_scm2double(list_ref(l,index)));
707
}
708
709
cnumber cnumber_list_ref(list l, int index)
710
{
711
return(scm2cnumber(list_ref(l,index)));
712
}
713
714
boolean boolean_list_ref(list l, int index)
715
{
716
return(SCM_BOOL_F != list_ref(l,index));
717
}
718
719
char* string_list_ref(list l, int index)
720
{
721
return(gh_scm2newstr(list_ref(l,index),NULL));
722
}
723
724
vector3 vector3_list_ref(list l, int index)
725
{
726
return(scm2vector3(list_ref(l,index)));
727
}
728
729
matrix3x3 matrix3x3_list_ref(list l, int index)
730
{
731
return(scm2matrix3x3(list_ref(l,index)));
732
}
733
734
cvector3 cvector3_list_ref(list l, int index)
735
{
736
return(scm2cvector3(list_ref(l,index)));
737
}
738
739
cmatrix3x3 cmatrix3x3_list_ref(list l, int index)
740
{
741
return(scm2cmatrix3x3(list_ref(l,index)));
742
}
743
744
list list_list_ref(list l, int index)
745
{
746
return(list_ref(l,index));
747
}
748
749
object object_list_ref(list l, int index)
750
{
751
return(list_ref(l,index));
752
}
753
754
function function_list_ref(list l, int index)
755
{
756
return(list_ref(l,index));
757
}
758
759
SCM SCM_list_ref(list l, int index)
760
{
761
return(list_ref(l,index));
762
}
763
764
/**************************************************************************/
765
766
/* list creation */
767
768
#define MAKE_LIST(conv) \
769
{ \
770
int i; \
771
list cur_list = SCM_EOL; \
772
for (i = num_items - 1; i >= 0; --i) \
773
cur_list = gh_cons(conv (items[i]), cur_list); \
774
return(cur_list); \
775
} \
776
777
list make_integer_list(int num_items, const integer *items)
778
MAKE_LIST(gh_int2scm)
779
780
list make_number_list(int num_items, const number *items)
781
MAKE_LIST(gh_double2scm)
782
783
list make_cnumber_list(int num_items, const cnumber *items)
784
MAKE_LIST(cnumber2scm)
785
786
list make_boolean_list(int num_items, const boolean *items)
787
MAKE_LIST(gh_bool2scm)
788
789
list make_string_list(int num_items, const char **items)
790
MAKE_LIST(gh_str02scm)
791
792
list make_vector3_list(int num_items, const vector3 *items)
793
MAKE_LIST(vector32scm)
794
795
list make_matrix3x3_list(int num_items, const matrix3x3 *items)
796
MAKE_LIST(matrix3x32scm)
797
798
list make_cvector3_list(int num_items, const cvector3 *items)
799
MAKE_LIST(cvector32scm)
800
801
list make_cmatrix3x3_list(int num_items, const cmatrix3x3 *items)
802
MAKE_LIST(cmatrix3x32scm)
803
804
#define NO_CONVERSION
805
806
list make_list_list(int num_items, const list *items)
807
MAKE_LIST(NO_CONVERSION)
808
809
list make_object_list(int num_items, const object *items)
810
MAKE_LIST(NO_CONVERSION)
811
812
list make_function_list(int num_items, const object *items)
813
MAKE_LIST(NO_CONVERSION)
814
815
list make_SCM_list(int num_items, const object *items)
816
MAKE_LIST(NO_CONVERSION)
817
818
819
/**************************************************************************/
820
821
/* object properties */
822
823
boolean object_is_member(char *type_name, object o)
824
{
825
return(SCM_BOOL_F != gh_call2(gh_lookup("object-member?"),
826
gh_symbol2scm(type_name),
827
o));
828
}
829
830
static SCM object_property_value(object o, char *property_name)
831
{
832
return(gh_call2(gh_lookup("object-property-value"),
833
o,
834
gh_symbol2scm(property_name)));
835
}
836
837
integer integer_object_property(object o, char *property_name)
838
{
839
return(gh_scm2int(object_property_value(o,property_name)));
840
}
841
842
number number_object_property(object o, char *property_name)
843
{
844
return(gh_scm2double(object_property_value(o,property_name)));
845
}
846
847
cnumber cnumber_object_property(object o, char *property_name)
848
{
849
return(scm2cnumber(object_property_value(o,property_name)));
850
}
851
852
boolean boolean_object_property(object o, char *property_name)
853
{
854
return(SCM_BOOL_F != object_property_value(o,property_name));
855
}
856
857
char* string_object_property(object o, char *property_name)
858
{
859
return(gh_scm2newstr(object_property_value(o,property_name),NULL));
860
}
861
862
vector3 vector3_object_property(object o, char *property_name)
863
{
864
return(scm2vector3(object_property_value(o,property_name)));
865
}
866
867
matrix3x3 matrix3x3_object_property(object o, char *property_name)
868
{
869
return(scm2matrix3x3(object_property_value(o,property_name)));
870
}
871
872
cvector3 cvector3_object_property(object o, char *property_name)
873
{
874
return(scm2cvector3(object_property_value(o,property_name)));
875
}
876
877
cmatrix3x3 cmatrix3x3_object_property(object o, char *property_name)
878
{
879
return(scm2cmatrix3x3(object_property_value(o,property_name)));
880
}
881
882
list list_object_property(object o, char *property_name)
883
{
884
return(object_property_value(o,property_name));
885
}
886
887
object object_object_property(object o, char *property_name)
888
{
889
return(object_property_value(o,property_name));
890
}
891
892
function function_object_property(object o, char *property_name)
893
{
894
return(object_property_value(o,property_name));
895
}
896
897
SCM SCM_object_property(object o, char *property_name)
898
{
899
return(object_property_value(o,property_name));
900
}
Loggerhead is a web-based interface for Breezy
Version: 2.0.1