1 //
2 // nazghul - an old-school RPG engine
3 // Copyright (C) 2002, 2003 Gordon McNutt
4 //
5 // This program is free software; you can redistribute it and/or modify it
6 // under the terms of the GNU General Public License as published by the Free
7 // Software Foundation; either version 2 of the License, or (at your option)
8 // any later version.
9 //
10 // This program is distributed in the hope that it will be useful, but WITHOUT
11 // ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
12 // FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
13 // more details.
14 //
15 // You should have received a copy of the GNU General Public License along with
16 // this program; if not, write to the Free Foundation, Inc., 59 Temple Place,
17 // Suite 330, Boston, MA 02111-1307 USA
18 //
19 // Gordon McNutt
20 // gmcnutt@users.sourceforge.net
21 //
22
23 #include "session.h"
24
25 #include "applet.h"
26 #include "blender.h"
27 #include "character.h"
28 #include "cmd.h"
29 #include "conv.h"
30 #include "config.h"
31 #include "ctrl.h"
32 #include "dice.h"
33 #include "effect.h"
34 #include "event.h"
35 #include "gob.h"
36 #include "object.h"
37 #include "sched.h"
38 #include "sprite.h"
39 #include "terrain.h"
40 #include "vmask.h"
41 #include "wq.h"
42 #include "place.h"
43 #include "ptable.h"
44 #include "images.h"
45 #include "Party.h"
46 #include "common.h"
47 #include "player.h"
48 #include "sky.h"
49 #include "ascii.h"
50 #include "map.h"
51 #include "cursor.h"
52 #include "Arms.h"
53 #include "Field.h"
54 #include "occ.h"
55 #include "species.h"
56 #include "Reagent.h"
57 #include "screen.h"
58 #include "vehicle.h"
59 #include "formation.h"
60 #include "combat.h"
61 #include "Container.h"
62 #include "clock.h"
63 #include "wind.h"
64 #include "foogod.h"
65 #include "sound.h"
66 #include "Missile.h"
67 #include "conv.h"
68 #include "mmode.h"
69 #include "log.h"
70 #include "dtable.h"
71 #include "factions.h"
72 #include "cmdwin.h"
73 #include "cfg.h"
74 #include "kern_intvar.h" // SAM
75 #include "menus.h"
76 #include "file.h"
77 #include "skill.h"
78 #include "skill_set.h"
79 #include "skill_set_entry.h"
80 #include "templ.h"
81 #include "macros.h"
82 #include "ztats.h"
83 #include "ztats_pane.h"
84 #include "../config.h" /* for USE_QUESTS */
85 // kern.c *doesnt* include kern.h?? wtf??
86
87 #include <assert.h>
88 #include <ctype.h> // isspace()
89 #include <errno.h>
90 #include <stdlib.h>
91 #include <string.h>
92 #include <time.h>
93 #include <SDL_image.h>
94 #include <unistd.h>
95 #include <stdarg.h>
96 #include <SDL.h> // for SDL_GetTicks()
97
98 #include "scheme-private.h"
99
100 #define API_DECL(sc, sym, val) \
101 scm_define(sc, sym, scm_mk_ptr(sc, val))
102
103 #define KERN_API_CALL(name) static pointer name(scheme *sc, pointer args)
104 #define KERN_OBSOLETE_CALL(name) \
105 static pointer name(scheme *sc, pointer args) { \
106 warn("warn: '" #name "' is obsolete\n"); \
107 return sc->NIL; \
108 }
109
110 #define KERN_ALLOC(type) (type *)calloc(1, sizeof(type))
111 #define KERN_FREE(ptr) (free(ptr))
112
113 #define TAG_UNK "<tag?>"
114
115
116 struct kjob {
117 void *data;
118 closure_t *clx;
119 };
120
121 /* Struct used by callbacks which build scheme lists */
122 struct kern_append_info {
123 scheme *sc;
124 pointer head;
125 pointer tail;
126 int (*filter)(Object *, struct kern_append_info *);
127 void *data;
128 };
129
130 struct kern_ui_target_info {
131 struct place *place;
132 int x, y, range;
133 struct list suggest;
134 };
135
136 /* Redefine the session query macro to turn its arg into a string, then #include
137 * the list of querys directly into an array of string pointers. */
138 #undef SESSION_DECL_QUERY
139 #define SESSION_DECL_QUERY(id) #id
140 static const char * query_to_id[] = {
141 # include "session_queries.h"
142 };
143
144 /*****************************************************************************
145 *
146 * kjob - wrapper for work queue jobs
147 *
148 *****************************************************************************/
kjob_new(void * data,closure_t * clx)149 static struct kjob * kjob_new(void *data, closure_t *clx)
150 {
151 struct kjob *kjob;
152 kjob = (struct kjob *)malloc(sizeof(*kjob));
153 assert(kjob);
154 kjob->data = data;
155 kjob->clx = clx;
156 closure_ref(clx);
157 return kjob;
158 }
159
kjob_del(struct kjob * kjob)160 static void kjob_del(struct kjob *kjob)
161 {
162 closure_unref(kjob->clx);
163 free(kjob);
164 }
165
kern_run_wq_job(struct wq_job * job,struct list * wq)166 static void kern_run_wq_job(struct wq_job *job, struct list *wq)
167 {
168 struct kjob *kjob;
169 kjob = (struct kjob*)job->data;
170 //dbg("kjob_run: %08lx\n", kjob);
171 closure_exec(kjob->clx, "p", kjob->data);
172 kjob_del(kjob);
173 wq_job_del(job);
174 }
175 /*****************************************************************************/
176
image_dtor(void * val)177 static void image_dtor(void *val)
178 {
179 images_del((struct images*)val);
180 }
181
sprite_dtor(void * val)182 static void sprite_dtor(void *val)
183 {
184 sprite_del((struct sprite*)val);
185 }
186
sound_dtor(void * val)187 static void sound_dtor(void *val)
188 {
189 sound_del((sound_t*)val);
190 }
191
terrain_palette_dtor(void * val)192 static void terrain_palette_dtor(void *val)
193 {
194 terrain_palette_del((struct terrain_palette*)val);
195 }
196
terrain_map_dtor(void * val)197 static void terrain_map_dtor(void *val)
198 {
199 terrain_map_unref((struct terrain_map*)val);
200 }
201
incfile_dtor(void * val)202 static void incfile_dtor(void *val)
203 {
204 free((char*)val);
205 }
206
incfile_save(save_t * save,void * val)207 static void incfile_save(save_t *save, void *val)
208 {
209 save->write(save, "(kern-load \"%s\")\n\n", (char*)val);
210 }
211
place_dtor(void * val)212 static void place_dtor(void *val)
213 {
214 place_del((struct place*)val);
215 }
216
species_dtor(void * val)217 static void species_dtor(void *val)
218 {
219 species_del((struct species*)val);
220 }
221
occ_dtor(void * val)222 static void occ_dtor(void *val)
223 {
224 occ_unref((struct occ*)val);
225 }
226
arms_type_dtor(void * val)227 static void arms_type_dtor(void *val)
228 {
229 delete (class ArmsType *)val;
230 }
231
missile_type_dtor(void * val)232 static void missile_type_dtor(void *val)
233 {
234 delete (class MissileType *)val;
235 }
236
field_type_dtor(void * val)237 static void field_type_dtor(void *val)
238 {
239 delete (class FieldType *)val;
240 }
241
obj_type_dtor(void * val)242 static void obj_type_dtor(void *val)
243 {
244 delete (class ObjectType *)val;
245 }
246
vehicle_type_dtor(void * val)247 static void vehicle_type_dtor(void *val)
248 {
249 delete (class VehicleType*)val;
250 }
251
blender_dtor(void * val)252 static void blender_dtor(void *val)
253 {
254 blender_t *blender=(blender_t*)val;
255 list_remove(&blender->list);
256 free(blender);
257 }
258
unpack(scheme * sc,pointer * cell,const char * fmt,...)259 static int unpack(scheme *sc, pointer *cell, const char *fmt, ...)
260 {
261 va_list args;
262 int expect, count = 0, errs = 0;
263 pointer car;
264 char **strval;
265 int *ival;
266 float *rval;
267 void **ptrval;
268 pointer *cval;
269
270 expect = strlen(fmt);
271
272 va_start(args, fmt);
273
274 while (*fmt && scm_is_pair(sc, *cell)) {
275
276 count++;
277 car = scm_car(sc, *cell);
278 *cell = scm_cdr(sc, *cell);
279
280 switch(*fmt++) {
281 case 'b': /* bool */
282 ival = va_arg(args, int*);
283 if (car == sc->T) {
284 *ival = 1;
285 } else if (car == sc->F) {
286 *ival = 0;
287 } else {
288 errs++;
289 load_err("arg %d not a bool", count);
290 }
291 break;
292 case 'c': /* closure (actually, a symbol, possibly for a
293 * closure; this is misleading) */
294 cval = va_arg(args, pointer*);
295 if (car == sc->NIL) {
296 *cval = sc->NIL;
297 } else if (! scm_is_sym(sc, car)) {
298 errs++;
299 load_err("arg %d not a symbol", count);
300 } else {
301 *cval = car;
302 }
303 break;
304 case 'd': /* integer */
305 ival = va_arg(args, int*);
306 if (! scm_is_num(sc, car)) {
307 errs++;
308 load_err("arg %d not a number", count);
309 } else if (! scm_is_int(sc, car)) {
310 /*errs++;
311 load_err("arg %d not an int", count);*/
312 /* coerce it */
313 *ival = (int)scm_real_val(sc, car);
314 } else {
315 *ival = scm_int_val(sc, car);
316 }
317 break;
318 case 'f': /* float */
319 rval = va_arg(args, float*);
320 if (! scm_is_num(sc, car)) {
321 errs++;
322 load_err("arg %d not a number", count);
323 } else if (! scm_is_real(sc, car)) {
324 /* coerce it */
325 *rval = scm_int_val(sc, car);
326 } else {
327 *rval = scm_real_val(sc, car);
328 }
329 break;
330 case 'o': /* procedure */
331 cval = va_arg(args, pointer*);
332 if (car == sc->NIL) {
333 *cval = sc->NIL;
334 } else if (! scm_is_closure(sc, car)) {
335 errs++;
336 load_err("arg %d not a closure", count);
337 } else {
338 *cval = car;
339 }
340 break;
341 case 'p': /* C pointer */
342 ptrval = va_arg(args, void**);
343 if (car == sc->NIL) {
344 *ptrval = 0;
345 } else if (scm_is_ptr(sc, car)) {
346 *ptrval = scm_ptr_val(sc, car);
347 } else {
348 errs++;
349 load_err("arg %d not a C ptr", count);
350 }
351 break;
352 case 'r': /* real number */
353 rval = va_arg(args, float*);
354 if (! scm_is_num(sc, car)) {
355 errs++;
356 load_err("arg %d not a number", count);
357 } else if (! scm_is_real(sc, car)) {
358 errs++;
359 load_err("arg %d not an int", count);
360 } else {
361 *rval = scm_real_val(sc, car);
362 }
363 break;
364 case 's': /* string */
365 strval = va_arg(args, char**);
366 if (car == sc->NIL) {
367 *strval = 0;
368 } else if (scm_is_str(sc, car)) {
369 *strval = scm_str_val(sc, car);
370 } else {
371 errs++;
372 load_err("arg %d not a string", count);
373 }
374 break;
375 case 'y': /* symbol */
376 strval = va_arg(args, char**);
377 if (car == sc->NIL) {
378 *strval = 0;
379 } else if (scm_is_sym(sc, car)) {
380 *strval = scm_sym_val(sc, car);
381 } else {
382 errs++;
383 load_err("arg %d not a symbol", count);
384 }
385 break;
386 case 'l': /* plain old cell, (eg a gob) */
387 cval = va_arg(args, pointer*);
388 *cval = car;
389 break;
390 default:
391 dbg("unknown format char: %c\n", *(fmt - 1));
392 assert(0);
393 break;
394 }
395 }
396
397 if (*fmt) {
398 load_err("received only %d of %d arguments",
399 count, count + strlen(fmt));
400 }
401
402 va_end(args);
403
404 return (! *fmt && ! errs) ? 0 : -1;
405 }
406
unpack_obj(scheme * sc,pointer * args,const char * caller)407 static Object *unpack_obj(scheme *sc, pointer *args, const char *caller)
408 {
409 class Object *obj;
410
411 if (unpack(sc, args, "p", &obj)) {
412 rt_err("%s: bad args", caller);
413 return NULL;
414 }
415
416 if (obj == NULL) {
417 rt_err("%s: null kernel object", caller);
418 return NULL;
419 }
420
421 return obj;
422 }
423
unpack_loc(scheme * sc,pointer * args,struct place ** place,int * x,int * y,const char * func)424 static int unpack_loc(scheme *sc, pointer *args, struct place **place, int *x,
425 int *y, const char *func)
426 {
427 pointer loc;
428
429 if (! scm_is_pair(sc, *args)) {
430 rt_err("%s: location not a list", func);
431 return -1;
432 }
433
434 loc = scm_car(sc, *args);
435 *args = scm_cdr(sc, *args);
436
437 if (unpack(sc, &loc, "pdd", place, x, y)) {
438 rt_err("%s: bad location list", func);
439 return -1;
440 }
441
442 if (!place) {
443 rt_err("%s: null place", func);
444 return -1;
445 }
446
447 return 0;
448 }
449
unpack_rect(scheme * sc,pointer * args,SDL_Rect * rect)450 static int unpack_rect(scheme *sc, pointer *args, SDL_Rect *rect)
451 {
452 pointer prect = scm_car(sc, *args);
453 *args = scm_cdr(sc, *args);
454 long x, y, w, h;
455
456 /* Can't use the rect fields directly because they're only Uint16 */
457 if (unpack(sc, &prect, "dddd", &x, &y, &w, &h)) {
458 load_err("%s: error unpacking rect elements", __FUNCTION__);
459 return -1;
460 }
461
462 rect->x = x;
463 rect->y = y;
464 rect->w = w;
465 rect->h = h;
466
467 return 0;
468 }
469
vpack(scheme * sc,const char * fmt,va_list ap)470 pointer vpack(scheme *sc, const char *fmt, va_list ap)
471 {
472 pointer head=sc->NIL;
473 pointer tail=sc->NIL;
474 pointer cell=sc->NIL;
475 pointer arg=sc->NIL;
476 void *ptr;
477 int ival;
478 char *strval;
479
480 while (*fmt) {
481
482 switch(*fmt++) {
483 case 'p':
484 ptr = va_arg(ap, void*);
485 arg = scm_mk_ptr(sc, ptr);
486 break;
487 case 'd':
488 ival = va_arg(ap, int);
489 arg = scm_mk_integer(sc, ival);
490 break;
491 case 'y':
492 strval = va_arg(ap, char*);
493 arg = scm_mk_symbol(sc, strval);
494 break;
495 case 'l':
496 arg = va_arg(ap, pointer);
497 if (!arg) {
498 arg = sc->NIL;
499 }
500 break;
501 default:
502 assert(false);
503 break;
504 }
505
506 /* Note: arg already protected during _cons */
507 cell = _cons(sc, arg, sc->NIL, 0);
508
509 if (head == sc->NIL) {
510 head = cell;
511 tail = cell;
512
513 /* By protecting the head we protect the rest of the
514 * list */
515 scm_protect(sc, head);
516 } else {
517 tail->_object._cons._cdr = cell;
518 tail = cell;
519 }
520 }
521
522 /* Allocations are over so unprotect the list */
523 if (head != sc->NIL)
524 scm_unprotect(sc, head);
525
526 return head;
527 }
528
kern_unpack_mview(scheme * sc,pointer * args,const char * caller)529 struct mview * kern_unpack_mview(scheme *sc, pointer *args, const char *caller)
530 {
531 struct mview *obj;
532
533 if (unpack(sc, args, "p", &obj)) {
534 rt_err("%s: bad args", caller);
535 return NULL;
536 }
537
538 if (obj == NULL) {
539 rt_err("%s: null view object");
540 return NULL;
541 }
542
543 return obj;
544 }
545
kern_unpack_loc(scheme * sc,pointer * args,struct place ** place,int * x,int * y,const char * caller)546 static int kern_unpack_loc(scheme *sc, pointer *args, struct place **place,
547 int *x, int *y, const char *caller)
548 {
549 pointer loc;
550
551 loc = scm_car(sc, *args);
552 if (! scm_is_pair(sc, loc)) {
553 rt_err("%s: location not a list", caller);
554 return 0;
555 }
556
557 *args = scm_cdr(sc, *args);
558
559 if (unpack(sc, &loc, "pdd", place, x, y)) {
560 rt_err("%s: bad location args", caller);
561 return 0;
562 }
563
564 if (!(*place)) {
565 rt_err("%s: null place", caller);
566 return 0;
567 }
568
569 return 1;
570 }
571
pack(scheme * sc,const char * fmt,...)572 static pointer pack(scheme *sc, const char *fmt, ...)
573 {
574 pointer head;
575 va_list ap;
576
577 va_start(ap, fmt);
578 head = vpack(sc, fmt, ap);
579 va_end(ap);
580
581 return head;
582 }
583
kern_mk_sprite_set(scheme * sc,pointer args)584 static pointer kern_mk_sprite_set(scheme *sc, pointer args)
585 {
586 int width, height, rows, cols, offx, offy;
587 char *fname;
588 struct images *image = NULL;
589 const char *tag = TAG_UNK;
590 pointer ret;
591
592 if (unpack(sc, &args, "ydddddds", &tag, &width, &height, &rows, &cols,
593 &offx, &offy, &fname)) {
594 load_err("kern-mk-sprite-set %s: bad args", tag);
595 return sc->NIL;
596 }
597
598 image = images_new(tag, width, height, rows, cols, offx, offy, fname);
599 session_add(Session, image, image_dtor, NULL, NULL);
600 ret = scm_mk_ptr(sc, image);
601 scm_define(sc, tag, ret);
602
603 return ret;
604 }
605
kern_mk_sprite(scheme * sc,pointer args)606 static pointer kern_mk_sprite(scheme *sc, pointer args)
607 {
608 struct images *images;
609 int n_frames, index, facings, wave;
610 struct sprite *sprite;
611 const char *tag = TAG_UNK;
612 pointer ret;
613
614 if (unpack(sc, &args, "ypddbd", &tag, &images, &n_frames, &index,
615 &wave, &facings)) {
616 load_err("kern-mk-sprite %s: bad args", tag);
617 return sc->NIL;
618 }
619
620 sprite = sprite_new(tag, n_frames, index, wave, facings, images);
621 session_add(Session, sprite, sprite_dtor, NULL, NULL);
622 ret = scm_mk_ptr(sc, sprite);
623 scm_define(sc, tag, ret);
624
625 return ret;
626 }
627
628 struct connection {
629 Object *from;
630 char *to;
631 };
632
kern_mk_terrain(scheme * sc,pointer args)633 static pointer kern_mk_terrain(scheme *sc, pointer args)
634 {
635 int alpha, light;
636 void *sprite;
637 struct terrain *terrain;
638 const char *tag = TAG_UNK, *name;
639 pointer ret;
640 int pclass;
641 pointer proc = NULL;
642
643 /* Revisit: ignore effects for now */
644
645 if (unpack(sc, &args, "ysdpddc", &tag, &name, &pclass, &sprite,
646 &alpha, &light, &proc)) {
647 load_err("kern-mk-terrain %s: bad args", tag);
648 return sc->NIL;
649 }
650
651 terrain = terrain_new(tag, name, (struct sprite*)sprite, pclass,
652 alpha, light);
653
654 if (proc != sc->NIL) {
655 terrain->effect = closure_new_ref(sc, proc);
656 }
657 terrain->renderCombat = NULL;
658
659 list_add(&Session->terrains, &terrain->session_list);
660 ret = scm_mk_ptr(sc, terrain);
661 scm_define(sc, tag, ret);
662
663 return ret;
664 }
665
kern_mk_sound(scheme * sc,pointer args)666 static pointer kern_mk_sound(scheme *sc, pointer args)
667 {
668 sound_t *sound;
669 const char *tag = TAG_UNK, *name;
670 pointer ret;
671
672 if (unpack(sc, &args, "ys", &tag, &name)) {
673 load_err("kern-mk-sound %s: bad args", tag);
674 return sc->NIL;
675 }
676
677 sound = sound_new(tag, name);
678
679 /* Add it to the session */
680 session_add(Session, sound, sound_dtor, NULL, NULL);
681 ret = scm_mk_ptr(sc, sound);
682 scm_define(sc, tag, ret);
683
684 return ret;
685 }
686
kern_mk_palette(scheme * sc,pointer args)687 static pointer kern_mk_palette(scheme *sc, pointer args)
688 {
689 int argno = 1;
690 const char *tag = TAG_UNK;
691 pointer ret;
692
693 if (Session->palette) {
694 load_err("kern-mk-palette: %s already set as the session "\
695 "palette",
696 Session->palette->tag);
697 return sc->NIL;
698 }
699
700 if (unpack(sc, &args, "y", &tag)) {
701 load_err("kern-mk-palette %s: bad args", tag);
702 return sc->NIL;
703 }
704
705 Session->palette = terrain_palette_new(tag);
706
707 /* The next argument after the tag shoud be a list of (glyph, terrain)
708 * pairs. Since these are pairs - and not lists - */
709
710 if (! scm_is_pair(sc, args)) {
711 load_err("kern-mk-palette arg %d: arg list too short", argno);
712 terrain_palette_del(Session->palette);
713 return sc->NIL;
714 }
715
716 args = scm_car(sc, args);
717 argno = 1;
718
719 while (scm_is_pair(sc, args)) {
720
721 char *glyph;
722 void *terrain;
723 pointer pair;
724
725 pair = scm_car(sc, args);
726 args = scm_cdr(sc, args);
727 unpack(sc, &pair, "sp", &glyph, &terrain);
728 terrain_palette_add(Session->palette, glyph,
729 (struct terrain*)terrain);
730 }
731
732 session_add(Session, Session->palette, terrain_palette_dtor, NULL, NULL);
733 ret = scm_mk_ptr(sc, Session->palette);
734 scm_define(sc, tag, ret);
735
736 return ret;
737 }
738
kern_mk_map(scheme * sc,pointer args)739 static pointer kern_mk_map(scheme *sc, pointer args)
740 {
741 int width, height, x, y, i;
742 struct terrain_palette *pal;
743 const char *tag = TAG_UNK;
744 struct terrain_map *map;
745 pointer ret;
746 struct list *elem;
747
748 if (unpack(sc, &args, "yddp", &tag, &width, &height, &pal)) {
749 load_err("kern-mk-map %s: bad args", tag);
750 return sc->NIL;
751 }
752
753 /* Final argument should be a list of strings. */
754
755 if (! scm_is_pair(sc, args)) {
756 load_err("kern-mk-map %s: arg list too short", tag);
757 return sc->NIL;
758 }
759
760 args = scm_car(sc, args);
761 map = terrain_map_new(tag, width, height, pal);
762 i = 0;
763
764 for (y = 0; y < height; y++) {
765
766 char *map_line;
767 char *glyph;
768
769 if (unpack(sc, &args, "s", &map_line))
770 goto abort;
771
772 for (x = 0; x < width; x++) {
773
774 struct terrain *tt;
775
776 glyph = strtok(x ? NULL : map_line, " ");
777 if (! glyph) {
778 load_err("kern-mk-map %s: line %d only "\
779 "%d wide, should be %d wide", tag,
780 y, x, width);
781 goto abort;
782 }
783
784 tt = palette_terrain_for_glyph(pal, glyph);
785 if (! tt) {
786 load_err("kern-mk-map %s: line %d "\
787 "column %d: glyph %s "\
788 "has no terrain in palette %s", tag,
789 y, x, glyph, pal->tag);
790 goto abort;
791 }
792
793 map->terrain[i] = tt;
794 i++;
795
796 }
797 }
798
799 /* run all registered terrain blenders on the new map */
800 list_for_each(&Session->blenders, elem) {
801 blender_t *blender=outcast(elem, blender_t, list);
802 terrain_map_blend(map, blender->inf, blender->n_nonsup,
803 blender->nonsup, blender->range);
804 }
805
806
807 map->handle = session_add(Session, map, terrain_map_dtor, NULL, NULL);
808 ret = scm_mk_ptr(sc, map);
809
810 /* Embedded maps (those defined within and used exclusively for) place
811 * constructors may not have and do not need tags. */
812 if (tag)
813 scm_define(sc, tag, ret);
814
815 return ret;
816
817 abort:
818 terrain_map_unref(map);
819 return sc->NIL;
820 }
821
822
823
kern_mk_composite_map(scheme * sc,pointer args)824 static pointer kern_mk_composite_map(scheme *sc, pointer args)
825 {
826 int width, height, x = 0, y = 0, i = 0;
827 const char *tag = TAG_UNK;
828 struct terrain_map *map=NULL, *submap=NULL;
829 pointer ret;
830 struct list *elem;
831
832 /* parse supermap tag and dimensions */
833 if (unpack(sc, &args, "ydd", &tag, &width, &height)) {
834 load_err("kern-mk-composite-map %s: bad args", tag);
835 return sc->NIL;
836 }
837
838 /* unpack the first submap */
839 if (unpack(sc, &args, "p", &submap)) {
840 load_err("kern-mk-composite-map %s: first submap invalid", tag);
841 goto abort;
842 }
843
844 /* create the supermap, inferring the submap dimensions and palette
845 * from the first submap */
846 map = terrain_map_new(tag, width * submap->w, height * submap->h,
847 submap->palette);
848
849 /* set the supermap info */
850 map->submap_w = submap->w;
851 map->submap_h = submap->h;
852 map->composite = 1;
853
854 /* blit the first submap onto the supermap in the upper left-hand
855 * corner */
856 terrain_map_blit(map, 0, 0, submap, 0, 0, submap->w, submap->h);
857
858 /* for each remaining submap in the list... */
859 for (y = 0; y < height; y++) {
860
861 for (x = 0; x < width; x++) {
862
863 /* except the first one... */
864 if (x == 0 && y == 0)
865 continue;
866
867 /* unpack it */
868 if (unpack(sc, &args, "p", &submap)) {
869 load_err("kern-mk-composite-map %s: submap "\
870 "%d invalid", tag, i);
871 goto abort;
872 }
873
874 /* check its palette and dimensions */
875 if (map->palette != submap->palette) {
876 load_err("kern-mk-composite-map %s: submap %d "\
877 "palette doesn't match first submap "\
878 "palette", tag, i);
879 goto abort;
880 }
881 if (map->submap_w != submap->w) {
882 load_err("kern-mk-composite-map %s: submap %d "\
883 "width doesn't match first submap "\
884 "width", tag, i);
885 goto abort;
886 }
887 if (map->submap_h != submap->h) {
888 load_err("kern-mk-composite-map %s: submap %d "\
889 "height doesn't match first submap "\
890 "height", tag, i);
891 goto abort;
892 }
893
894 /* blit the submap onto the supermap */
895 terrain_map_blit(map, x * map->submap_w, y * map->submap_h,
896 submap, 0, 0,
897 map->submap_w, map->submap_h);
898 }
899 }
900
901 /* run all registered terrain blenders on the new map */
902 list_for_each(&Session->blenders, elem) {
903 blender_t *blender=outcast(elem, blender_t, list);
904 terrain_map_blend(map, blender->inf, blender->n_nonsup,
905 blender->nonsup, blender->range);
906 }
907
908 /* add it to the session */
909 map->handle = session_add(Session, map, terrain_map_dtor, NULL, NULL);
910 ret = scm_mk_ptr(sc, map);
911
912 /* define its tag (if specified) */
913 if (tag)
914 scm_define(sc, tag, ret);
915
916 return ret;
917
918 abort:
919 terrain_map_unref(map);
920 return sc->NIL;
921 }
922
kern_place_load_subplaces(scheme * sc,pointer * args,struct place * place)923 static int kern_place_load_subplaces(scheme *sc, pointer *args, struct place *place)
924 {
925 pointer subplaces;
926
927 if (! scm_is_pair(sc, *args)) {
928 load_err("kern-mk-place %s: missing the subplaces list",
929 place->tag);
930 return -1;
931 }
932
933 subplaces = scm_car(sc, *args);
934 *args = scm_cdr(sc, *args);
935
936 while (scm_is_pair(sc, subplaces)) {
937 struct place *subplace = 0;
938 int x, y;
939 pointer cell;
940
941 cell = scm_car(sc, subplaces);
942 subplaces = scm_cdr(sc, subplaces);
943
944 if (unpack(sc, &cell, "pdd", &subplace, &x, &y)) {
945 load_err("kern-mk-place %s: bad arg in subplaces list",
946 place->tag);
947 return -1;
948 }
949
950 if (!subplace) {
951 load_err("kern-mk-place %s: null place in subplaces "\
952 "list", place->tag);
953 return -1;
954 }
955
956 if (subplace->magic != PLACE_MAGIC) {
957 load_err("kern-mk-place %s: subplace is not a place",
958 place->tag);
959 return -1;
960 }
961
962 if (place_add_subplace(place, subplace, x, y)) {
963 load_err("kern-mk-place %s: failed to put %s as a "\
964 "subplace at [%d, %d]; is another subplace "\
965 "already there? Are the coordinates off-map?",
966 place->tag, subplace->tag, x, y);
967 return -1;
968 }
969 }
970
971 return 0;
972 }
973
974
975
kern_place_load_neighbors(scheme * sc,pointer * args,struct place * place)976 static int kern_place_load_neighbors(scheme *sc, pointer *args,
977 struct place *place)
978 {
979 pointer neighbors;
980
981 if (! scm_is_pair(sc, *args)) {
982 load_err("kern-mk-place %s: missing the contents list",
983 place->tag);
984 return -1;
985 }
986
987 neighbors = scm_car(sc, *args);
988 *args = scm_cdr(sc, *args);
989
990 while (scm_is_pair(sc, neighbors)) {
991 int dir, opdir;
992 struct place *neighbor, *tmp;
993 pointer cell;
994
995 cell = scm_car(sc, neighbors);
996 neighbors = scm_cdr(sc, neighbors);
997
998 if (unpack(sc, &cell, "pd", &neighbor, &dir)) {
999 load_err("kern-mk-place %s: error in neighbor list",
1000 place->tag);
1001 return -1;
1002 }
1003
1004 if (! IS_LEGAL_DIRECTION(dir)) {
1005 load_err("kern-mk-place %s: invalid direction for "\
1006 "neighbor: %d\n", place->tag, dir);
1007 return -1;
1008 }
1009
1010 opdir = directionToOpposite(dir);
1011
1012 /* check for existing neighbors */
1013 if ((tmp = place_get_neighbor(place, dir))) {
1014 load_err("kern-mk-place %s: already has %s as a "\
1015 "neighbor in direction %d\n",
1016 place->tag, tmp->tag, dir);
1017 return -1;
1018 }
1019
1020 if ((tmp = place_get_neighbor(neighbor, opdir))) {
1021 load_err("kern-mk-place %s: already has %s as a "\
1022 "neighbor in direction %d\n",
1023 neighbor->tag,
1024 tmp->tag, opdir);
1025 return -1;
1026 }
1027
1028 /* finally, hook them up */
1029 place_set_neighbor(place, dir, neighbor);
1030 }
1031
1032 return 0;
1033 }
1034
KERN_API_CALL(kern_place_set_neighbor)1035 KERN_API_CALL(kern_place_set_neighbor)
1036 {
1037 int dir;
1038 struct place *place, *neighbor;
1039
1040 if (unpack(sc, &args, "dpp", &dir, &place, &neighbor)) {
1041 rt_err("kern-place-set-neighbor: bad args");
1042 return sc->F;
1043 }
1044
1045 // neighbor == null is allowed (it unlinks current neighbor)
1046 if (! place) {
1047 rt_err("kern-place-set-neighbor: null place");
1048 return sc->F;
1049 }
1050
1051 if (! IS_LEGAL_DIRECTION(dir)) {
1052 rt_err("kern-place-set-neighbor: bad direction %d", dir);
1053 return sc->F;
1054 }
1055
1056 /* link (works both ways) */
1057 place_set_neighbor(place, dir, neighbor);
1058
1059 return sc->T;
1060 }
1061
KERN_API_CALL(kern_place_apply_tile_effects)1062 KERN_API_CALL(kern_place_apply_tile_effects)
1063 {
1064 struct place *place;
1065 class Object *obj;
1066
1067 if (unpack(sc, &args, "p", &place)) {
1068 rt_err("kern-place-apply-tile-effects: bad place arg");
1069 return sc->NIL;
1070 }
1071
1072 obj = unpack_obj(sc, &args, "kern-obj-relocate");
1073 if (!obj)
1074 return sc->NIL;
1075
1076 place_apply_tile_effects(place, obj);
1077 return sc->NIL;
1078 }
1079
kern_place_load_contents(scheme * sc,pointer * args,struct place * place)1080 static int kern_place_load_contents(scheme *sc, pointer *args,
1081 struct place *place)
1082 {
1083 pointer contents;
1084
1085 if (! scm_is_pair(sc, *args)) {
1086 load_err("kern-mk-place %s: missing the contents list",
1087 place->tag);
1088 return -1;
1089 }
1090
1091 contents = scm_car(sc, *args);
1092 *args = scm_cdr(sc, *args);
1093
1094 while (scm_is_pair(sc, contents)) {
1095
1096 class Object *obj = 0;
1097 int x, y;
1098 pointer cell;
1099
1100 cell = scm_car(sc, contents);
1101 contents = scm_cdr(sc, contents);
1102
1103 if (unpack(sc, &cell, "pdd", &obj, &x, &y)) {
1104 load_err("kern-mk-place %s: bad arg in content list",
1105 place->tag);
1106 return -1;
1107 }
1108
1109 if (!obj) {
1110 load_err("kern-mk-place %s: null obj in content list",
1111 place->tag);
1112 return -1;
1113 }
1114
1115 obj->relocate(place, x, y, REL_NOTRIG);
1116 }
1117
1118 return 0;
1119 }
1120
kern_place_load_entrances(scheme * sc,pointer * args,struct place * place)1121 static int kern_place_load_entrances(scheme *sc, pointer *args,
1122 struct place *place)
1123 {
1124 pointer entrances;
1125
1126 if (! scm_is_pair(sc, *args)) {
1127 load_err("kern-mk-place %s: missing the entrances list",
1128 place->tag);
1129 return -1;
1130 }
1131
1132 entrances = scm_car(sc, *args);
1133 *args = scm_cdr(sc, *args);
1134
1135 while (scm_is_pair(sc, entrances)) {
1136
1137 int dir, x, y;
1138 pointer cell;
1139
1140 cell = scm_car(sc, entrances);
1141 entrances = scm_cdr(sc, entrances);
1142
1143 if (unpack(sc, &cell, "ddd", &dir, &x, &y)) {
1144 load_err("kern-mk-place %s: bad arg in entrances list",
1145 place->tag);
1146 return -1;
1147 }
1148
1149 if (place_set_edge_entrance(place, dir, x, y)) {
1150 load_err("kern-mk-place %s: failed to set entrance for "\
1151 "direction %d to [%d %d]", place->tag, dir, x, y);
1152 return -1;
1153 }
1154 }
1155
1156 return 0;
1157 }
1158
kern_place_load_hooks(scheme * sc,pointer * args,struct place * place)1159 static int kern_place_load_hooks(scheme *sc, pointer *args,
1160 struct place *place)
1161 {
1162 pointer contents;
1163 pointer pre_entry_proc;
1164
1165 if (! scm_is_pair(sc, *args)) {
1166 load_err("kern-mk-place %s: missing the hooks list",
1167 place->tag);
1168 return -1;
1169 }
1170
1171 contents = scm_car(sc, *args);
1172 *args = scm_cdr(sc, *args);
1173
1174 while (scm_is_pair(sc, contents)) {
1175
1176 if (unpack(sc, &contents, "c", &pre_entry_proc)) {
1177 load_err("kern-mk-place %s: bad arg in hook list",
1178 place->tag);
1179 return -1;
1180 }
1181
1182 place_add_on_entry_hook(place,
1183 closure_new_ref(sc, pre_entry_proc));
1184 }
1185
1186 return 0;
1187 }
1188
KERN_API_CALL(kern_place_add_on_entry_hook)1189 KERN_API_CALL(kern_place_add_on_entry_hook)
1190 {
1191 struct place *place;
1192 pointer proc;
1193
1194 if (unpack(sc, &args, "pc", &place, &proc)) {
1195 rt_err("kern-place-add-on-entry-hook: bad args");
1196 return sc->NIL;
1197 }
1198
1199 if (! place) {
1200 rt_err("kern-place-add-on-entry-hook: null place");
1201 return sc->NIL;
1202 }
1203
1204 place_add_on_entry_hook(place,
1205 closure_new_ref(sc, proc));
1206 return sc->NIL;
1207 }
1208
KERN_API_CALL(kern_mk_place)1209 KERN_API_CALL(kern_mk_place)
1210 {
1211 int wild, wraps, underground, combat;
1212 struct terrain_map *map;
1213 struct place *place;
1214 struct sprite *sprite;
1215 const char *tag = TAG_UNK, *name;
1216 pointer ret;
1217
1218 if (unpack(sc, &args, "ysppbbbb", &tag, &name, &sprite, &map,
1219 &wraps, &underground, &wild, &combat)) {
1220 load_err("kern-mk-place %s: bad args", tag);
1221 return sc->NIL;
1222 }
1223
1224 if ( ! map->handle) {
1225 load_err("kern-mk-place %s: map %s has no session handle; "\
1226 "is it already being used in another place?", tag,
1227 map->tag);
1228 return sc->NIL;
1229 }
1230
1231 session_rm(Session, map->handle);
1232 map->handle = 0;
1233 place = place_new(tag, name, sprite, map, wraps, underground, wild,
1234 combat);
1235
1236
1237 if (kern_place_load_subplaces(sc, &args, place) ||
1238 kern_place_load_neighbors(sc, &args, place) ||
1239 kern_place_load_contents(sc, &args, place) ||
1240 kern_place_load_hooks(sc, &args, place) ||
1241 kern_place_load_entrances(sc, &args, place))
1242 goto abort;
1243
1244 place->handle = session_add(Session, place, place_dtor, place_save, place_start);
1245 ret = scm_mk_ptr(sc, place);
1246 scm_define(sc, tag, ret);
1247 return ret;
1248
1249 abort:
1250 place_del(place);
1251 return sc->NIL;
1252 }
1253
kern_mk_species(scheme * sc,pointer args)1254 static pointer kern_mk_species(scheme *sc, pointer args)
1255 {
1256 struct species *species;
1257 int str, intl, dex, spd, vr, hpmod, hpmult, argno = 1;
1258 int mpmod, mpmult, visible, n_slots, n_spells, i, xpval;
1259 int stationary=0;
1260 struct sprite *sleep_sprite;
1261 class ArmsType *weapon;
1262 const char *tag = TAG_UNK, *name, *armor_dice;
1263 sound_t *damage_sound, *walking_sound;
1264 pointer slots;
1265 pointer spells;
1266 pointer ret;
1267 struct mmode *mmode;
1268
1269
1270 if (unpack(sc, &args, "ysdddddpddddppbppdbs", &tag, &name, &str,
1271 &intl, &dex, &spd, &vr, &mmode, &hpmod, &hpmult, &mpmod,
1272 &mpmult, &sleep_sprite, &weapon,
1273 &visible, &damage_sound, &walking_sound,
1274 &xpval, &stationary, &armor_dice)) {
1275 load_err("kern-mk-species %s: bad args", tag);
1276 return sc->NIL;
1277 }
1278
1279 if (scm_len(sc, args) < 2) {
1280 load_err("kern-mk-species %s: arg list too short", tag,
1281 argno++);
1282 return sc->NIL;
1283 }
1284
1285 if (! mmode) {
1286 load_err("kern-mk-species %s: null mmode", tag);
1287 return sc->NIL;
1288 }
1289
1290
1291 /* get the list of slots */
1292 slots = scm_car(sc, args);
1293 args = scm_cdr(sc, args);
1294
1295 /* get the list of spells */
1296 spells = scm_car(sc, args);
1297 args = scm_cdr(sc, args);
1298
1299 /* get the sizes of the various lists */
1300 n_slots = scm_len(sc, slots);
1301 n_spells = scm_len(sc, spells);
1302
1303 species = species_new(tag, name, damage_sound, walking_sound, str,
1304 intl, dex, spd, vr, hpmod, hpmult,
1305 mpmod, mpmult, visible,
1306 n_slots, n_spells);
1307 species->weapon = weapon;
1308 species->sleep_sprite = sleep_sprite;
1309 species->mmode = mmode;
1310 species->xpval = xpval;
1311 species->stationary = stationary;
1312
1313 /* Optional armor dice */
1314 if (armor_dice) {
1315 species->armor_dice = strdup(armor_dice);
1316 }
1317
1318 /* Load the list of slots. */
1319 i = 0;
1320 while (scm_is_pair(sc, slots)) {
1321 if (unpack(sc, &slots, "d", &species->slots[i++]))
1322 goto abort;
1323 }
1324
1325 /* Load the list of spells */
1326 i = 0;
1327 while (scm_is_pair(sc, spells)) {
1328 char *code;
1329 if (unpack(sc, &spells, "s", &code))
1330 goto abort;
1331 species->spells[i] = strdup(code);
1332 assert(species->spells[i]);
1333 i++;
1334 }
1335
1336 session_add(Session, species, species_dtor, NULL, NULL);
1337 ret = scm_mk_ptr(sc, species);
1338 scm_define(sc, tag, ret);
1339 return ret;
1340
1341 abort:
1342 species_del(species);
1343 return sc->NIL;
1344 }
1345
kern_mk_arms_type(scheme * sc,pointer args)1346 static pointer kern_mk_arms_type(scheme *sc, pointer args)
1347 {
1348 class ArmsType *arms;
1349 const char *tag = TAG_UNK, *name;
1350 sound_t *fire_sound;
1351 int slots, hands, range, weight;
1352 char *hit, *defend, *damage, *armor;
1353 int rap, AP_mod, thrown, ubiq;
1354 struct sprite *sprite;
1355 class MissileType *missile;
1356 class ObjectType *ammo;
1357 pointer gifc;
1358 pointer ret;
1359 int gifc_cap;
1360 int str_attack_mod;
1361 int dex_attack_mod;
1362 int char_damage_mod;
1363 float char_avoid_mod;
1364 struct mmode *mmode;
1365
1366
1367 if (unpack(sc, &args, "yspssssdddddppbbdpdodddrp",
1368 &tag,
1369 &name,
1370 &sprite,
1371 &hit, &damage, &armor, &defend,
1372 &slots, &hands, &range, &rap, &AP_mod,
1373 &missile, &ammo,
1374 &thrown, &ubiq,
1375 &weight,
1376 &fire_sound,
1377 &gifc_cap,
1378 &gifc,
1379 &str_attack_mod, &dex_attack_mod, &char_damage_mod,
1380 &char_avoid_mod,
1381 &mmode)) {
1382 load_err("kern-mk-arms-type %s: bad args", tag);
1383 return sc->NIL;
1384 }
1385
1386 if (! dice_valid(hit)) {
1387 load_err("kern-mk-arms-type %s: bad dice format '%s'",
1388 tag, hit);
1389 return sc->NIL;
1390 }
1391
1392 if (! dice_valid(defend)) {
1393 load_err("kern-mk-arms-type %s: bad dice format '%s'",
1394 tag, defend);
1395 return sc->NIL;
1396 }
1397
1398 if (! dice_valid(damage)) {
1399 load_err("kern-mk-arms-type %s: bad dice format '%s'",
1400 tag, damage);
1401 return sc->NIL;
1402 }
1403
1404 if (! dice_valid(armor)) {
1405 load_err("kern-mk-arms-type %s: bad dice format '%s'",
1406 tag, armor);
1407 return sc->NIL;
1408 }
1409
1410 arms = new ArmsType(tag, name, sprite, slots, hit, defend, hands,
1411 range,
1412 weight, damage, armor, rap, AP_mod, thrown, ubiq,
1413 fire_sound, missile, ammo, str_attack_mod, dex_attack_mod,
1414 char_damage_mod, char_avoid_mod, false);
1415
1416 arms->setMovementMode(mmode);
1417
1418 if (gifc != sc->NIL) {
1419 /* arms->get_handler = closure_new(sc, get_handler); */
1420 arms->setGifc(closure_new(sc, gifc), gifc_cap);
1421 }
1422
1423 session_add(Session, arms, arms_type_dtor, NULL, NULL);
1424 ret = scm_mk_ptr(sc, arms);
1425 scm_define(sc, tag, ret);
1426 return ret;
1427 }
1428
kern_mk_missile_type(scheme * sc,pointer args)1429 static pointer kern_mk_missile_type(scheme *sc, pointer args)
1430 {
1431 class MissileType *arms;
1432 const char *tag = TAG_UNK, *name;
1433 struct sprite *sprite;
1434 pointer gifc;
1435 pointer ret;
1436 int gifc_cap;
1437 struct mmode *mmode;
1438 int beam;
1439 int fixedrange;
1440
1441
1442 if (unpack(sc, &args, "yspdopbb",
1443 &tag,
1444 &name,
1445 &sprite,
1446 &gifc_cap,
1447 &gifc,
1448 &mmode,
1449 &beam,
1450 &fixedrange))
1451 {
1452 load_err("kern-mk-projectile-type %s: bad args", tag);
1453 return sc->NIL;
1454 }
1455
1456 arms = new MissileType(tag, name, sprite, beam, fixedrange, mmode);
1457
1458 if (gifc != sc->NIL)
1459 {
1460 /* arms->get_handler = closure_new(sc, get_handler); */
1461 arms->setGifc(closure_new(sc, gifc), gifc_cap);
1462 }
1463
1464 session_add(Session, arms, missile_type_dtor, NULL, NULL);
1465 ret = scm_mk_ptr(sc, arms);
1466 scm_define(sc, tag, ret);
1467
1468 return ret;
1469 }
1470
kern_mk_field_type(scheme * sc,pointer args)1471 static pointer kern_mk_field_type(scheme *sc, pointer args)
1472 {
1473 class FieldType *field;
1474 const char *tag = TAG_UNK, *name;
1475 struct sprite *sprite;
1476 int light, duration, pclass;
1477 closure_t *clx = NULL;
1478 pointer func = sc->NIL;
1479 pointer ret;
1480 struct mmode *mmode = NULL;
1481
1482 if (unpack(sc, &args, "yspdddcp", &tag, &name, &sprite, &light,
1483 &duration, &pclass, &func, &mmode)) {
1484 load_err("kern-mk-field-type %s: bad args", tag);
1485 return sc->NIL;
1486 }
1487
1488 if (func != sc->NIL) {
1489 clx = closure_new(sc, func);
1490 }
1491
1492 field = new FieldType(tag, name, sprite, light, duration, pclass, clx);
1493 field->setMovementMode(mmode);
1494 session_add(Session, field, field_type_dtor, NULL, NULL);
1495 ret = scm_mk_ptr(sc, field);
1496 scm_define(sc, tag, ret);
1497 return ret;
1498 }
1499
mmode_dtor(void * ptr)1500 static void mmode_dtor(void *ptr)
1501 {
1502 mmode_del((struct mmode*)ptr);
1503 }
1504
KERN_API_CALL(kern_mk_mmode)1505 KERN_API_CALL(kern_mk_mmode)
1506 {
1507 char *tag, *name;
1508 int index;
1509 struct mmode *mmode;
1510 pointer ret;
1511
1512 if (unpack(sc, &args, "ysd", &tag, &name, &index)) {
1513 load_err("kern-mk-mmode: bad args");
1514 return sc->NIL;
1515 }
1516
1517 mmode = mmode_new(tag, name, index);
1518 session_add(Session, mmode, mmode_dtor, NULL, NULL);
1519 ret = scm_mk_ptr(sc, mmode);
1520 scm_define(sc, tag, ret);
1521 return ret;
1522 }
1523
kern_mk_obj_type(scheme * sc,pointer args)1524 static pointer kern_mk_obj_type(scheme *sc, pointer args)
1525 {
1526 class ObjectType *type;
1527 const char *tag = TAG_UNK, *name;
1528 char *pluralName=NULL;
1529 enum layer layer;
1530 struct sprite *sprite;
1531 pointer ret;
1532 pointer gifc;
1533 int gifc_cap;
1534 struct mmode *mmode;
1535
1536 /* unpack the tag */
1537 if (unpack(sc, &args, "y", &tag)) {
1538 load_err("kern-mk-obj-type %s: bad args (did you mean to use "\
1539 "kern-mk-obj instead?)", tag);
1540 return sc->NIL;
1541 }
1542
1543 /* probe the name to see if it is a list, if so then use the car as the
1544 * name and the cadr as the pluralName */
1545 if (scm_is_pair(sc, scm_car(sc, args))) {
1546 pointer list = scm_car(sc, args);
1547 args=scm_cdr(sc, args);
1548 if (unpack(sc, &list, "ss", &name, &pluralName)) {
1549 load_err("kern-mk-obj-type %s: bad name arg", tag);
1550 return sc->NIL;
1551 }
1552 } else if (unpack(sc, &args, "s", &name)) {
1553 load_err("kern-mk-obj-type %s: bad name arg", tag);
1554 return sc->NIL;
1555 }
1556
1557 /* continue unpacking the rest of the args */
1558 if (unpack(sc, &args, "pddop", &sprite, &layer, &gifc_cap, &gifc, &mmode)) {
1559 load_err("kern-mk-obj-type %s: bad args (did you mean to use "\
1560 "kern-mk-obj instead?)", tag);
1561 return sc->NIL;
1562 }
1563
1564 type = new ObjectType(tag, name, sprite, layer);
1565 assert(type);
1566
1567 if (gifc != sc->NIL) {
1568 type->setGifc(closure_new(sc, gifc), gifc_cap);
1569 }
1570
1571 if (pluralName) {
1572 type->setPluralName(pluralName);
1573 }
1574
1575 type->setMovementMode(mmode);
1576 session_add(Session, type, obj_type_dtor, NULL, NULL);
1577 ret = scm_mk_ptr(sc, type);
1578 scm_define(sc, tag, ret);
1579 return ret;
1580 }
1581
kern_mk_occ(scheme * sc,pointer args)1582 static pointer kern_mk_occ(scheme *sc, pointer args)
1583 {
1584 struct occ *occ;
1585 int hpmod, hpmult;
1586 int mpmod, mpmult, hit, def, dam, arm, xpval;
1587 const char *tag = TAG_UNK, *name;
1588 struct skill_set *skset;
1589 float magic;
1590 pointer ret;
1591
1592 /* Basic args */
1593 if (unpack(sc, &args, "ysrdddddddddp",
1594 &tag, &name, &magic, &hpmod, &hpmult, &mpmod, &mpmult, &hit,
1595 &def, &dam, &arm, &xpval, &skset)) {
1596 load_err("kern-mk-occ %s: bad args", tag);
1597 return sc->NIL;
1598 }
1599
1600 occ = occ_new(tag, name, magic, hpmod, hpmult, mpmod, mpmult, hit, def,
1601 dam, arm);
1602 occ_ref(occ);
1603 occ->xpval = xpval;
1604 occ_set_skills(occ, skset);
1605
1606 session_add(Session, occ, occ_dtor, NULL, NULL);
1607 ret = scm_mk_ptr(sc, occ);
1608 scm_define(sc, tag, ret);
1609 return ret;
1610 }
1611
kern_load_hooks(scheme * sc,pointer hook_tbl,Object * obj)1612 static int kern_load_hooks(scheme *sc, pointer hook_tbl, Object *obj)
1613 {
1614 while (scm_is_pair(sc, hook_tbl)) {
1615
1616 struct effect *effect;
1617 int flags;
1618 pointer gobcell;
1619 pointer hook_entry;
1620 struct gob *gob = NULL;
1621 clock_alarm_t clk;
1622
1623 hook_entry = scm_car(sc, hook_tbl);
1624 hook_tbl = scm_cdr(sc, hook_tbl);
1625
1626 if (unpack(sc, &hook_entry, "pldd", &effect, &gobcell, &flags,
1627 &clk)) {
1628 return -1;
1629 }
1630
1631 /* Note: even if gobcell is sc->NIL we want to wrap it. I once
1632 * tried to use a NULL gob instead but if we pass that back
1633 * into scheme as an arg and the gc tries to mark it we'll
1634 * crash. */
1635 gob = gob_new(sc, gobcell);
1636 gob->flags |= GOB_SAVECAR;
1637
1638 obj->restoreEffect(effect, gob, flags, clk);
1639 }
1640
1641 return 0;
1642 }
1643
kern_load_conv(scheme * sc,pointer sym,Object * obj)1644 static void kern_load_conv(scheme *sc, pointer sym, Object *obj)
1645 {
1646 struct conv *conv;
1647 struct closure *proc;
1648
1649 if (sym == sc->NIL) {
1650 return;
1651 }
1652
1653 if (! (proc = closure_new_ref(sc, sym))) {
1654 load_err("%s: closure_new failed", __FUNCTION__);
1655 return;
1656 }
1657
1658 if (!(conv = conv_new(proc))) {
1659 load_err("%s: conv_new failed", __FUNCTION__);
1660 goto done2;
1661 }
1662
1663 obj->setConversation(conv);
1664 conv_unref(conv);
1665 done2:
1666 closure_unref(proc);
1667 }
1668
kern_mk_char(scheme * sc,pointer args)1669 static pointer kern_mk_char(scheme *sc, pointer args)
1670 {
1671 class Character *character;
1672 int str, intl, dex, hpmod, hpmult;
1673 int mpmod, mpmult, hp, xp, mp, AP_per_round, lvl, dead;
1674 const char *tag = TAG_UNK, *name;
1675 struct species *species;
1676 struct occ *occ;
1677 struct sprite *sprite;
1678 pointer conv;
1679 pointer readied;
1680 pointer ret;
1681 pointer ai;
1682 pointer hook_tbl;
1683 int base_faction;
1684 struct sched *sched;
1685 class Container *inventory;
1686
1687 if (unpack(sc, &args, "yspppdddddddddddddbcpcp",
1688 &tag, &name, &species, &occ,
1689 &sprite, &base_faction, &str,
1690 &intl, &dex, &hpmod, &hpmult, &mpmod, &mpmult,
1691 &hp, &xp, &mp, &AP_per_round, &lvl, &dead,
1692 &conv, &sched, &ai, &inventory)) {
1693 load_err("kern-mk-char %s: bad args", tag);
1694 return sc->NIL;
1695 }
1696
1697 if (! scm_is_pair(sc, args)) {
1698 load_err("kern-mk-char %s: no readied arms list", tag);
1699 return sc->NIL;
1700 }
1701
1702 readied = scm_car(sc, args);
1703 args = scm_cdr(sc, args);
1704
1705 character = new class Character(tag, name, sprite,species, occ,
1706 str, intl, dex, hpmod, hpmult, mpmod,
1707 mpmult,
1708 hp, xp, mp, AP_per_round, lvl);
1709 assert(character);
1710 character->setBaseFaction(base_faction);
1711 character->setSchedule(sched);
1712 character->setInventoryContainer(inventory);
1713 character->setDead(dead);
1714
1715 kern_load_conv(sc, conv, character);
1716
1717 if (ai != sc->NIL) {
1718 character->setAI(closure_new(sc, ai));
1719 }
1720
1721 /* Load the list of arms. */
1722 while (scm_is_pair(sc, readied)) {
1723 class ArmsType *arms;
1724 if (unpack(sc, &readied, "p", &arms)) {
1725 load_err("kern-mk-char %s: error in arms list", tag);
1726 goto abort;
1727 }
1728 /*character->add(arms, 1);*/
1729 character->ready(arms);
1730 }
1731
1732 /* Load the hooks. */
1733 hook_tbl = scm_car(sc, args);
1734 args = scm_cdr(sc, args);
1735 if (kern_load_hooks(sc, hook_tbl, character)) {
1736 load_err("kern-mk-char %s: bad hook entry", tag);
1737 goto abort;
1738 }
1739
1740
1741 ret = scm_mk_ptr(sc, character);
1742
1743 /* If the character is tagged then it's not "anonymous", and we'll
1744 * assign it to a scheme variable named after the tag. */
1745 if (tag) {
1746 scm_define(sc, tag, ret);
1747
1748 /* Tagged objects may be referred to in the script by their
1749 * tag. If the object is destroyed, the scheme variable that
1750 * refers to the object is still valid (in Scheme, it isn't
1751 * really possible to undefine variables). To prevent crashes
1752 * on dereferencing this variable we'll bump the refcount. To
1753 * ensure the object is destroyed on session teardown, we'll
1754 * mark it for custom finalization, which will decrement the
1755 * extra refcount. */
1756 obj_inc_ref(character);
1757 scm_set_cust_fin(sc, ret);
1758 }
1759
1760 return ret;
1761
1762 abort:
1763 delete character;
1764 return sc->NIL;
1765 }
1766
kern_mk_obj(scheme * sc,pointer args)1767 static pointer kern_mk_obj(scheme *sc, pointer args)
1768 {
1769 class Object *obj;
1770 class ObjectType *type = 0;
1771 int count;
1772
1773 if (unpack(sc, &args, "pd", &type, &count)) {
1774 load_err("kern-mk-obj: bad args");
1775 return sc->NIL;
1776 }
1777
1778 if (!type) {
1779 load_err("kern-mk-obj: null type");
1780 return sc->NIL;
1781 }
1782
1783 // Fixme: we need a MAGIC number field, but it won't work because
1784 // 'type' is a c++ object. If the script hands us something that is not
1785 // really an ObjectType we'll crash sooner or later.
1786
1787 obj = type->createInstance();
1788 assert(obj);
1789 obj->setCount(count);
1790
1791 if (kern_load_hooks(sc, scm_car(sc, args), obj)) {
1792 load_err("kern-mk-obj: error in hook list");
1793 goto abort;
1794 }
1795 args = scm_cdr(sc, args);
1796
1797 // Objects aren't added to the session the way types are. Every object
1798 // will end up in some type of container; objects should always be
1799 // loaded as part of a container's contents; and the container should
1800 // always save the objects it contains.
1801 //
1802 // There's nothing to prevent a script from creating a "dangling"
1803 // object which is never put anywhere. Although weird (and probably a
1804 // bug in the script), it should be benign. Memory leaks are prevented
1805 // by deinitializing the interpreter every time we load a new session.
1806 // Furthermore, such orphan objects will never be saved, so they won't
1807 // propogate.
1808
1809 return scm_mk_ptr(sc, obj);
1810
1811 abort:
1812 delete obj;
1813 return sc->NIL;
1814 }
1815
kern_mk_field(scheme * sc,pointer args)1816 static pointer kern_mk_field(scheme *sc, pointer args)
1817 {
1818 class Field *obj;
1819 class FieldType *type = 0;
1820 int duration;
1821
1822 if (unpack(sc, &args, "pd", &type, &duration)) {
1823 load_err("kern-mk-obj: bad args");
1824 return sc->NIL;
1825 }
1826
1827 if (!type) {
1828 load_err("kern-mk-obj: null type");
1829 return sc->NIL;
1830 }
1831
1832 obj = new Field(type, duration);
1833 assert(obj);
1834
1835 // Objects aren't added to the session the way types are. Every object
1836 // will end up in some type of container; objects should always be
1837 // loaded as part of a container's contents; and the container should
1838 // always save the objects it contains.
1839
1840 return scm_mk_ptr(sc, obj);
1841 }
1842
kern_mk_party(scheme * sc,pointer args)1843 static pointer kern_mk_party(scheme *sc, pointer args)
1844 {
1845 class Party *obj;
1846
1847 obj = new Party();
1848 assert(obj);
1849
1850 return scm_mk_ptr(sc, obj);
1851 }
1852
kern_obj_put_at(scheme * sc,pointer args)1853 static pointer kern_obj_put_at(scheme *sc, pointer args)
1854 {
1855 class Object *obj;
1856 struct place *place;
1857 pointer loc;
1858 int x, y;
1859
1860 if (unpack(sc, &args, "p", &obj)) {
1861 rt_err("kern-obj-put-at: bad args");
1862 return sc->NIL;
1863 }
1864
1865 if (!obj) {
1866 rt_err("kern-obj-put-at: null obj");
1867 return sc->NIL;
1868 }
1869
1870 loc = scm_car(sc, args);
1871 if (! scm_is_pair(sc, loc)) {
1872 rt_err("kern-obj-put-at: invalid location");
1873 return sc->NIL;
1874 }
1875
1876 if (unpack(sc, &loc, "pdd", &place, &x, &y)) {
1877 rt_err("kern-obj-put-at: bad location args");
1878 return sc->NIL;
1879 }
1880
1881 if (!place) {
1882 rt_err("kern-obj-put-at: null place");
1883 return sc->NIL;
1884 }
1885
1886 obj->relocate(place, x, y, REL_NOSTEP);
1887 return sc->NIL;
1888 }
1889
kern_obj_relocate(scheme * sc,pointer args)1890 static pointer kern_obj_relocate(scheme *sc, pointer args)
1891 {
1892 class Object *obj;
1893 struct place *place;
1894 pointer cutscene;
1895 int x, y;
1896 struct closure *clx = NULL;
1897
1898 obj = unpack_obj(sc, &args, "kern-obj-relocate");
1899 if (!obj)
1900 return sc->NIL;
1901
1902 if (unpack_loc(sc, &args, &place, &x, &y, "kern-obj-relocate"))
1903 return sc->NIL;
1904
1905 if (unpack(sc, &args, "o", &cutscene)) {
1906 rt_err("kern-obj-relocate: bad args");
1907 return sc->NIL;
1908 }
1909
1910 if (cutscene != sc->NIL) {
1911 clx = closure_new_ref(sc, cutscene);
1912 }
1913
1914 obj->relocate(place, x, y, REL_NOSTEP, clx);
1915
1916 closure_unref_safe(clx);
1917
1918 return sc->NIL;
1919 }
1920
kern_obj_get_location(scheme * sc,pointer args)1921 static pointer kern_obj_get_location(scheme *sc, pointer args)
1922 {
1923 class Object *obj;
1924 struct place *place;
1925 int x, y;
1926
1927 if (!(obj = unpack_obj(sc, &args, "kern-obj-get-location"))) {
1928 assert(false);
1929 return sc->NIL;
1930 }
1931
1932 if ((place = obj->getPlace())) {
1933 x = obj->getX();
1934 y = obj->getY();
1935 return pack(sc, "pdd", place, x, y);
1936 }
1937
1938 return sc->NIL;
1939 }
1940
kern_obj_get_dir(scheme * sc,pointer args)1941 static pointer kern_obj_get_dir(scheme *sc, pointer args)
1942 {
1943 class Object *obj;
1944 int dx, dy;
1945
1946 if (!(obj = unpack_obj(sc, &args, "kern-obj-get-dir"))) {
1947 assert(false);
1948 return sc->NIL;
1949 }
1950
1951 dx = obj->getDx();
1952 dy = obj->getDy();
1953
1954 return pack(sc, "dd", dx, dy);
1955 }
1956
kern_place_get_location(scheme * sc,pointer args)1957 static pointer kern_place_get_location(scheme *sc, pointer args)
1958 {
1959 struct place *place;
1960
1961 if (unpack(sc, &args, "p", &place)) {
1962 rt_err("kern-place-get-location: bad args");
1963 return sc->NIL;
1964 }
1965
1966 if (! place) {
1967 rt_err("kern-place-get-location: null place");
1968 return sc->NIL;
1969 }
1970
1971 if (! place->location.place)
1972 return sc->NIL;
1973
1974 return pack(sc, "pdd",
1975 place->location.place,
1976 place->location.x,
1977 place->location.y);
1978 }
1979
kern_append_effect(struct hook_entry * entry,void * data)1980 static int kern_append_effect(struct hook_entry *entry, void *data)
1981 {
1982 pointer cell;
1983 struct kern_append_info *info;
1984
1985 info = (struct kern_append_info *)data;
1986
1987 cell = scm_mk_ptr(info->sc, entry->effect);
1988 cell = _cons(info->sc, cell, info->sc->NIL, 0);
1989
1990 if (info->head == info->sc->NIL) {
1991 info->head = cell;
1992 info->tail = cell;
1993 } else {
1994 info->tail->_object._cons._cdr = cell;
1995 info->tail = cell;
1996 }
1997
1998 return 0;
1999 }
2000
KERN_API_CALL(kern_obj_get_effects)2001 KERN_API_CALL(kern_obj_get_effects)
2002 {
2003 class Object *obj;
2004 int i;
2005 struct kern_append_info info;
2006
2007 if (!(obj = unpack_obj(sc, &args, "kern-obj-get-effects"))) {
2008 return sc->NIL;
2009 }
2010
2011 /* initialize the context used by the callback to append objects */
2012 info.sc = sc;
2013 info.head = sc->NIL;
2014 info.tail = sc->NIL;
2015 info.filter = NULL;
2016
2017 /* for each effect hook on the object */
2018 for (i = 0; i < OBJ_NUM_HOOKS; i++) {
2019
2020 /* build a scheme list of the attached effects */
2021 obj->hookForEach(i, kern_append_effect, &info);
2022 }
2023
2024 return info.head;
2025 }
2026
kern_obj_get_vision_radius(scheme * sc,pointer args)2027 static pointer kern_obj_get_vision_radius(scheme *sc, pointer args)
2028 {
2029 class Object *obj;
2030
2031 if (!(obj = unpack_obj(sc, &args, "kern-obj-get-location"))) {
2032 return sc->NIL;
2033 }
2034
2035 return scm_mk_integer(sc, obj->getVisionRadius());
2036 }
2037
kern_obj_put_into(scheme * sc,pointer args)2038 static pointer kern_obj_put_into(scheme *sc, pointer args)
2039 {
2040 class Object *obj;
2041 class Object *container;
2042
2043 if (unpack(sc, &args, "pp", &obj, &container)) {
2044 load_err("kern-obj-put: bad args");
2045 return sc->F;
2046 }
2047
2048 if (!obj) {
2049 rt_err("kern-obj-put: null obj");
2050 return sc->F;
2051 }
2052
2053 if (!container) {
2054 rt_err("kern-obj-put: null container");
2055 return sc->F;
2056 }
2057
2058 return container->add(obj->getObjectType(),
2059 obj->getCount()) ? sc->T : sc->F;
2060
2061 }
2062
2063 /*
2064 * kern_obj_remove - remove an object from the map. Note that this implicitly
2065 * destroys most objects automatically, unless the object has another reference
2066 * count. Use kern_obj_inc_ref to prevent destruction during this call.
2067 */
kern_obj_remove(scheme * sc,pointer args)2068 static pointer kern_obj_remove(scheme *sc, pointer args)
2069 {
2070 class Object *obj;
2071
2072 if (!(obj=unpack_obj(sc, &args, "kern-obj-remove"))) {
2073 return sc->NIL;
2074 }
2075
2076 /* Bugfix: don't use place_remove_object() because it doesn't call
2077 setOnMap(false). */
2078 //place_remove_object(obj->getPlace(), obj);
2079 obj->remove();
2080
2081 return sc->NIL;
2082 }
2083
2084 #if 0
2085 /*
2086 * kern_obj_destroy - obsolete explicit destructor. Try to use kern_obj_dec_ref
2087 * instead, wait and see if we really need this.
2088 */
2089 static pointer kern_obj_destroy(scheme *sc, pointer args)
2090 {
2091 class Object *obj;
2092
2093 if (!(obj=unpack_obj(sc, &args, "kern-obj-destroy"))) {
2094 return sc->NIL;
2095 }
2096
2097 delete obj;
2098
2099 return sc->NIL;
2100 }
2101 #endif
2102
kern_obj_inc_ref(scheme * sc,pointer args)2103 static pointer kern_obj_inc_ref(scheme *sc, pointer args)
2104 {
2105 class Object *obj;
2106
2107 if (!(obj=unpack_obj(sc, &args, "kern-obj-inc-ref"))) {
2108 return sc->NIL;
2109 }
2110
2111 obj_inc_ref(obj);
2112
2113 return scm_mk_ptr(sc, obj);
2114 }
2115
kern_obj_dec_ref(scheme * sc,pointer args)2116 static pointer kern_obj_dec_ref(scheme *sc, pointer args)
2117 {
2118 class Object *obj;
2119 int refcount;
2120
2121 if (!(obj=unpack_obj(sc, &args, "kern-obj-dec-ref"))) {
2122 return sc->NIL;
2123 }
2124
2125 refcount = obj->refcount;
2126 obj_dec_ref(obj);
2127
2128 if (refcount > 1)
2129 /* object was not destroyed - return it */
2130 return scm_mk_ptr(sc, obj);
2131
2132 /* object was destroyed - return NIL */
2133 return sc->NIL;
2134 }
2135
kern_obj_add_food(scheme * sc,pointer args)2136 static pointer kern_obj_add_food(scheme *sc, pointer args)
2137 {
2138 class Object *obj;
2139 int quantity;
2140
2141 if (unpack(sc, &args, "pd", &obj, &quantity)) {
2142 load_err("kern-obj-add-food: bad args");
2143 return sc->NIL;
2144 }
2145
2146 if (!obj) {
2147 rt_err("kern-obj-add-food: null obj");
2148 return sc->NIL;
2149 }
2150
2151 if (! obj->addFood(quantity)) {
2152 rt_err("kern-obj-add-food: '%s' does not use food",
2153 obj->getName());
2154 }
2155
2156 return sc->NIL;
2157 }
2158
kern_obj_add_gold(scheme * sc,pointer args)2159 static pointer kern_obj_add_gold(scheme *sc, pointer args)
2160 {
2161 class Object *obj;
2162 int quantity;
2163
2164 if (unpack(sc, &args, "pd", &obj, &quantity)) {
2165 load_err("kern-obj-add-gold: bad args");
2166 return sc->NIL;
2167 }
2168
2169 if (!obj) {
2170 rt_err("kern-obj-add-gold: null obj");
2171 return sc->NIL;
2172 }
2173
2174 if (! obj->addGold(quantity)) {
2175 /* NPC's can't add gold (not even if they have containers)
2176 * because gold is not an object! Gold coins are, but that's
2177 * not what gets passed in here, is it? */
2178 rt_err("kern-obj-add-gold: '%s' does not use gold",
2179 obj->getName());
2180 }
2181
2182 return sc->NIL;
2183 }
2184
kern_mk_inventory(scheme * sc,pointer args)2185 static pointer kern_mk_inventory(scheme *sc, pointer args)
2186 {
2187 class Container *container;
2188 pointer contents;
2189
2190 container = new Container();
2191
2192 /* contents */
2193 contents = scm_car(sc, args);
2194 args = scm_cdr(sc, args);
2195 while (contents != sc->NIL) {
2196
2197 int num;
2198 class ObjectType *type;
2199 pointer entry;
2200
2201 entry = scm_car(sc, contents);
2202 contents = scm_cdr(sc, contents);
2203
2204 if (! scm_is_pair(sc, entry)) {
2205 load_err("kern-mk-inventory: error in inv list "\
2206 "(not a pair)");
2207 goto abort;
2208 }
2209
2210 if (unpack(sc, &entry, "dp", &num, &type)) {
2211 load_err("kern-mk-inventory: error in inv list");
2212 goto abort;
2213 }
2214
2215 container->add(type, num);
2216 }
2217
2218 /* hooks */
2219 if (kern_load_hooks(sc, scm_car(sc, args), container)) {
2220 load_err("kern-mk-inventory: error in hook list");
2221 goto abort;
2222 }
2223 args = scm_cdr(sc, args);
2224
2225 return scm_mk_ptr(sc, container);
2226
2227 abort:
2228 delete container;
2229 return sc->NIL;
2230 }
2231
KERN_API_CALL(kern_mk_player)2232 KERN_API_CALL(kern_mk_player)
2233 {
2234 int food, gold, ttnm;
2235 char *mv_desc, *tag;
2236 sound_t *mv_sound;
2237 struct sprite *sprite;
2238 struct terrain_map *campsite;
2239 struct formation *form, *camp_form;
2240 class Container *inventory;
2241 Vehicle *vehicle;
2242 pointer members;
2243 pointer ret;
2244
2245 if (unpack(sc, &args, "ypspdddppppp",
2246 &tag,
2247 &sprite,
2248 &mv_desc, &mv_sound,
2249 &food, &gold, &ttnm,
2250 &form, &campsite, &camp_form,
2251 &vehicle,
2252 &inventory)) {
2253 load_err("kern-mk-player: bad args");
2254 return sc->NIL;
2255 }
2256
2257 if (! inventory) {
2258 load_err("kern-mk-player: nil inventory container");
2259 return sc->NIL;
2260 }
2261
2262 //members = scm_car(sc, scm_cdr(sc, args));
2263 members = scm_car(sc, args);
2264
2265 player_party = new class PlayerParty(tag, sprite,
2266 mv_desc,
2267 mv_sound,
2268 food, gold, form,
2269 campsite,
2270 camp_form);
2271 player_party->setInventoryContainer(inventory);
2272 player_party->setTurnsToNextMeal(ttnm);
2273
2274 /* Load the members. */
2275 while (scm_is_pair(sc, members)) {
2276
2277 class Character *ch;
2278
2279 if (unpack(sc, &members, "p", &ch)) {
2280 load_err("kern-mk-player: error in member list");
2281 goto abort;
2282 }
2283
2284 if (!ch) {
2285 load_err("kern-mk-player: null member object");
2286 goto abort;
2287 }
2288
2289 if (! player_party->addMember(ch)) {
2290 load_err("kern-mk-player: failed to add %s to player "
2291 "party", ch->getName());
2292 goto abort;
2293 }
2294 }
2295
2296 /* Board the vehicle */
2297 if (vehicle) {
2298
2299 /* This sets the vehicle's occupant, too. */
2300 player_party->setVehicle(vehicle);
2301
2302 /* bugfix: party unrefs vehicle when it disembarks; needs to
2303 * keep a refcount while boarded */
2304 obj_inc_ref(vehicle);
2305 }
2306
2307 session_add_obj(Session, player_party, player_dtor, player_save, NULL);
2308 ret = scm_mk_ptr(sc, player_party);
2309 scm_define(sc, tag, ret);
2310 return ret;
2311
2312 abort:
2313 delete player_party;
2314 player_party = 0;
2315 return sc->NIL;
2316 }
2317
sched_dtor(void * data)2318 static void sched_dtor(void *data)
2319 {
2320 sched_del((struct sched *)data);
2321 }
2322
effect_dtor(void * data)2323 static void effect_dtor(void *data)
2324 {
2325 effect_del((struct effect *)data);
2326 }
2327
kern_mk_sched(scheme * sc,pointer args)2328 static pointer kern_mk_sched(scheme *sc, pointer args)
2329 {
2330 struct sched *sched;
2331 char *tag;
2332 char *activity;
2333 int n_appts;
2334 int i;
2335 pointer ret;
2336
2337 /* unpack the tag */
2338 if (unpack(sc, &args, "y", &tag)) {
2339 load_err("kern-mk-sched: bad args");
2340 return sc->NIL;
2341 }
2342
2343 /* count the number of appointments */
2344 n_appts = scm_len(sc, args);
2345
2346 /* alloc the schedule */
2347 sched = sched_new(tag, n_appts);
2348 sched->sc = sc;
2349
2350 /* loop, adding the appointments to the schedule */
2351 for (i = 0; i < n_appts; i++) {
2352 struct appt *appt = &sched->appts[i];
2353 pointer p = scm_car(sc, args);
2354 pointer rect;
2355 args = scm_cdr(sc, args);
2356
2357 if (unpack(sc, &p, "dd", &appt->hr, &appt->min, &activity)) {
2358 load_err("kern-mk-sched %s: bad args in appt %d time",
2359 tag, i);
2360 goto abort;
2361 }
2362
2363 rect = scm_car(sc, p);
2364 p = scm_cdr(sc, p);
2365
2366 if (unpack(sc, &rect, "cdddd", &appt->place_sym,
2367 &appt->x, &appt->y,
2368 &appt->w, &appt->h)) {
2369 load_err("kern-mk-sched %s: bad args in appt %d rect",
2370 tag, i);
2371 goto abort;
2372 }
2373
2374 if (unpack(sc, &p, "s", &activity)) {
2375 load_err("kern-mk-sched %s: bad args in appt %d activity",
2376 tag, i);
2377 goto abort;
2378 }
2379
2380 appt->act = sched_name_to_activity(activity);
2381 if (appt->act < 0) {
2382 load_err("kern-mk-sched %d: unknown activity name %s",
2383 tag, activity);
2384 goto abort;
2385 }
2386 }
2387
2388 session_add(Session, sched, sched_dtor, 0, NULL);
2389 ret = scm_mk_ptr(sc, sched);
2390 scm_define(sc, tag, ret);
2391 return ret;
2392
2393 abort:
2394 sched_del(sched);
2395 return sc->NIL;
2396 }
2397
kern_interp_error(scheme * sc,pointer args)2398 static pointer kern_interp_error(scheme *sc, pointer args)
2399 {
2400 load_err("interpreter error");
2401 return sc->NIL;
2402 }
2403
kern_include(scheme * sc,pointer args)2404 static pointer kern_include(scheme *sc, pointer args)
2405 {
2406 char *fname;
2407
2408 if (unpack(sc, &args, "s", &fname)) {
2409 load_err("kern-include: bad args");
2410 return sc->NIL;
2411 }
2412
2413 session_add(Session, strdup(fname), incfile_dtor, incfile_save, NULL);
2414 Session->num_kern_includes++;
2415 return sc->NIL;
2416 }
2417
2418
kern_set_crosshair(scheme * sc,pointer args)2419 static pointer kern_set_crosshair(scheme *sc, pointer args)
2420 {
2421 if (unpack(sc, &args, "p", &Session->crosshair_type)) {
2422 load_err("kern-set-crosshair: bad args");
2423 }
2424 return sc->NIL;
2425 }
2426
2427
kern_set_damage_sprite(scheme * sc,pointer args)2428 static pointer kern_set_damage_sprite(scheme *sc, pointer args)
2429 {
2430 if (unpack(sc, &args, "p", &Session->damage_sprite)) {
2431 load_err("kern-set-damage-sprite: bad args");
2432 }
2433 return sc->NIL;
2434 }
2435
kern_set_clock(scheme * sc,pointer args)2436 static pointer kern_set_clock(scheme *sc, pointer args)
2437 {
2438 if (unpack(sc, &args, "dddddd",
2439 &Session->clock.year,
2440 &Session->clock.month,
2441 &Session->clock.week,
2442 &Session->clock.day,
2443 &Session->clock.hour,
2444 &Session->clock.min)) {
2445 load_err("kern-set-clock: bad args");
2446 return sc->NIL;
2447 }
2448
2449 if (Session->clock.month >= MONTHS_PER_YEAR ||
2450 Session->clock.week >= WEEKS_PER_MONTH ||
2451 Session->clock.day >= DAYS_PER_WEEK ||
2452 Session->clock.hour >= HOURS_PER_DAY ||
2453 Session->clock.min >= MINUTES_PER_HOUR) {
2454 load_err("kern-set-clock: invalid time");
2455 return sc->NIL;
2456 }
2457
2458 Session->clock.total_minutes =
2459 Session->clock.min +
2460 Session->clock.hour * MINUTES_PER_HOUR +
2461 Session->clock.day * MINUTES_PER_DAY +
2462 Session->clock.week * MINUTES_PER_WEEK +
2463 Session->clock.month * MINUTES_PER_MONTH;
2464 Session->clock.tick_to_change_time = CLOCK_TICKS_PER_MINUTE;
2465 Session->clock.set = 1;
2466
2467 return sc->NIL;
2468 }
2469
kern_obj_apply_damage(scheme * sc,pointer args)2470 static pointer kern_obj_apply_damage(scheme *sc, pointer args)
2471 {
2472 class Object *obj;
2473 char *desc;
2474 int amount;
2475
2476 if (unpack(sc, &args, "psd", &obj, &desc, &amount)) {
2477 rt_err("kern-obj-inflict-damage: bad args");
2478 return sc->NIL;
2479 }
2480
2481 if (!obj) {
2482 rt_err("kern-obj-inflict-damage: null object");
2483 return sc->NIL;
2484 }
2485
2486 obj->damage(amount);
2487
2488 return sc->NIL;
2489 }
2490
kern_obj_inflict_damage(scheme * sc,pointer args)2491 static pointer kern_obj_inflict_damage(scheme *sc, pointer args)
2492 {
2493 class Object *obj;
2494 char *desc;
2495 int amount;
2496 class Character *attacker;
2497
2498 if (unpack(sc, &args, "psdp", &obj, &desc, &amount, &attacker)) {
2499 rt_err("kern-obj-apply-damage: bad args");
2500 return sc->NIL;
2501 }
2502
2503 if (!obj) {
2504 rt_err("kern-obj-apply-damage: null object");
2505 return sc->NIL;
2506 }
2507
2508 obj->inflictDamage(amount,attacker);
2509
2510 return sc->NIL;
2511 }
2512
kern_obj_add_effect(scheme * sc,pointer args)2513 static pointer kern_obj_add_effect(scheme *sc, pointer args)
2514 {
2515 class Object *obj;
2516 struct effect *effect = NULL;
2517 pointer gobcell;
2518 struct gob *gob = NULL;
2519
2520 if (unpack(sc, &args, "ppl", &obj, &effect, &gobcell)) {
2521 rt_err("kern-obj-add-effect: bad args");
2522 return sc->F;
2523 }
2524
2525 if (!obj) {
2526 rt_err("kern-obj-add-effect: null object");
2527 return sc->F;
2528 }
2529
2530 if (! is_effect(effect)) {
2531 rt_err("kern-obj-remove-effect: wrong type for effect!");
2532 return sc->F;
2533 }
2534
2535 /* Note: even if gobcell is sc->NIL we want to wrap it. I once tried to
2536 * use a NULL gob instead but if we pass that back into scheme as an
2537 * arg and the gc tries to mark it we'll crash. */
2538 gob = gob_new(sc, gobcell);
2539 gob->flags |= GOB_SAVECAR;
2540
2541 return obj->addEffect(effect, gob) ? sc->T : sc->F;
2542 }
2543
kern_obj_remove_effect(scheme * sc,pointer args)2544 static pointer kern_obj_remove_effect(scheme *sc, pointer args)
2545 {
2546 class Object *obj;
2547 struct effect *effect;
2548
2549 if (unpack(sc, &args, "pp", &obj, &effect)) {
2550 load_err("kern-obj-remove-effect: bad args");
2551 return sc->F;
2552 }
2553
2554 if (!obj) {
2555 rt_err("kern-obj-remove-effect: null object");
2556 return sc->F;
2557 }
2558
2559 if (! is_effect(effect)) {
2560 rt_err("kern-obj-remove-effect: wrong type for effect!");
2561 return sc->F;
2562 }
2563
2564 /* Just remove one per call */
2565 return obj->removeEffect(effect) ? sc->T : sc->F;
2566 }
2567
kern_print(scheme * sc,pointer args)2568 static pointer kern_print(scheme *sc, pointer args)
2569 {
2570 while (scm_is_pair(sc, args)) {
2571
2572 pointer val = scm_car(sc, args);
2573 args = scm_cdr(sc, args);
2574
2575 if (scm_is_str(sc, val)) {
2576 consolePrint(scm_str_val(sc, val));
2577 } else if (scm_is_int(sc, val)) {
2578 consolePrint("%d", scm_int_val(sc, val));
2579 } else if (scm_is_real(sc, val)) {
2580 consolePrint("%f", scm_real_val(sc, val));
2581 } else {
2582 rt_err("kern-print: bad args");
2583 }
2584 }
2585
2586 return sc->NIL;
2587 }
2588
kern_log_msg(scheme * sc,pointer args)2589 static pointer kern_log_msg(scheme *sc, pointer args)
2590 {
2591 log_begin(NULL);
2592
2593 while (scm_is_pair(sc, args)) {
2594
2595 pointer val = scm_car(sc, args);
2596 args = scm_cdr(sc, args);
2597
2598 if (scm_is_str(sc, val)) {
2599 log_continue(scm_str_val(sc, val));
2600 } else if (scm_is_int(sc, val)) {
2601 log_continue("%d", scm_int_val(sc, val));
2602 } else if (scm_is_real(sc, val)) {
2603 log_continue("%f", scm_real_val(sc, val));
2604 } else {
2605 rt_err("kern-log-msg: bad args");
2606 }
2607 }
2608
2609 log_end(NULL);
2610
2611 return sc->NIL;
2612 }
2613
KERN_API_CALL(kern_log_begin)2614 KERN_API_CALL(kern_log_begin)
2615 {
2616 log_begin(NULL);
2617
2618 while (scm_is_pair(sc, args)) {
2619
2620 pointer val = scm_car(sc, args);
2621 args = scm_cdr(sc, args);
2622
2623 if (scm_is_str(sc, val)) {
2624 log_continue(scm_str_val(sc, val));
2625 } else if (scm_is_int(sc, val)) {
2626 log_continue("%d", scm_int_val(sc, val));
2627 } else if (scm_is_real(sc, val)) {
2628 log_continue("%f", scm_real_val(sc, val));
2629 } else {
2630 rt_err("kern-log-begin: bad args");
2631 }
2632 }
2633
2634 return sc->NIL;
2635 }
2636
KERN_API_CALL(kern_log_end)2637 KERN_API_CALL(kern_log_end)
2638 {
2639 while (scm_is_pair(sc, args)) {
2640
2641 pointer val = scm_car(sc, args);
2642 args = scm_cdr(sc, args);
2643
2644 if (scm_is_str(sc, val)) {
2645 log_continue(scm_str_val(sc, val));
2646 } else if (scm_is_int(sc, val)) {
2647 log_continue("%d", scm_int_val(sc, val));
2648 } else if (scm_is_real(sc, val)) {
2649 log_continue("%f", scm_real_val(sc, val));
2650 } else {
2651 rt_err("kern-log-end: bad args");
2652 }
2653 }
2654
2655 log_end(NULL);
2656
2657 return sc->NIL;
2658 }
2659
kern_log_continue(scheme * sc,pointer args)2660 static pointer kern_log_continue(scheme *sc, pointer args)
2661 {
2662 while (scm_is_pair(sc, args)) {
2663
2664 pointer val = scm_car(sc, args);
2665 args = scm_cdr(sc, args);
2666
2667 if (scm_is_str(sc, val)) {
2668 log_continue(scm_str_val(sc, val));
2669 } else if (scm_is_int(sc, val)) {
2670 log_continue("%d", scm_int_val(sc, val));
2671 } else if (scm_is_real(sc, val)) {
2672 log_continue("%f", scm_real_val(sc, val));
2673 } else {
2674 rt_err("kern-log-continue: bad args");
2675 }
2676 }
2677
2678 return sc->NIL;
2679 }
2680
KERN_API_CALL(kern_log_flush)2681 KERN_API_CALL(kern_log_flush)
2682 {
2683 log_flush();
2684 return sc->T;
2685 }
2686
kern_stdout_msg(scheme * sc,pointer args)2687 static pointer kern_stdout_msg(scheme *sc, pointer args)
2688 {
2689
2690 while (scm_is_pair(sc, args)) {
2691
2692 pointer val = scm_car(sc, args);
2693 args = scm_cdr(sc, args);
2694
2695 if (scm_is_str(sc, val)) {
2696 fprintf(stdout,"%s",scm_str_val(sc, val));
2697 } else if (scm_is_int(sc, val)) {
2698 fprintf(stdout,"%ld",scm_int_val(sc, val));
2699 } else if (scm_is_real(sc, val)) {
2700 fprintf(stdout,"%f",scm_real_val(sc, val));
2701 } else {
2702 rt_err("kern-print: bad args");
2703 }
2704 }
2705 fprintf(stdout,"\n");
2706
2707 return sc->NIL;
2708 }
2709
KERN_API_CALL(kern_log_enable)2710 KERN_API_CALL(kern_log_enable)
2711 {
2712 int val;
2713
2714 if (unpack(sc, &args, "b", &val)) {
2715 rt_err("kern_log_enable: bad args");
2716 return sc->F;
2717 }
2718
2719 if (val)
2720 log_enable();
2721 else
2722 log_disable();
2723
2724 return sc->T;
2725 }
2726
kern_conv_say(scheme * sc,pointer args)2727 static pointer kern_conv_say(scheme *sc, pointer args)
2728 {
2729 class Character *speaker;
2730 struct conv *conv;
2731
2732 if (unpack(sc, &args, "p", &speaker)) {
2733 rt_err("kern-conv-say: bad args");
2734 return sc->NIL;
2735 }
2736
2737 if (speaker == NULL) {
2738 rt_err("kern-conv-say: null speaker");
2739 return sc->NIL;
2740 }
2741
2742 if (!(conv = speaker->getConversation())) {
2743 rt_err("%s() no conv for %s", __FUNCTION__, speaker->getName());
2744 return sc->NIL;
2745 }
2746
2747 if (speaker->isKnown()) {
2748 log_begin("^c+%c%s:^c- ", CONV_NPC_COLOR, speaker->getName());
2749 } else {
2750 log_begin("^c+%c", CONV_NPC_COLOR);
2751 speaker->describe();
2752 log_continue(":^c- ");
2753 }
2754
2755 args = scm_car(sc, args);
2756
2757 while (scm_is_pair(sc, args)) {
2758
2759 pointer val = scm_car(sc, args);
2760 args = scm_cdr(sc, args);
2761 if (scm_is_str(sc, val)) {
2762 char *beg, *end, *text = scm_str_val(sc, val);
2763 while (text) {
2764 if (! conv_get_word(text, &beg, &end)) {
2765 log_continue(text);
2766 text = NULL;
2767 } else {
2768 int keyword = conv_is_keyword(conv, beg);
2769 if (text<beg) {
2770 do {
2771 log_continue("%c", *text);
2772 text++;
2773 } while (text<beg);
2774 }
2775 if (keyword) {
2776 char color = (keyword & CONV_IS_MARKED) ? 'G' : 'm';
2777 log_continue("^c+%c", color);
2778 }
2779 while (beg<end) {
2780 log_continue("%c", *beg);
2781 beg++;
2782 }
2783 if (keyword) {
2784 log_continue("^c-");
2785 }
2786 text = end;
2787 }
2788 }
2789 } else if (scm_is_int(sc, val)) {
2790 log_continue("%d", scm_int_val(sc, val));
2791 } else if (scm_is_real(sc, val)) {
2792 log_continue("%f", scm_real_val(sc, val));
2793 } else {
2794 rt_err("kern-print: bad args");
2795 }
2796 }
2797
2798 log_end(NULL);
2799
2800 return sc->NIL;
2801 }
2802
kern_conv_get_yes_no(scheme * sc,pointer args)2803 static pointer kern_conv_get_yes_no(scheme *sc, pointer args)
2804 {
2805 Object *pc = unpack_obj(sc, &args, "kern-conv-get-yes-no?");
2806 if (NULL == pc)
2807 return sc->F;
2808 return ui_get_yes_no(pc->getName()) ? sc->T : sc->F;
2809 }
2810
kern_conv_get_amount(scheme * sc,pointer args)2811 static pointer kern_conv_get_amount(scheme *sc, pointer args)
2812 {
2813 cmdwin_clear();
2814 cmdwin_spush("How much");
2815 return scm_mk_integer(sc, ui_get_quantity(-1));
2816 }
2817
kern_conv_get_reply(scheme * sc,pointer args)2818 static pointer kern_conv_get_reply(scheme *sc, pointer args)
2819 {
2820 char buf[32];
2821
2822 Object *pc = unpack_obj(sc, &args, "kern-conv-get-reply");
2823 if (NULL == pc)
2824 return sc->F;
2825
2826 ui_getline(buf, sizeof(buf));
2827 log_msg("^c+%c%s:^c- %s", CONV_PC_COLOR, pc->getName(), buf);
2828
2829 /* Return only the first four characters, to be consistent with the
2830 * usual keyword/reply scheme. */
2831 buf[4] = 0;
2832
2833 return scm_mk_symbol(sc, buf);
2834 }
2835
kern_conv_get_string(scheme * sc,pointer args)2836 static pointer kern_conv_get_string(scheme *sc, pointer args)
2837 {
2838 char buf[32];
2839
2840 Object *pc = unpack_obj(sc, &args, "kern-conv-get-string");
2841 if (NULL == pc)
2842 return sc->F;
2843
2844 ui_getline(buf, sizeof(buf));
2845 log_msg("%s: %s", pc->getName(), buf);
2846
2847 return scm_mk_string(sc, buf);
2848 }
2849
kern_conv_trade(scheme * sc,pointer args)2850 static pointer kern_conv_trade(scheme *sc, pointer args)
2851 {
2852 Object *npc;
2853 Object *pc;
2854 struct merchant merch;
2855 int i, traded = 0;
2856 char *menu = 0;
2857 pointer catalog = sc->NIL;
2858
2859 if (unpack(sc, &args, "pps", &npc, &pc, &menu)) {
2860 rt_err("kern-conv-trade: bad args");
2861 return sc->NIL;
2862 }
2863
2864 if (! npc || ! pc) {
2865 rt_err("kern-conv-trade: null kernel object(s)");
2866 return sc->NIL;
2867 }
2868
2869 /* Get the catalog */
2870 if (! scm_is_pair(sc, args)) {
2871 rt_err("kern-conv-trade: no catalog!");
2872 return sc->NIL;
2873 }
2874 catalog = scm_car(sc, args);
2875 args = scm_cdr(sc, args);
2876 if (! scm_is_pair(sc, catalog)) {
2877 rt_err("kern-conv-trade: catalog is not a list");
2878 return sc->NIL;
2879 }
2880
2881 /* setup the merchant struct */
2882 merch.name = npc->getName();
2883 merch.n_trades = scm_len(sc, catalog);
2884 if (! merch.n_trades) {
2885 rt_err("kern-conv-trade: nothing in trade list");
2886 return sc->NIL;
2887 }
2888 merch.trades = (struct trade_info*)calloc(merch.n_trades,
2889 sizeof(struct trade_info));
2890 assert(merch.trades);
2891
2892 /* fill out the merchant's item list */
2893 for (i = 0; i < merch.n_trades; i++) {
2894
2895 ObjectType *type;
2896 pointer p = scm_car(sc, catalog);
2897 struct trade_info *trade = &merch.trades[i];
2898 catalog = scm_cdr(sc, catalog);
2899
2900 if (unpack(sc, &p, "pds", &type, &trade->cost, &trade->sales_pitch)) {
2901 rt_err("kern-conv-trade: bad args in trade list %d", i);
2902 goto abort;
2903 }
2904
2905 if (! type) {
2906 rt_err("kern-conv-trade: null object type in trade list %d", i);
2907 goto abort;
2908 }
2909
2910 /* This is kind of dumb. We should just point to the ObjectType
2911 * and be done with it. */
2912 trade->sprite = type->getSprite();
2913 trade->name = type->getName();
2914 trade->data = type;
2915 trade->quantity = player_party->inventory->numAvail(type);
2916 trade->show_sprite = 1;
2917 trade->show_quantity = 1;
2918 }
2919
2920 if (! strcmp(menu, "buy")) {
2921 traded = ui_buy(&merch);
2922 } else if (! strcmp(menu, "sell")) {
2923 traded = ui_sell(&merch);
2924 } else {
2925 traded = ui_trade(&merch);
2926 }
2927
2928 abort:
2929 free(merch.trades);
2930 return traded ? sc->T : sc->F;
2931 }
2932
kern_obj_get_activity(scheme * sc,pointer args)2933 static pointer kern_obj_get_activity(scheme *sc, pointer args)
2934 {
2935 class Object *obj = unpack_obj(sc, &args, "kern-obj-get-activity");
2936 if (obj == NULL)
2937 return sc->NIL;
2938
2939 return scm_mk_string(sc,
2940 sched_activity_to_name(obj->getActivity()));
2941 }
2942
kern_obj_set_sprite(scheme * sc,pointer args)2943 static pointer kern_obj_set_sprite(scheme *sc, pointer args)
2944 {
2945 class Object *obj;
2946 struct sprite *sprite;
2947
2948 if (unpack(sc, &args, "pp", &obj, &sprite)) {
2949 rt_err("kern-obj-set-sprite: bad args");
2950 return sc->NIL;
2951 }
2952
2953 if (!obj) {
2954 rt_err("kern-obj-set-sprite: null object");
2955 return sc->NIL;
2956 }
2957
2958 obj->setSprite(sprite);
2959
2960 return sc->NIL;
2961 }
2962
kern_obj_set_opacity(scheme * sc,pointer args)2963 static pointer kern_obj_set_opacity(scheme *sc, pointer args)
2964 {
2965 class Object *obj;
2966 int opacity;
2967
2968 if (unpack(sc, &args, "pb", &obj, &opacity)) {
2969 rt_err("kern-obj-set-opacity: bad args");
2970 return sc->NIL;
2971 }
2972
2973 if (!obj) {
2974 rt_err("kern-obj-set-opacity: null object");
2975 return sc->NIL;
2976 }
2977
2978 obj->setOpacity(opacity != 0);
2979
2980 return sc->NIL;
2981 }
2982
kern_obj_set_ap(scheme * sc,pointer args)2983 static pointer kern_obj_set_ap(scheme *sc, pointer args)
2984 {
2985 class Object *obj;
2986 int ap;
2987
2988 if (unpack(sc, &args, "pd", &obj, &ap)) {
2989 rt_err("kern-obj-set-ap: bad args");
2990 return sc->NIL;
2991 }
2992
2993 if (!obj) {
2994 rt_err("kern-obj-set-ap: null object");
2995 return sc->NIL;
2996 }
2997
2998 obj->setActionPoints(ap);
2999
3000 return sc->NIL;
3001 }
3002
kern_obj_set_facing(scheme * sc,pointer args)3003 static pointer kern_obj_set_facing(scheme *sc, pointer args)
3004 {
3005 class Object *obj;
3006 int facing;
3007
3008 if (unpack(sc, &args, "pd", &obj, &facing)) {
3009 rt_err("kern-obj-set-facing: bad args");
3010 return sc->NIL;
3011 }
3012
3013 if (!obj) {
3014 rt_err("kern-obj-set-facing: null object");
3015 return sc->NIL;
3016 }
3017
3018 obj->setFacing(facing);
3019
3020 return sc->NIL;
3021 }
3022
kern_obj_get_facing(scheme * sc,pointer args)3023 static pointer kern_obj_get_facing(scheme *sc, pointer args)
3024 {
3025 class Object *obj;
3026
3027 if (unpack(sc, &args, "p", &obj)) {
3028 rt_err("kern-obj-get-facing: bad args");
3029 return sc->NIL;
3030 }
3031
3032 if (!obj) {
3033 rt_err("kern-obj-get-facing: null object");
3034 return sc->NIL;
3035 }
3036
3037 return scm_mk_integer(sc, obj->getFacing());
3038 }
3039
kern_obj_set_conv(scheme * sc,pointer args)3040 static pointer kern_obj_set_conv(scheme *sc, pointer args)
3041 {
3042 class Object *obj;
3043 pointer conv;
3044
3045 if (unpack(sc, &args, "pc", &obj, &conv)) {
3046 rt_err("kern-obj-set-conv: bad args");
3047 return sc->NIL;
3048 }
3049
3050 if (conv == sc->NIL) {
3051 obj->setConversation(NULL);
3052 } else {
3053 kern_load_conv(sc, conv, obj);
3054 }
3055
3056 return scm_mk_ptr(sc, obj);
3057 }
3058
kern_char_set_known(scheme * sc,pointer args)3059 static pointer kern_char_set_known(scheme *sc, pointer args)
3060 {
3061 class Character *ch;
3062 int val;
3063
3064 ch = (class Character*)unpack_obj(sc, &args, "kern-char-set-known");
3065 if (!ch)
3066 return sc->NIL;
3067
3068 if (unpack(sc, &args, "b", &val)) {
3069 rt_err("kern-char-set-known: bad args");
3070 return sc->NIL;
3071 }
3072
3073 ch->setKnown(val);
3074 return scm_mk_ptr(sc, ch);
3075 }
3076
kern_obj_set_visible(scheme * sc,pointer args)3077 static pointer kern_obj_set_visible(scheme *sc, pointer args)
3078 {
3079 class Object *obj;
3080 int val;
3081
3082 if (unpack(sc, &args, "pb", &obj, &val)) {
3083 rt_err("kern-obj-set-visible: bad args");
3084 return sc->NIL;
3085 }
3086
3087 if (!obj) {
3088 rt_err("kern-obj-set-visible: null object");
3089 return sc->NIL;
3090 }
3091
3092 obj->setVisible(val);
3093
3094 return scm_mk_ptr(sc, obj);
3095 }
3096
kern_obj_set_submerged(scheme * sc,pointer args)3097 static pointer kern_obj_set_submerged(scheme *sc, pointer args)
3098 {
3099 class Object *obj;
3100 int val;
3101
3102 if (unpack(sc, &args, "pb", &obj, &val)) {
3103 rt_err("kern-obj-set-submerged: bad args");
3104 return sc->NIL;
3105 }
3106
3107 if (!obj) {
3108 rt_err("kern-obj-set-submerged: null object");
3109 return sc->NIL;
3110 }
3111
3112 obj->setSubmerged(val);
3113
3114 return scm_mk_ptr(sc, obj);
3115 }
3116
kern_obj_set_pclass(scheme * sc,pointer args)3117 static pointer kern_obj_set_pclass(scheme *sc, pointer args)
3118 {
3119 class Object *obj;
3120 int val;
3121
3122 if (unpack(sc, &args, "pd", &obj, &val)) {
3123 rt_err("kern-obj-set-pclass: bad args");
3124 return sc->NIL;
3125 }
3126
3127 if (!obj) {
3128 rt_err("kern-obj-set-pclass: null object");
3129 return sc->NIL;
3130 }
3131
3132 obj->setPclass(val);
3133
3134 return sc->NIL;
3135 }
3136
kern_obj_get_type(scheme * sc,pointer args)3137 static pointer kern_obj_get_type(scheme *sc, pointer args)
3138 {
3139 Object *obj;
3140
3141 if (!(obj = unpack_obj(sc, &args, "kern-obj-get-type")))
3142 return sc->NIL;
3143
3144 return scm_mk_ptr(sc, obj->getObjectType());
3145 }
3146
kern_place_map(scheme * sc,pointer args)3147 static pointer kern_place_map(scheme *sc, pointer args)
3148 {
3149 struct place *place;
3150
3151 if (unpack(sc, &args, "p", &place)) {
3152 rt_err("kern-place-map: bad args");
3153 return sc->NIL;
3154 }
3155
3156 if (! place || ! place->terrain_map) {
3157 rt_err("kern-place-map: null place or map");
3158 return sc->NIL;
3159 }
3160
3161 return scm_mk_ptr(sc, place->terrain_map);
3162 }
3163
KERN_API_CALL(kern_place_synch)3164 KERN_API_CALL(kern_place_synch)
3165 {
3166 struct place *place;
3167
3168 if (unpack(sc, &args, "p", &place)) {
3169 rt_err("kern-place-synch: bad args");
3170 return sc->NIL;
3171 }
3172
3173 if (! place) {
3174 rt_err("kern-place-synch: null place");
3175 return sc->NIL;
3176 }
3177 place_synchronize(place);
3178 return sc->NIL;
3179 }
3180
KERN_API_CALL(kern_place_is_visible)3181 KERN_API_CALL(kern_place_is_visible)
3182 {
3183 struct place *place;
3184 int x, y;
3185
3186 if (unpack_loc(sc, &args, &place, &x, &y, "kern_place_is_visible"))
3187 return sc->NIL;
3188
3189 if (! place) {
3190 rt_err("kern_place_is_visible: null place");
3191 return sc->NIL;
3192 }
3193
3194 // the player party doesnt wind up being in a temporary combat map,
3195 // but by its existance we can infer the player is there
3196 if (!place_is_wilderness_combat(place) && place != player_party->getPlace())
3197 {
3198 return sc->F;
3199 }
3200
3201 if (mapTileIsVisible(x,y) && (mapTileLightLevel(x,y) >= MIN_XAMINE_LIGHT_LEVEL))
3202 {
3203 return sc->T;
3204 }
3205 else
3206 {
3207 return sc->F;
3208 }
3209 }
3210
KERN_API_CALL(kern_place_is_combat_map)3211 KERN_API_CALL(kern_place_is_combat_map)
3212 {
3213 struct place *place;
3214
3215 if (unpack(sc, &args, "p", &place)) {
3216 rt_err("kern_place_is_combat_map: bad args");
3217 return sc->NIL;
3218 }
3219
3220 if (! place) {
3221 rt_err("kern_place_is_combat_map: null place");
3222 return sc->NIL;
3223 }
3224
3225 if (place_is_wilderness_combat(place))
3226 {
3227 return sc->T;
3228 }
3229 else
3230 {
3231 return sc->F;
3232 }
3233 }
3234
kern_blit_map(scheme * sc,pointer args)3235 static pointer kern_blit_map(scheme *sc, pointer args)
3236 {
3237 struct terrain_map *src;
3238 struct terrain_map *dst;
3239 int dst_x;
3240 int dst_y;
3241 int src_x;
3242 int src_y;
3243 int w;
3244 int h;
3245
3246 if (unpack(sc, &args, "pddpdddd", &dst, &dst_x, &dst_y,
3247 &src, &src_x, &src_y, &w, &h)) {
3248 rt_err("kern-blit-map: bad args");
3249 return sc->NIL;
3250 }
3251
3252 if (! dst || ! src) {
3253 rt_err("kern-blit-map: null src or dst map");
3254 return sc->NIL;
3255 }
3256
3257 terrain_map_blit(dst, dst_x, dst_y, src, src_x, src_y, w, h);
3258
3259 vmask_flush_all();
3260
3261
3262 /* Return the modified destination map */
3263 return scm_mk_ptr(sc, dst);
3264 }
3265
kern_map_rotate(scheme * sc,pointer args)3266 static pointer kern_map_rotate(scheme *sc, pointer args)
3267 {
3268 struct terrain_map *map;
3269 int degree;
3270
3271 if (unpack(sc, &args, "pd", &map, °ree)) {
3272 rt_err("kern-map-rotate: bad args");
3273 return sc->NIL;
3274 }
3275
3276 if (! map) {
3277 rt_err("kern-map-rotate: null map");
3278 return sc->NIL;
3279 }
3280
3281 terrain_map_rotate(map, degree);
3282
3283 /* Return the modified map */
3284 return scm_mk_ptr(sc, map);
3285 }
3286
3287
kern_map_flash_sprite(scheme * sc,pointer args)3288 static pointer kern_map_flash_sprite(scheme *sc, pointer args)
3289 {
3290 int x, y;
3291 struct sprite *sprite;
3292
3293 if (unpack(sc, &args, "pdd", &sprite, &x, &y)) {
3294 rt_err("kern_map_flash_sprite: bad args");
3295 return sc->NIL;
3296 }
3297
3298 if (!sprite) {
3299 rt_err("kern_map_flash_sprite: null sprite");
3300 return sc->NIL;
3301 }
3302
3303 if (mapTileLightLevel(x,y) < MIN_XAMINE_LIGHT_LEVEL || (!mapTileIsVisible(x,y)))
3304 {
3305 return sc->NIL;
3306 }
3307
3308 mapFlashSprite(x, y, sprite);
3309
3310 return sc->NIL;
3311 }
3312
kern_tag(scheme * sc,pointer args)3313 static pointer kern_tag(scheme *sc, pointer args)
3314 {
3315 char *tag;
3316 Object *obj;
3317 pointer p;
3318
3319 if (unpack(sc, &args, "y", &tag)) {
3320 rt_err("kern-tag: bad args");
3321 return sc->NIL;
3322 }
3323
3324 if (! scm_is_pair(sc, args)) {
3325 rt_err("kern-tag %s: no second arg", tag);
3326 return sc->NIL;
3327 }
3328
3329 p = scm_car(sc, args);
3330 scm_define(sc, tag, p);
3331
3332 if (unpack(sc, &args, "p", &obj)) {
3333 rt_err("kern-tag: bad object");
3334 return sc->NIL;
3335 }
3336
3337 /* Tagged objects may be referred to in the script by their
3338 * tag. If the object is destroyed, the scheme variable that
3339 * refers to the object is still valid (in Scheme, it isn't
3340 * really possible to undefine variables). To prevent crashes
3341 * on dereferencing this variable we'll bump the refcount. To
3342 * ensure the object is destroyed on session teardown, we'll
3343 * mark it for custom finalization, which will decrement the
3344 * extra refcount. */
3345 obj_inc_ref(obj);
3346 scm_set_cust_fin(sc, p);
3347
3348 obj->tag = strdup(tag);
3349 assert(obj->tag);
3350
3351 return p;
3352 }
3353
kern_obj_get_gob(scheme * sc,pointer args)3354 static pointer kern_obj_get_gob(scheme *sc, pointer args)
3355 {
3356 Object *obj;
3357
3358 if (unpack(sc, &args, "p", &obj)) {
3359 rt_err("kern-obj-get-gob: bad args");
3360 return sc->NIL;
3361 }
3362
3363 if (!obj) {
3364 rt_err("kern-obj-get-gob: null obj");
3365 return sc->NIL;
3366 }
3367
3368 if (obj->getGob() == NULL) {
3369 return sc->NIL;
3370 }
3371
3372 // It's already a scheme pointer so just return it directly
3373 return obj->getGob()->p;
3374 }
3375
kern_obj_set_gob(scheme * sc,pointer args)3376 static pointer kern_obj_set_gob(scheme *sc, pointer args)
3377 {
3378 Object *obj;
3379
3380 if (! (obj = unpack_obj(sc, &args, "kern-obj-set-gob"))) {
3381 return sc->NIL;
3382 }
3383
3384 if (! scm_is_pair(sc, args)) {
3385 rt_err("kern-obj-set-gob: no gob specified");
3386 return sc->NIL;
3387 }
3388
3389 obj->setGob(gob_new(sc, scm_car(sc, args)));
3390
3391 return sc->NIL;
3392 }
3393
kern_obj_set_ttl(scheme * sc,pointer args)3394 static pointer kern_obj_set_ttl(scheme *sc, pointer args)
3395 {
3396 Object *obj;
3397 int ttl;
3398
3399 if (! (obj = unpack_obj(sc, &args, "kern-obj-set-ttl"))) {
3400 goto done;
3401 }
3402
3403 if (unpack(sc, &args, "d", &ttl)) {
3404 rt_err("kern-obj-set-ttl: bad ttl");
3405 goto done;
3406 }
3407
3408 Object::setTTL(obj, ttl);
3409 done:
3410 return scm_mk_ptr(sc, obj);
3411 }
3412
kern_astral_body_get_gob(scheme * sc,pointer args)3413 static pointer kern_astral_body_get_gob(scheme *sc, pointer args)
3414 {
3415 struct astral_body *astral_body;
3416
3417 if (unpack(sc, &args, "p", &astral_body)) {
3418 rt_err("kern-astral-body-get-gob: bad args");
3419 return sc->NIL;
3420 }
3421
3422 if (! astral_body) {
3423 rt_err("kern-astral-body-get-gob: null object");
3424 return sc->NIL;
3425 }
3426
3427 if (astral_body->gob == NULL) {
3428 rt_err("kern-astral-body-get-gob: no gob for %s",
3429 astral_body->name);
3430 return sc->NIL;
3431 }
3432
3433 // It's already a scheme pointer so just return it directly
3434 return astral_body->gob->p;
3435 }
3436
kern_astral_body_get_phase(scheme * sc,pointer args)3437 static pointer kern_astral_body_get_phase(scheme *sc, pointer args)
3438 {
3439 struct astral_body *astral_body;
3440
3441 if (unpack(sc, &args, "p", &astral_body)) {
3442 rt_err("kern-astral-body-get-phase: bad args");
3443 return sc->NIL;
3444 }
3445
3446 if (! astral_body) {
3447 rt_err("kern-astral-body-get-phase: null object");
3448 return sc->NIL;
3449 }
3450
3451 return scm_mk_integer(sc, astral_body->phase);
3452 }
3453
kern_astral_body_set_gob(scheme * sc,pointer args)3454 static pointer kern_astral_body_set_gob(scheme *sc, pointer args)
3455 {
3456 struct astral_body *astral_body;
3457
3458 if (unpack(sc, &args, "p", &astral_body)) {
3459 rt_err("kern-astral-body-set-gob: bad args");
3460 return sc->NIL;
3461 }
3462
3463 if (! astral_body) {
3464 rt_err("kern-astral-body-set-gob: null object");
3465 return sc->NIL;
3466 }
3467
3468 if (! scm_is_pair(sc, args)) {
3469 rt_err("kern-astral-body-set-gob: no gob specified");
3470 return sc->NIL;
3471 }
3472
3473 astral_body->gob = (gob_new(sc, scm_car(sc, args)));
3474
3475 return sc->NIL;
3476 }
3477
kern_type_get_gifc(scheme * sc,pointer args)3478 static pointer kern_type_get_gifc(scheme *sc, pointer args)
3479 {
3480 ObjectType *cptr;
3481 closure_t *gifc;
3482
3483 if (unpack(sc, &args, "p", &cptr)) {
3484 rt_err("kern-type-get-gifc: bad args");
3485 return sc->NIL;
3486 }
3487
3488 if (cptr == NULL) {
3489 /* This is not necessarily an error. Some objects (like
3490 * characters) have no type, which can result in us getting
3491 * here. */
3492 return sc->NIL;
3493 }
3494
3495 gifc = cptr->getGifc();
3496
3497 return gifc ? gifc->code : sc->NIL;
3498 }
3499
kern_type_get_name(scheme * sc,pointer args)3500 static pointer kern_type_get_name(scheme *sc, pointer args)
3501 {
3502 ObjectType *cptr;
3503
3504 if (unpack(sc, &args, "p", &cptr)) {
3505 rt_err("kern-type-get-name: bad args");
3506 return sc->NIL;
3507 }
3508
3509 if (cptr == NULL) {
3510 /* This is not necessarily an error. Some objects (like
3511 * characters) have no type, which can result in us getting
3512 * here. */
3513 return sc->NIL;
3514 }
3515
3516 return scm_mk_string(sc, cptr->getName());
3517 }
3518
kern_type_describe(scheme * sc,pointer args)3519 static pointer kern_type_describe(scheme *sc, pointer args)
3520 {
3521 ObjectType *cptr;
3522
3523 if (unpack(sc, &args, "p", &cptr)) {
3524 rt_err("kern-type-get-name: bad args");
3525 return sc->NIL;
3526 }
3527
3528 if (cptr == NULL) {
3529 /* This is not necessarily an error. Some objects (like
3530 * characters) have no type, which can result in us getting
3531 * here. */
3532 return sc->NIL;
3533 }
3534
3535 cptr->describeType(1);
3536 return sc->NIL;
3537 }
3538
kern_add_tick_job(scheme * sc,pointer args)3539 static pointer kern_add_tick_job(scheme *sc, pointer args)
3540 {
3541 int tick;
3542 pointer proc;
3543 void *data;
3544
3545 if (unpack(sc, &args, "dop", &tick, &proc, &data)) {
3546 rt_err("kern-add-tick-job: bad args");
3547 return sc->NIL;
3548 }
3549
3550 wqCreateJob(&TickWorkQueue, Tick + tick, 0,
3551 kjob_new(data, closure_new(sc, proc)),
3552 kern_run_wq_job);
3553
3554 return sc->NIL;
3555 }
3556
kern_ui_select_party_member(scheme * sc,pointer args)3557 static pointer kern_ui_select_party_member(scheme *sc, pointer args)
3558 {
3559 class Character *member;
3560
3561 member = select_party_member();
3562 cmdwin_pop();
3563 if (! member) {
3564 return sc->NIL;
3565 }
3566 return scm_mk_ptr(sc, member);
3567 }
3568
kern_conv_end(scheme * sc,pointer args)3569 static pointer kern_conv_end(scheme *sc, pointer args)
3570 {
3571 conv_end();
3572 return sc->T;
3573 }
3574
3575
kern_conv_begin(scheme * sc,pointer args)3576 static pointer kern_conv_begin(scheme *sc, pointer args)
3577 {
3578 class Character *npc, *member;
3579 struct conv *conv;
3580
3581 if (unpack(sc, &args, "p", &npc)) {
3582 rt_err("kern-conv-begin: bad args");
3583 return sc->F;
3584 }
3585
3586 conv = npc->getConversation();
3587 if (! conv) {
3588 rt_err("kern-conv-begin: npc has no conv!");
3589 return sc->F;
3590 }
3591
3592 member = player_party->get_leader();
3593 if (! member) {
3594 rt_err("kern-conv-begin: no player party leader!");
3595 return sc->F;
3596 }
3597
3598 log_begin("You are accosted by ");
3599 Session->subject = player_party;
3600 npc->describe();
3601 Session->subject = NULL;
3602 log_end(".");
3603
3604 conv_enter(npc, member, conv);
3605
3606 return sc->T;
3607 }
3608
kern_map_set_dirty(scheme * sc,pointer args)3609 static pointer kern_map_set_dirty(scheme *sc, pointer args)
3610 {
3611 mapSetDirty();
3612 return sc->T;
3613 }
3614
kern_mk_astral_body(scheme * sc,pointer args)3615 static pointer kern_mk_astral_body(scheme *sc, pointer args)
3616 {
3617 struct astral_body *body;
3618 char *tag;
3619 char *name;
3620 int minutes_per_phase;
3621 int minutes_per_degree;
3622 int initial_arc;
3623 int initial_phase;
3624 int distance;
3625 pointer proc;
3626 pointer phases;
3627 pointer ret;
3628 int i;
3629
3630 if (unpack(sc, &args, "ysdddddc",
3631 &tag,
3632 &name,
3633 &distance,
3634 &minutes_per_phase,
3635 &minutes_per_degree,
3636 &initial_arc,
3637 &initial_phase,
3638 &proc)) {
3639 load_err("kern-mk-astral-body: bad args");
3640 return sc->NIL;
3641 }
3642
3643 if (! scm_is_pair(sc, args)) {
3644 load_err("kern-mk-astral-body: null phase list");
3645 return sc->NIL;
3646 }
3647
3648 phases = scm_car(sc, args);
3649 args = scm_cdr(sc, args);
3650
3651 body = astral_body_new(tag, name, scm_len(sc, phases));
3652 body->distance = distance;
3653 body->minutes_per_phase = minutes_per_phase;
3654 body->minutes_per_degree = minutes_per_degree;
3655 body->initial_arc = initial_arc;
3656 body->initial_phase = initial_phase;
3657 body->arc = initial_arc;
3658 body->phase = initial_phase;
3659
3660 if (proc != sc->NIL)
3661 body->gifc = closure_new_ref(sc, proc);
3662
3663 i = 0;
3664 while (scm_is_pair(sc, phases)) {
3665 pointer phase = scm_car(sc, phases);
3666 phases = scm_cdr(sc, phases);
3667 char *phase_name = NULL;
3668
3669 if (unpack(sc, &phase, "pds",
3670 &body->phases[i].sprite,
3671 &body->phases[i].maxlight,
3672 &phase_name)) {
3673 load_err("kern-mk-astral-body: bad args in phase "\
3674 "list at entry %d", i);
3675 goto abort;
3676 }
3677 if (! phase_name) {
3678 load_err("kern-mk-astral-body %s: null phase name",
3679 body->tag);
3680 goto abort;
3681 }
3682 body->phases[i].name = strdup(phase_name);
3683 assert(body->phases[i].name);
3684 i++;
3685 }
3686
3687 /* Like types, I define astral bodies in the script so they can be
3688 * referred to by their tags as script variables. I do this because a)
3689 * kern-obj-tag won't work on them, so I need some other way to tag
3690 * them, and b) they are unique enough that it won't hurt to just
3691 * automatically make them variables. */
3692 sky_add_astral_body(&Session->sky, body);
3693 ret = scm_mk_ptr(sc, body);
3694 scm_define(sc, tag, ret);
3695
3696 return ret;
3697
3698 abort:
3699 astral_body_del(body);
3700 return sc->NIL;
3701
3702 }
3703
KERN_API_CALL(kern_mk_vehicle_type)3704 KERN_API_CALL(kern_mk_vehicle_type)
3705 {
3706 VehicleType *type;
3707 const char *tag = TAG_UNK;
3708 char *name;
3709 struct sprite *sprite;
3710 struct terrain_map *map;
3711 ArmsType *ordnance;
3712 int vulnerable;
3713 int killsOccupants;
3714 int mustTurn;
3715 char *mv_desc;
3716 sound_t *mv_sound;
3717 int tailwind_penalty;
3718 int headwind_penalty;
3719 int crosswind_penalty;
3720 int max_hp;
3721 int speed;
3722 pointer ret;
3723 struct mmode *mmode;
3724 pointer proc;
3725
3726 if (unpack(sc, &args, "yspppbbbspdddddpo",
3727 &tag,
3728 &name,
3729 &sprite,
3730 &map,
3731 &ordnance,
3732 &vulnerable,
3733 &killsOccupants,
3734 &mustTurn,
3735 &mv_desc,
3736 &mv_sound,
3737 &tailwind_penalty,
3738 &headwind_penalty,
3739 &crosswind_penalty,
3740 &max_hp,
3741 &speed,
3742 &mmode,
3743 &proc
3744 )) {
3745 load_err("kern-mk-vehicle-type %s: bad args", tag);
3746 return sc->NIL;
3747 }
3748
3749 type = new VehicleType(tag,
3750 name,
3751 sprite,
3752 map,
3753 ordnance,
3754 vulnerable,
3755 killsOccupants,
3756 mustTurn,
3757 mv_desc,
3758 mv_sound,
3759 tailwind_penalty,
3760 headwind_penalty,
3761 crosswind_penalty,
3762 max_hp,
3763 speed
3764 );
3765 assert(type);
3766
3767 type->mmode = mmode;
3768 session_add(Session, type, vehicle_type_dtor, NULL, NULL);
3769 ret = scm_mk_ptr(sc, type);
3770 scm_define(sc, tag, ret);
3771
3772 if (proc != sc->NIL) {
3773 type->renderCombat = closure_new(sc, proc);
3774 closure_ref(type->renderCombat); //TODO clean up this nasty leaky hack
3775 }
3776 else
3777 {
3778 type->renderCombat=NULL;
3779 }
3780
3781 return ret;
3782 }
3783
KERN_API_CALL(kern_mk_vehicle)3784 KERN_API_CALL(kern_mk_vehicle)
3785 {
3786 Vehicle *vehicle;
3787 VehicleType *type;
3788 int facing;
3789 int hp;
3790
3791 if (unpack(sc, &args, "pdd", &type, &facing, &hp)) {
3792 load_err("kern-mk-vehicle: bad args");
3793 return sc->NIL;
3794 }
3795
3796 if (!type) {
3797 load_err("kern-mk-vehicle-type: null type");
3798 return sc->NIL;
3799 }
3800
3801 vehicle = new Vehicle(type, facing, hp);
3802 assert(vehicle);
3803
3804 return scm_mk_ptr(sc, vehicle);
3805 }
3806
KERN_API_CALL(kern_obj_get_sprite)3807 KERN_API_CALL(kern_obj_get_sprite)
3808 {
3809 Object *obj = unpack_obj(sc, &args, "kern-obj-get-sprite");
3810 if (!obj)
3811 return sc->NIL;
3812
3813 return scm_mk_ptr(sc, obj->getSprite());
3814 }
3815
KERN_API_CALL(kern_obj_get_light)3816 KERN_API_CALL(kern_obj_get_light)
3817 {
3818 Object *obj = unpack_obj(sc, &args, "kern-obj-get-light");
3819 if (!obj)
3820 return sc->NIL;
3821
3822 return scm_mk_integer(sc, obj->getLight());
3823 }
3824
KERN_API_CALL(kern_obj_get_mmode)3825 KERN_API_CALL(kern_obj_get_mmode)
3826 {
3827 struct mmode *mmode;
3828
3829 Object *obj = unpack_obj(sc, &args, "kern-obj-get-mmode");
3830 if (!obj)
3831 return sc->NIL;
3832
3833 mmode = obj->getMovementMode();
3834 if (mmode)
3835 return scm_mk_ptr(sc, mmode);
3836 return sc->NIL;
3837 }
3838
KERN_API_CALL(kern_obj_get_movecost)3839 KERN_API_CALL(kern_obj_get_movecost)
3840 {
3841 class Object *obj;
3842 int val;
3843
3844 if (unpack(sc, &args, "pd", &obj, &val)) {
3845 rt_err("kern_obj_get_movecost: bad args");
3846 return sc->NIL;
3847 }
3848
3849 if (!obj) {
3850 rt_err("kern_obj_get_movecost: null object");
3851 return sc->NIL;
3852 }
3853
3854 val = obj->getMovementCost(val);
3855 return scm_mk_integer(sc,val);
3856 }
3857
KERN_API_CALL(kern_obj_get_name)3858 KERN_API_CALL(kern_obj_get_name)
3859 {
3860 Object *obj = unpack_obj(sc, &args, "kern-obj-get-name");
3861 if (!obj) {
3862 return sc->NIL;
3863 }
3864
3865 if (!obj->getName()) {
3866 return sc->NIL;
3867 }
3868
3869 return scm_mk_string(sc, obj->getName());
3870 }
3871
KERN_API_CALL(kern_obj_set_light)3872 KERN_API_CALL(kern_obj_set_light)
3873 {
3874 Object *obj;
3875 int light;
3876
3877 if (unpack(sc, &args, "pd", &obj, &light)) {
3878 rt_err("kern-obj-set-light: bad args");
3879 return sc->NIL;
3880 }
3881
3882 if (!obj) {
3883 rt_err("kern-obj-set-light: null obj");
3884 return sc->NIL;
3885 }
3886
3887 obj->setLight(light);
3888
3889 return sc->NIL;
3890 }
3891
KERN_API_CALL(kern_sleep)3892 KERN_API_CALL(kern_sleep)
3893 {
3894 int msecs;
3895
3896 if (unpack(sc, &args, "d", &msecs)) {
3897 rt_err("kern-sleep: bad args");
3898 return sc->F;
3899 }
3900 //usleep(MS_PER_TICK * msecs);
3901 SDL_Delay(msecs);
3902 return sc->T;
3903 }
3904
KERN_API_CALL(kern_map_view_create)3905 KERN_API_CALL(kern_map_view_create)
3906 {
3907 return scm_mk_ptr(sc, mapCreateView());
3908 }
3909
3910
KERN_API_CALL(kern_map_view_destroy)3911 KERN_API_CALL(kern_map_view_destroy)
3912 {
3913 struct mview *v = kern_unpack_mview(sc, &args,
3914 "kern-map-view-destroy");
3915 if (v)
3916 mapDestroyView(v);
3917 return sc->NIL;
3918 }
3919
KERN_API_CALL(kern_map_view_add)3920 KERN_API_CALL(kern_map_view_add)
3921 {
3922 struct mview *v = kern_unpack_mview(sc, &args, "kern-map-view-add");
3923 if (v)
3924 mapAddView(v);
3925 return sc->NIL;
3926 }
3927
KERN_API_CALL(kern_map_view_rm)3928 KERN_API_CALL(kern_map_view_rm)
3929 {
3930 struct mview *v = kern_unpack_mview(sc, &args, "kern-map-view-rm");
3931 if (v)
3932 mapRmView(v);
3933 return sc->NIL;
3934 }
3935
KERN_API_CALL(kern_map_view_center)3936 KERN_API_CALL(kern_map_view_center)
3937 {
3938 struct place *place;
3939 int x, y;
3940
3941 struct mview *v = kern_unpack_mview(sc, &args,
3942 "kern-map-view-center");
3943 if (!v)
3944 return sc->NIL;
3945
3946 if (! kern_unpack_loc(sc, &args, &place, &x, &y,
3947 "kern-map-view-center"))
3948 return sc->NIL;
3949
3950 mapSetPlace(place);
3951 mapCenterView(v, x, y);
3952
3953 return sc->NIL;
3954 }
3955
KERN_API_CALL(kern_map_center_camera)3956 KERN_API_CALL(kern_map_center_camera)
3957 {
3958 struct place *place;
3959 int x, y;
3960
3961 if (! kern_unpack_loc(sc, &args, &place, &x, &y,
3962 "kern-map-view-center"))
3963 return sc->NIL;
3964
3965 mapCenterCamera(x, y);
3966
3967 return sc->NIL;
3968 }
3969
KERN_API_CALL(kern_map_repaint)3970 KERN_API_CALL(kern_map_repaint)
3971 {
3972 mapUpdate(0);
3973 return sc->NIL;
3974 }
3975
KERN_API_CALL(kern_map_flash)3976 KERN_API_CALL(kern_map_flash)
3977 {
3978 int msecs;
3979 if (unpack(sc, &args, "d", &msecs)) {
3980 rt_err("kern-map-flash: bad args");
3981 return sc->NIL;
3982 }
3983 mapFlash(msecs);
3984 return sc->NIL;
3985 }
3986
KERN_API_CALL(kern_sound_play)3987 KERN_API_CALL(kern_sound_play)
3988 {
3989 sound_t *sound;
3990 if (unpack(sc, &args, "p", &sound)) {
3991 rt_err("kern-sound-play: bad args");
3992 return sc->NIL;
3993 }
3994 sound_play(sound, SOUND_MAX_VOLUME);
3995 return sc->NIL;
3996 }
3997
3998 //refactor refactor refactor!
KERN_API_CALL(kern_sound_play_at)3999 KERN_API_CALL(kern_sound_play_at)
4000 {
4001 sound_t *sound;
4002 struct place *place, *foc_place;
4003 int x, foc_x;
4004 int y, foc_y;
4005 if (unpack(sc, &args, "p", &sound))\
4006 {
4007 rt_err("kern-sound-play-at: bad args");
4008 return sc->NIL;
4009 }
4010 if (unpack_loc(sc, &args, &place, &x, &y, "kern-sound-play-at: bad loc"))
4011 {
4012 return sc->NIL;
4013 }
4014 int volume = SOUND_MAX_VOLUME;
4015 int distance;
4016 mapGetCameraFocus(&foc_place, &foc_x, &foc_y);
4017 if (foc_place == place)
4018 {
4019 distance = place_flying_distance(foc_place, foc_x, foc_y, x, y);
4020 if (distance > 1)
4021 volume = (volume * (20 - distance))/20;
4022 if (volume > 0)
4023 {
4024 sound_play(sound, volume, false);
4025 }
4026 }
4027 return sc->NIL;
4028 }
4029
KERN_API_CALL(kern_sound_play_ambient)4030 KERN_API_CALL(kern_sound_play_ambient)
4031 {
4032 sound_t *sound;
4033 struct place *place, *foc_place;
4034 int x, foc_x;
4035 int y, foc_y;
4036 if (unpack(sc, &args, "p", &sound))
4037 {
4038 rt_err("kern-sound-play-ambient: bad args");
4039 return sc->NIL;
4040 }
4041 if (unpack_loc(sc, &args, &place, &x, &y, "kern-sound-play-ambient: bad loc"))
4042 {
4043 return sc->NIL;
4044 }
4045 int volume = SOUND_MAX_VOLUME;
4046 int distance;
4047 mapGetCameraFocus(&foc_place, &foc_x, &foc_y);
4048 if (foc_place == place)
4049 {
4050 distance = place_flying_distance(foc_place, foc_x, foc_y, x, y);
4051 if (distance > 1)
4052 volume = (volume * (20 - distance))/20;
4053 if (volume > 0)
4054 {
4055 sound_play(sound, volume, true);
4056 }
4057 }
4058 return sc->NIL;
4059 }
4060
KERN_API_CALL(kern_music_play)4061 KERN_API_CALL(kern_music_play)
4062 {
4063 char *file;
4064 if (unpack(sc, &args, "s", &file))
4065 {
4066 rt_err("kern-music-play: bad args");
4067 return sc->NIL;
4068 }
4069 music_load_track(file);
4070 return sc->NIL;
4071 }
4072
KERN_API_CALL(kern_set_spell_words)4073 KERN_API_CALL(kern_set_spell_words)
4074 {
4075 int i = 0;
4076 pointer words;
4077 pointer word;
4078
4079 words = args;
4080
4081 for (i = 0; i < MAX_SPELL_WORDS; i++) {
4082
4083 /* check for end-of-list */
4084 if (! scm_is_pair(sc, words))
4085 break;
4086
4087 word = scm_car(sc, words);
4088
4089 /* type-check */
4090 if (! scm_is_str(sc, word)) {
4091 load_err("kern-set-spell-words: entry %i not a string",
4092 i);
4093 break;
4094 }
4095
4096 /* copy the word into the global list of words */
4097 if (magic_add_word(&Session->magic, scm_str_val(sc, word))) {
4098 load_err("kern-set-spell-words: error adding '%s'",
4099 scm_str_val(sc, word));
4100 }
4101
4102 words = scm_cdr(sc, words);
4103 }
4104
4105 return sc->NIL;
4106 }
4107
KERN_API_CALL(kern_mk_skill)4108 KERN_API_CALL(kern_mk_skill)
4109 {
4110 char *name, *desc;
4111 pointer yuse, can_yuse, list;
4112 struct skill *skill;
4113 int wilderness_ok, passive;
4114
4115 /* Unpack name and desc */
4116 if (unpack(sc, &args, "ss", &name, &desc)) {
4117 load_err("kern-mk-skill: bad args");
4118 return sc->NIL;
4119 }
4120
4121 skill = skill_new();
4122 skill_set_name(skill, name);
4123 skill_set_desc(skill, desc);
4124
4125 /* Unpack ap, mp and yusage procs */
4126 if (unpack(sc, &args, "ddbbcc",
4127 &skill->ap,
4128 &skill->mp,
4129 &wilderness_ok,
4130 &passive,
4131 &yuse, &can_yuse)) {
4132 load_err("kern-mk-skill %s: bad args", name);
4133 goto abort;
4134 }
4135
4136 /* I used an int for the unpack since I don't trust the cast to work
4137 * portably on structure bit fields */
4138 skill->wilderness_ok = wilderness_ok;
4139 skill->passive = passive;
4140
4141 /* yuse is mandatory for non-passive skills */
4142 if (! skill->passive
4143 && yuse == sc->NIL) {
4144 load_err("kern-mk-skill %s: active but nil yuse proc", name);
4145 goto abort;
4146 }
4147
4148 if (yuse != sc->NIL) {
4149 skill->yuse = closure_new_ref(sc, yuse);
4150 }
4151
4152 /* can_yuse is optional */
4153 if (can_yuse != sc->NIL) {
4154 skill->can_yuse = closure_new_ref(sc, can_yuse);
4155 }
4156
4157 /* list of tools */
4158 list = scm_car(sc, args);
4159 args = scm_cdr(sc, args);
4160 while (scm_is_pair(sc, list)) {
4161 void *objtype;
4162 if (unpack(sc, &list, "p", &objtype)) {
4163 load_err("kern-mk-skill %s: bad tool arg", name);
4164 goto abort;
4165 }
4166 skill_add_tool(skill, objtype);
4167 }
4168
4169 /* list of materials: (objtype, int) pairs */
4170 list = scm_car(sc, args);
4171 args = scm_cdr(sc, args);
4172 while (scm_is_pair(sc, list)) {
4173 void *objtype;
4174 int quan;
4175 pointer pair = scm_car(sc, list);
4176 list = scm_cdr(sc, list);
4177 if (unpack(sc, &pair, "pd", &objtype, &quan)) {
4178 load_err("kern-mk-skill %s: bad material arg", name);
4179 goto abort;
4180 }
4181 skill_add_material(skill, objtype, quan);
4182 }
4183
4184 list_add(&Session->skills, &skill->list);
4185 return scm_mk_ptr(sc, skill);
4186
4187 abort:
4188 skill_unref(skill);
4189 return sc->NIL;
4190 }
4191
KERN_API_CALL(kern_mk_skill_set)4192 KERN_API_CALL(kern_mk_skill_set)
4193 {
4194 char *name;
4195 struct skill_set *skset;
4196 pointer list;
4197
4198 if (unpack(sc, &args, "s", &name)) {
4199 load_err("kern-mk-skill-set: bad name");
4200 return sc->NIL;
4201 }
4202
4203 skset = skill_set_new();
4204 skill_set_set_name(skset, name);
4205
4206 list = scm_car(sc, args);
4207 args = scm_cdr(sc, args);
4208 while (scm_is_pair(sc, list)) {
4209 pointer pair;
4210 int lvl;
4211 struct skill *skill;
4212
4213 pair = scm_car(sc, list);
4214 list = scm_cdr(sc, list);
4215 if (unpack(sc, &pair, "dp", &lvl, &skill)) {
4216 load_err("kern-mk-skill-set %s: bad skill list args",
4217 name);
4218 goto abort;
4219 }
4220
4221 if (!skill) {
4222 load_err("kern-mk-skill-set %s: nil skill", name);
4223 goto abort;
4224 }
4225
4226 skill_set_add_skill(skset, skill, lvl);
4227 }
4228
4229 list_add(&Session->skill_sets, &skset->list);
4230 return scm_mk_ptr(sc, skset);
4231
4232 abort:
4233 skill_set_unref(skset);
4234 return sc->NIL;
4235 }
4236
KERN_API_CALL(kern_add_spell)4237 KERN_API_CALL(kern_add_spell)
4238 {
4239 char *code;
4240 ObjectType *type;
4241 struct spell *spell;
4242 pointer reagents;
4243
4244 /* Unpack just as far as the word until we can verify that we can add
4245 * this spell. */
4246 if (unpack(sc, &args, "ps", &type, &code)) {
4247 load_err("kern-add-spell: bad args");
4248 return sc->NIL;
4249 }
4250
4251 if (!(spell = magic_add_spell(&Session->magic, code))) {
4252 load_err("kern-add-spell: failed to add %s",
4253 type->getName());
4254 return sc->NIL;
4255 }
4256
4257 spell->type = type;
4258
4259 /* NOTE: unlike other kernel data structures/objects, if we fail we
4260 * don't have to deallocate the spell structure. Nor do we need to
4261 * explicitly add it to the session for teardown later. After
4262 * magic_add_spell() returns the spell structure has already been added
4263 * to the spell tree associated with the session, and will be
4264 * automatically deallocated at end-of-session. */
4265
4266 /* unpack remaining fields (other than the reagent list) directly into
4267 * the spell structure. */
4268 if (unpack(sc, &args, "ddddp", &spell->level, &spell->cost,
4269 &spell->context, &spell->action_points, &spell->sprite)) {
4270 load_err("kern-add-spell: bad args");
4271 return sc->NIL;
4272 }
4273
4274 reagents = scm_car(sc, args);
4275 args = scm_cdr(sc, args);
4276
4277 while (scm_is_pair(sc, reagents)) {
4278 ObjectType *reagent_type;
4279 if (unpack(sc, &reagents, "p", &reagent_type)) {
4280 load_err("kern-add-spell %s: bad arg in reagent list",
4281 spell->type->getName());
4282 return sc->NIL;
4283 }
4284 if (spell_add_reagent(spell, reagent_type)) {
4285 load_err("kern-add-spell: failed to add reagent %s "\
4286 "to mixture for spell %s",
4287 reagent_type->getName(),
4288 spell->type->getName());
4289 return sc->NIL;
4290 }
4291
4292 }
4293
4294 return sc->NIL;
4295 }
4296
KERN_API_CALL(kern_init_random)4297 KERN_API_CALL(kern_init_random)
4298 {
4299 /* This should have some timing randomness,
4300 since human interaction is required before scripts run */
4301
4302 srand(clock());
4303 return sc->NIL;
4304 }
4305
KERN_API_CALL(kern_dice_roll)4306 KERN_API_CALL(kern_dice_roll)
4307 {
4308 static char *dice;
4309
4310 if (unpack(sc, &args, "s", &dice)) {
4311 rt_err("kern-dice-roll: bad args");
4312 return scm_mk_integer(sc, 0);
4313 }
4314
4315 if (!dice_valid(dice)) {
4316 rt_err("kern-dice-roll: bad dice '%s'", dice);
4317 return scm_mk_integer(sc, 0);
4318 }
4319
4320 return scm_mk_integer(sc, dice_roll(dice));
4321 }
4322
KERN_API_CALL(kern_char_set_sleep)4323 KERN_API_CALL(kern_char_set_sleep)
4324 {
4325 class Character *ch;
4326 int val;
4327
4328 ch = (class Character*)unpack_obj(sc, &args, "kern-char-set-sleep");
4329 if (!ch)
4330 return sc->F;
4331
4332 if (unpack(sc, &args, "b", &val)) {
4333 rt_err("kern-char-set-sleep: bad args");
4334 return sc->F;
4335 }
4336
4337 if (val)
4338 ch->sleep();
4339 else
4340 ch->awaken();
4341
4342 return sc->T;
4343 }
4344
KERN_API_CALL(kern_char_force_drop)4345 KERN_API_CALL(kern_char_force_drop)
4346 {
4347 class Character *ch;
4348 int val;
4349
4350 ch = (class Character*)unpack_obj(sc, &args, "kern-char-force-drop");
4351 if (!ch)
4352 return sc->NIL;
4353
4354 if (unpack(sc, &args, "b", &val)) {
4355 rt_err("kern-char-force-drop: bad args");
4356 goto done;
4357 }
4358
4359 ch->setForceContainerDrop(val);
4360 done:
4361 return scm_mk_ptr(sc, ch);
4362 }
4363
KERN_API_CALL(kern_char_unready)4364 KERN_API_CALL(kern_char_unready)
4365 {
4366 class Character *ch;
4367 class ArmsType *type;
4368
4369 ch = (class Character*)unpack_obj(sc, &args, "kern-char-unready");
4370 if (!ch)
4371 return sc->F;
4372
4373 if (unpack(sc, &args, "p", &type)) {
4374 rt_err("kern-char-unready: bad args");
4375 return sc->F;
4376 }
4377
4378 return ch->unready(type) ? sc->T : sc->F;
4379 }
4380
KERN_API_CALL(kern_char_get_readied_weapons)4381 KERN_API_CALL(kern_char_get_readied_weapons)
4382 {
4383 class Character *ch;
4384 class ArmsType *weapon;
4385 pointer head = sc->NIL;
4386 pointer tail = sc->NIL;
4387
4388 ch = (class Character*)unpack_obj(sc, &args, "kern-char-unready");
4389 if (!ch)
4390 return sc->F;
4391
4392 int armsIndex = 0;
4393 for (weapon = ch->enumerateWeapons(&armsIndex); weapon != NULL;
4394 weapon = ch->getNextWeapon(&armsIndex)) {
4395
4396 /* skip "natural" weapons that are not really readied */
4397 if (ch->species &&
4398 weapon == ch->species->weapon)
4399 continue;
4400
4401 pointer cell = scm_mk_ptr(sc, weapon);
4402 cell = _cons(sc, cell, sc->NIL, 0);
4403
4404 if (head == sc->NIL) {
4405 head = cell;
4406 tail = cell;
4407 } else {
4408 tail->_object._cons._cdr = cell;
4409 tail = cell;
4410 }
4411 }
4412
4413 return head;
4414 }
4415
KERN_API_CALL(kern_char_set_hp)4416 KERN_API_CALL(kern_char_set_hp)
4417 {
4418 class Character *ch;
4419 int val;
4420
4421 ch = (class Character*)unpack_obj(sc, &args, "kern-char-set-hp");
4422 if (!ch)
4423 return sc->NIL;
4424
4425 if (unpack(sc, &args, "d", &val)) {
4426 rt_err("kern-char-set-hp: bad args");
4427 } else {
4428 ch->setHp(val);
4429 }
4430
4431 return scm_mk_ptr(sc, ch);;
4432 }
4433
KERN_API_CALL(kern_char_set_mana)4434 KERN_API_CALL(kern_char_set_mana)
4435 {
4436 class Character *ch;
4437 int val;
4438
4439 ch = (class Character*)unpack_obj(sc, &args, "kern-char-set-mana");
4440 if (!ch)
4441 return sc->NIL;
4442
4443 if (unpack(sc, &args, "d", &val)) {
4444 rt_err("kern-char-set-mana: bad args");
4445 } else {
4446 ch->setMana(val);
4447 }
4448
4449 return scm_mk_ptr(sc, ch);;
4450 }
4451
KERN_API_CALL(kern_char_set_schedule)4452 KERN_API_CALL(kern_char_set_schedule)
4453 {
4454 class Character *ch;
4455 struct sched *val;
4456
4457 ch = (class Character*)unpack_obj(sc, &args, "kern-char-set-schedule");
4458 if (!ch)
4459 return sc->NIL;
4460
4461 if (unpack(sc, &args, "p", &val)) {
4462 rt_err("kern-char-set-schedule: bad args");
4463 } else {
4464 ch->setSchedule(val);
4465 }
4466
4467 return scm_mk_ptr(sc, ch);
4468 }
4469
4470 /*
4471 * kern_char_join_player -- wrapper for Character::joinPlayer
4472 */
KERN_API_CALL(kern_char_join_player)4473 KERN_API_CALL(kern_char_join_player)
4474 {
4475 class Character *ch;
4476
4477 ch = (class Character*)unpack_obj(sc, &args, "kern-char-join-player");
4478 if (!ch)
4479 return sc->F;
4480
4481 if (ch->joinPlayer())
4482 return sc->T;
4483 return sc->F;
4484 }
4485
KERN_API_CALL(kern_char_is_known)4486 KERN_API_CALL(kern_char_is_known)
4487 {
4488 class Character *ch;
4489
4490 ch = (class Character*)unpack_obj(sc, &args, "kern-char-is-known");
4491 if (!ch) {
4492 return sc->F;
4493 }
4494
4495 return ch->isKnown() ? sc->T : sc->F;
4496 }
4497
KERN_API_CALL(kern_char_leave_player)4498 KERN_API_CALL(kern_char_leave_player)
4499 {
4500 class Character *ch;
4501
4502 ch = (class Character*)unpack_obj(sc, &args, "kern-char-leave-player");
4503 if (!ch)
4504 return sc->F;
4505
4506 if (NULL==ch->getPlace()
4507 || place_is_wilderness(ch->getPlace()))
4508 return sc->F;
4509
4510 ch->leavePlayer();
4511
4512 return sc->T;
4513 }
4514
4515 /*
4516 * kern_char_set_ai -- change the AI for a Character object
4517 */
KERN_API_CALL(kern_char_set_ai)4518 KERN_API_CALL(kern_char_set_ai)
4519 {
4520 class Character *ch;
4521 pointer ai;
4522
4523 ch = (class Character*)unpack_obj(sc, &args, "kern-char-set-ai");
4524 if (!ch)
4525 return sc->F;
4526
4527 if (unpack(sc, &args, "c", &ai)) {
4528 rt_err("kern-char-set-ai: bad args");
4529 return sc->F;
4530 }
4531
4532 if (ai == sc->NIL) {
4533 ch->setAI(NULL);
4534 } else {
4535 ch->setAI(closure_new(sc, ai));
4536 }
4537
4538 return sc->T;
4539 }
4540
KERN_API_CALL(kern_char_task_abort)4541 KERN_API_CALL(kern_char_task_abort)
4542 {
4543 class Character *ch;
4544
4545 ch = (class Character*)unpack_obj(sc, &args, "kern-char-task-abort");
4546 if (ch) {
4547 ch->taskAbort();
4548 }
4549 return sc->NIL;
4550 }
4551
KERN_API_CALL(kern_char_task_begin)4552 KERN_API_CALL(kern_char_task_begin)
4553 {
4554 char *taskname = NULL;
4555 class Character *ch;
4556 pointer taskproc, taskgob;
4557 struct closure *closure = NULL;
4558 struct gob *gob = NULL;
4559
4560 ch = (class Character*)unpack_obj(sc, &args, "kern-char-task-begin");
4561 if (!ch) {
4562 return sc->F;
4563 }
4564
4565 if (unpack(sc, &args, "scl", &taskname, &taskproc, &taskgob)) {
4566 rt_err("%s: bad args", __FUNCTION__);
4567 return sc->F;
4568 }
4569
4570 if (taskproc == sc->NIL) {
4571 rt_err("%s: nil task procedure not allowed", __FUNCTION__);
4572 return sc->F;
4573 }
4574
4575 /* For now, disallow starting tasks in the wilderness. Maybe later. */
4576 if (place_is_wilderness(ch->getPlace())) {
4577 return sc->F;
4578 }
4579
4580 if (!(closure = closure_new_ref(sc, taskproc))) {
4581 return sc->F;
4582 }
4583
4584 /* gob is optional */
4585 if (taskgob != sc->NIL) {
4586 if (!(gob = gob_new(sc, taskgob))) {
4587 closure_unref(closure);
4588 return sc->F;
4589 }
4590 }
4591
4592 ch->taskBegin(taskname, closure, gob);
4593 closure_unref(closure);
4594
4595 return sc->T;
4596 }
4597
KERN_API_CALL(kern_char_task_continue)4598 KERN_API_CALL(kern_char_task_continue)
4599 {
4600 char *taskname = NULL;
4601 class Character *ch;
4602 pointer taskproc, taskgob;
4603 struct closure *closure = NULL;
4604 struct gob *gob = NULL;
4605
4606 ch = (class Character*)unpack_obj(sc, &args, "kern-char-task-continue");
4607 if (!ch) {
4608 return sc->F;
4609 }
4610
4611 if (unpack(sc, &args, "scl", &taskname, &taskproc, &taskgob)) {
4612 rt_err("%s: bad args", __FUNCTION__);
4613 return sc->F;
4614 }
4615
4616 if (taskproc == sc->NIL) {
4617 return sc->F;
4618 }
4619
4620 if (!(closure = closure_new_ref(sc, taskproc))) {
4621 return sc->F;
4622 }
4623
4624 /* gob is optional */
4625 if (taskgob != sc->NIL) {
4626 if (!(gob = gob_new(sc, taskgob))) {
4627 closure_unref(closure);
4628 return sc->F;
4629 }
4630 }
4631
4632 ch->taskContinue(taskname, closure, gob);
4633 closure_unref(closure);
4634
4635 return sc->T;
4636 }
4637
KERN_API_CALL(kern_char_task_end)4638 KERN_API_CALL(kern_char_task_end)
4639 {
4640 class Character *ch;
4641
4642 ch = (class Character*)unpack_obj(sc, &args, "kern-char-task-end");
4643 if (ch) {
4644 ch->taskEnd();
4645 }
4646 return sc->NIL;
4647 }
4648
4649
KERN_API_CALL(kern_char_set_sched)4650 KERN_API_CALL(kern_char_set_sched)
4651 {
4652 class Character *ch;
4653 struct sched *sched = 0;
4654
4655 if (unpack(sc, &args, "pp", &ch, &sched)) {
4656 rt_err("kern-char-set-sched: bad args");
4657 return sc->NIL;
4658 }
4659
4660 if (!ch) {
4661 rt_err("kern-char-set-sched: null object");
4662 return sc->NIL;
4663 }
4664
4665 ch->setSchedule(sched);
4666
4667 return sc->T;
4668 }
4669
KERN_API_CALL(kern_char_set_control_mode)4670 KERN_API_CALL(kern_char_set_control_mode)
4671 {
4672 static struct { const char *str; enum control_mode mode; } tbl[] = {
4673 { "auto", CONTROL_MODE_AUTO },
4674 { "player", CONTROL_MODE_PLAYER },
4675 { "idle", CONTROL_MODE_IDLE },
4676 { "follow", CONTROL_MODE_FOLLOW }
4677 };
4678 class Character *ch;
4679 char *modestr = 0;
4680 int i;
4681
4682
4683 ch = (class Character*)unpack_obj(sc, &args, "kern-char-set-control-mode");
4684 if (!ch)
4685 return sc->NIL;
4686
4687 if (unpack(sc, &args, "s", &modestr)) {
4688 rt_err("kern-char-set-control-mode: bad args");
4689 return sc->NIL;
4690 }
4691
4692 for (i = 0; i < array_sz(tbl); i++) {
4693 if (! strcmp(tbl[i].str, modestr)) {
4694 ch->setControlMode(tbl[i].mode);
4695 return sc->NIL;
4696 }
4697 }
4698
4699 return sc->NIL;
4700 }
4701
KERN_API_CALL(kern_char_attack)4702 KERN_API_CALL(kern_char_attack)
4703 {
4704 class Character *attacker, *defender;
4705 class ArmsType *weapon;
4706
4707 if (unpack(sc, &args, "ppp", &attacker, &weapon, &defender)) {
4708 rt_err("kern-char-attack: bad args");
4709 return sc->F;
4710 }
4711
4712 if (! attacker) {
4713 rt_err("kern-char-attack: null attacker");
4714 return sc->F;
4715 }
4716
4717 if (! weapon) {
4718 rt_err("kern-char-attack: null weapon");
4719 return sc->F;
4720 }
4721
4722 if (! defender) {
4723 rt_err("kern-char-attack: null defender");
4724 return sc->F;
4725 }
4726
4727 ctrl_do_attack(attacker, weapon, defender,
4728 attacker->getToHitPenalty());
4729
4730 attacker->decActionPoints(weapon->getRequiredActionPoints());
4731
4732 return sc->T;
4733 }
4734
KERN_API_CALL(kern_char_is_asleep)4735 KERN_API_CALL(kern_char_is_asleep)
4736 {
4737 class Character *ch;
4738
4739 ch = (class Character*)unpack_obj(sc, &args, "kern-char-is-asleep");
4740 if (!ch)
4741 return sc->F;
4742
4743 return ch->isAsleep() ? sc->T : sc->F;
4744 }
4745
KERN_API_CALL(kern_char_is_dead)4746 KERN_API_CALL(kern_char_is_dead)
4747 {
4748 class Character *ch;
4749
4750 ch = (class Character*)unpack_obj(sc, &args, "kern-char-is-dead");
4751 if (!ch)
4752 return sc->T;
4753
4754 return ch->isDead() ? sc->T : sc->F;
4755 }
4756
KERN_API_CALL(kern_mk_effect)4757 KERN_API_CALL(kern_mk_effect)
4758 {
4759 struct effect *effect;
4760 pointer exec_proc = sc->NIL;
4761 pointer apply_proc = sc->NIL;
4762 pointer rm_proc = sc->NIL;
4763 pointer restart_proc = sc->NIL;
4764 void *sprite;
4765 pointer ret;
4766 char *name, *tag = 0;
4767 int hook_id;
4768
4769 if (unpack(sc, &args, "yspccccd", &tag, &name, &sprite, &exec_proc,
4770 &apply_proc, &rm_proc, &restart_proc, &hook_id)) {
4771 load_err("kern-mk-effect %s: bad args", tag);
4772 return sc->NIL;
4773 }
4774
4775 if (exec_proc == sc->NIL)
4776 exec_proc = NULL;
4777
4778 if (apply_proc == sc->NIL)
4779 apply_proc = NULL;
4780
4781 if (rm_proc == sc->NIL)
4782 rm_proc = NULL;
4783
4784 if (restart_proc == sc->NIL)
4785 restart_proc = NULL;
4786
4787 effect = effect_new(tag, sc, exec_proc, apply_proc, rm_proc,
4788 restart_proc, name);
4789
4790 effect->hook_id = hook_id;
4791 effect->sprite = (struct sprite*)sprite;
4792
4793 if (unpack(sc, &args, "dbd", &effect->detect_dc,
4794 &effect->cumulative, &effect->duration)) {
4795 load_err("kern-mk-effect %s: bad args", tag);
4796 goto abort;
4797 }
4798
4799 session_add(Session, effect, effect_dtor, NULL, NULL);
4800 ret = scm_mk_ptr(sc, effect);
4801 scm_define(sc, tag, ret);
4802
4803 return ret;
4804
4805 abort:
4806 effect_del(effect);
4807 return sc->NIL;
4808 }
4809
4810 /* kern_ui_target_visitor - build a suggested list of targets from all beings
4811 * in range. */
kern_ui_target_visitor(class Object * obj,void * data)4812 static void kern_ui_target_visitor(class Object *obj, void *data)
4813 {
4814 struct kern_ui_target_info *info = (struct kern_ui_target_info*)data;
4815 class Character *npc = 0;
4816 int dist = 0;
4817 struct location_list *entry = 0;
4818
4819 if (being_layer!=obj->getLayer())
4820 return;
4821
4822 npc = (class Character*)obj;
4823
4824 if (! npc->isVisible() && ! Reveal)
4825 return;
4826
4827 dist = place_flying_distance(info->place,
4828 info->x,
4829 info->y,
4830 obj->getX(),
4831 obj->getY());
4832 if (dist > info->range)
4833 return;
4834
4835 /* Add it to the list */
4836 entry = (struct location_list*)malloc(sizeof(*entry));
4837 assert(entry);
4838 entry->x = obj->getX();
4839 entry->y = obj->getY();
4840 list_add_tail(&info->suggest, &entry->list);
4841 }
4842
4843 /* kern_ui_target_cleanup_info - free the suggest list. */
kern_ui_target_cleanup_info(struct kern_ui_target_info * info)4844 static void kern_ui_target_cleanup_info(struct kern_ui_target_info *info)
4845 {
4846 struct list *head = &info->suggest;
4847 struct list *entry = head->next;
4848 while (entry != head) {
4849 struct location_list *tmp =
4850 (struct location_list*)entry;
4851 entry = entry->next;
4852 list_remove(&tmp->list);
4853 free(tmp);
4854 }
4855 }
4856
KERN_API_CALL(kern_ui_target)4857 KERN_API_CALL(kern_ui_target)
4858 {
4859 struct place *place;
4860 int ox, oy, tx, ty, range;
4861 struct kern_ui_target_info info;
4862 pointer ret;
4863
4864 /* Unpack the origin */
4865 if (unpack_loc(sc, &args, &place, &ox, &oy, "kern-ui-target")) {
4866 return sc->NIL;
4867 }
4868
4869 /* Unpack the range */
4870 if (unpack(sc, &args, "d", &range)) {
4871 rt_err("kern-ui-target: bad range arg");
4872 return sc->NIL;
4873 }
4874
4875 /* Build a list of suggested targets. */
4876 memset(&info, 0, sizeof(info));
4877 info.place = Place;
4878 info.x = ox;
4879 info.y = oy;
4880 info.range = range;
4881 list_init(&info.suggest);
4882 place_for_each_object(Place,
4883 kern_ui_target_visitor,
4884 &info);
4885
4886
4887 /* Get the target coords from the user */
4888 tx = ox;
4889 ty = oy;
4890 if (select_target(ox, oy, &tx, &ty, range, &info.suggest)) {
4891 ret = sc->NIL;
4892 }
4893
4894 /* Pack the target coords for return */
4895 else {
4896 ret = pack(sc, "pdd", place, tx, ty);
4897 }
4898
4899 kern_ui_target_cleanup_info(&info);
4900 return ret;
4901 }
4902
kern_mk_templ_visitor(struct templ * templ,int x,int y,void * data)4903 static int kern_mk_templ_visitor(struct templ *templ, int x, int y, void *data)
4904 {
4905 closure_t *check = (closure_t*)data;
4906
4907 /* if the check proc returns #f then turn off this location in the
4908 * template */
4909 if (! closure_exec(check, "dd", x, y)) {
4910 templ_set(templ, x, y, 0);
4911 }
4912
4913 return 0;
4914 }
4915
KERN_API_CALL(kern_mk_templ)4916 KERN_API_CALL(kern_mk_templ)
4917 {
4918 int rad, x, y;
4919 struct place *place;
4920 pointer checkptr;
4921 struct templ *templ;
4922 closure_t *checkproc;
4923
4924 /* origin */
4925 if (unpack_loc(sc, &args, &place, &x, &y, "kern-mk-templ")) {
4926 return sc->NIL;
4927 }
4928
4929 /* radius, check-proc and gob */
4930 if (unpack(sc, &args, "dc", &rad, &checkptr)) {
4931 rt_err("kern-mk-templ: bad args");
4932 return sc->NIL;
4933 }
4934
4935 /* create the templ and set its origin */
4936 templ = templ_new_from_range(rad);
4937 templ_set_origin(templ, x, y);
4938
4939 /* run the check procedure on each location covered by the templ */
4940 checkproc = closure_new_ref(sc, checkptr);
4941 templ_for_each(templ, kern_mk_templ_visitor, checkproc);
4942 closure_unref(checkproc);
4943
4944 return scm_mk_ptr(sc, templ);
4945 }
4946
KERN_API_CALL(kern_ui_target_generic)4947 KERN_API_CALL(kern_ui_target_generic)
4948 {
4949 ui_select_target_req_t req;
4950 pointer move_cb, select_cb, gob, dummy;
4951
4952 ui_select_target_req_init(&req);
4953
4954 /* Unpack the origin */
4955 if (unpack_loc(sc, &args, &req.place, &req.x1, &req.y1,
4956 "kern-ui-target-generic")) {
4957 return sc->NIL;
4958 }
4959
4960 /* Unpack the initial cursor loc */
4961 if (unpack_loc(sc, &args, &req.place, &req.x2, &req.y2,
4962 "kern-ui-target-generic")) {
4963 return sc->NIL;
4964 }
4965
4966 /* Unpack the template */
4967 if (unpack(sc, &args, "p", &req.tiles)) {
4968 rt_err("kern-ui-target-generic: bad template arg");
4969 return sc->NIL;
4970 }
4971
4972 /* fixme: unpack the suggested list */
4973 if (unpack(sc, &args, "p", &dummy)) {
4974 rt_err("kern-ui-target-generic: bad template arg");
4975 return sc->NIL;
4976 }
4977
4978 /* unpack the move-cb, select-cb and gob */
4979 if (unpack(sc, &args, "ccc", &move_cb, &select_cb, &gob)) {
4980 rt_err("kern-ui-target-generic: bad callback or gob arg");
4981 return sc->NIL;
4982 }
4983
4984 /* fixme: convert the cb procs into closures (will have to clean them
4985 * up at the bottom, too) */
4986
4987 /* Prompt the player; returns when player has made selection */
4988 if (ui_select_target_generic(&req)) {
4989 return sc->NIL;
4990 }
4991
4992 /* Kind of a hack: manually unref the templ here, assuming the caller
4993 * is done with it, which is going to be the usual case. If I encounter
4994 * an unusual case then I'll need to add kern-templ-ref/unref so the
4995 * script can protect it. */
4996 if (req.tiles) {
4997 templ_unref(req.tiles);
4998 }
4999
5000 /* Pack the target coords for return */
5001 return pack(sc, "pdd", req.place, req.x2, req.y2);
5002 }
5003
KERN_API_CALL(kern_fire_missile)5004 KERN_API_CALL(kern_fire_missile)
5005 {
5006 MissileType *missile_type;
5007 Missile *missile;
5008 struct place *oplace, *dplace;
5009 int ox, oy, dx, dy, hitTarget = 0;
5010
5011 /* Unpack the missile type */
5012 if (unpack(sc, &args, "p", &missile_type)) {
5013 rt_err("kern-fire-missile: bad missile type arg");
5014 return sc->NIL;
5015 }
5016 if (! missile_type) {
5017 rt_err("kern-fire-missile: null missile type");
5018 return sc->NIL;
5019 }
5020
5021 /* Unpack the origin */
5022 if (unpack_loc(sc, &args, &oplace, &ox, &oy, "kern-fire-missile"))
5023 return sc->NIL;
5024
5025 /* Unpack the destination */
5026 if (unpack_loc(sc, &args, &dplace, &dx, &dy, "kern-fire-missile"))
5027 return sc->NIL;
5028
5029 /* Create the missile */
5030 missile = new Missile(missile_type);
5031 assert(missile);
5032
5033 /* Fire the missile */
5034 missile->setPlace(dplace);
5035 missile->animate(ox, oy, &dx, &dy, 0, 0);
5036 hitTarget = missile->hitTarget();
5037 missile->fireHitLoc(NULL, NULL, oplace,dx,dy,-1);
5038 delete missile;
5039 return hitTarget ? sc->T : sc->F;
5040 }
5041
5042
KERN_API_CALL(kern_fire_missile_to_max)5043 KERN_API_CALL(kern_fire_missile_to_max)
5044 {
5045 MissileType *missile_type;
5046 Missile *missile;
5047 struct place *oplace, *dplace;
5048 int ox, oy, dx, dy, hitTarget = 0;
5049 int range;
5050
5051 /* Unpack the missile type */
5052 if (unpack(sc, &args, "pd", &missile_type, &range)) {
5053 rt_err("kern-fire-missile-to-max: bad missile type arg");
5054 return sc->NIL;
5055 }
5056 if (! missile_type) {
5057 rt_err("kern-fire-missile-to-max: null missile type");
5058 return sc->NIL;
5059 }
5060
5061 /* Unpack the origin */
5062 if (unpack_loc(sc, &args, &oplace, &ox, &oy, "kern-fire-missile-to-max"))
5063 return sc->NIL;
5064
5065 /* Unpack the destination */
5066 if (unpack_loc(sc, &args, &dplace, &dx, &dy, "kern-fire-missile-to-max"))
5067 return sc->NIL;
5068
5069 /* Create the missile */
5070 missile = new Missile(missile_type);
5071 assert(missile);
5072
5073 /* Fire the missile */
5074 missile->setPlace(dplace);
5075 missile->animate(ox, oy, &dx, &dy, 0, range);
5076 hitTarget = missile->hitTarget();
5077 missile->fireHitLoc(NULL, NULL, oplace,dx,dy,-1);
5078 delete missile;
5079 return hitTarget ? sc->T : sc->F;
5080 }
5081
KERN_API_CALL(kern_obj_inc_light)5082 KERN_API_CALL(kern_obj_inc_light)
5083 {
5084 int light;
5085
5086 Object *obj = unpack_obj(sc, &args, "kern-obj-inc-light");
5087 if (!obj)
5088 return sc->F;
5089
5090 if (unpack(sc, &args, "d", &light)) {
5091 rt_err("kern-obj-inc-light: bad args");
5092 return sc->F;
5093 }
5094
5095 obj->setLight(obj->getLight() + light);
5096
5097 return sc->T;
5098 }
5099
KERN_API_CALL(kern_obj_dec_light)5100 KERN_API_CALL(kern_obj_dec_light)
5101 {
5102 int light;
5103
5104 Object *obj = unpack_obj(sc, &args, "kern-obj-dec-light");
5105 if (!obj)
5106 return sc->F;
5107
5108 if (unpack(sc, &args, "d", &light)) {
5109 rt_err("kern-obj-dec-light: bad args");
5110 return sc->F;
5111 }
5112
5113 obj->setLight(obj->getLight() - light);
5114
5115 return sc->T;
5116 }
5117
KERN_API_CALL(kern_obj_dec_ap)5118 KERN_API_CALL(kern_obj_dec_ap)
5119 {
5120 int val;
5121
5122 Object *obj = unpack_obj(sc, &args, "kern-obj-add-ap");
5123 if (!obj)
5124 return sc->F;
5125
5126 if (unpack(sc, &args, "d", &val)) {
5127 rt_err("kern-obj-add-ap: bad args");
5128 return sc->F;
5129 }
5130
5131 obj->decActionPoints(val);
5132
5133 return sc->T;
5134 }
5135
KERN_API_CALL(kern_place_is_wilderness)5136 KERN_API_CALL(kern_place_is_wilderness)
5137 {
5138 struct place *place;
5139
5140 if (unpack(sc, &args, "p", &place)) {
5141 rt_err("kern-place-is-wilderness: bad args");
5142 return sc->F;
5143 }
5144
5145 if (!place) {
5146 rt_err("kern-place-is-wilderness: null place");
5147 return sc->F;
5148 }
5149
5150 return place_is_wilderness(place) ? sc->T : sc->F;
5151 }
5152
KERN_API_CALL(kern_place_is_wrapping)5153 KERN_API_CALL(kern_place_is_wrapping)
5154 {
5155 struct place *place;
5156
5157 if (unpack(sc, &args, "p", &place)) {
5158 rt_err("kern-place-is-wrapping: bad args");
5159 return sc->F;
5160 }
5161
5162 if (!place) {
5163 rt_err("kern-place-is-wrapping: null place");
5164 return sc->F;
5165 }
5166
5167 return place_is_wrapping(place) ? sc->T : sc->F;
5168 }
5169
KERN_API_CALL(kern_obj_heal)5170 KERN_API_CALL(kern_obj_heal)
5171 {
5172 Object *obj;
5173 int val;
5174
5175 obj = unpack_obj(sc, &args, "kern-obj-heal");
5176 if (!obj)
5177 return sc->NIL;
5178
5179 if (unpack(sc, &args, "d", &val)) {
5180 rt_err("kern-obj-heal: bad args");
5181 return sc->NIL;
5182 }
5183
5184 obj->heal(val);
5185
5186 return sc->T;
5187 }
5188
kern_filter_being(Object * obj,struct kern_append_info * info)5189 static int kern_filter_being(Object *obj, struct kern_append_info *info)
5190 {
5191 return (obj->getLayer() == being_layer);
5192 }
5193
kern_filter_visible_hostile(Object * obj,struct kern_append_info * info)5194 static int kern_filter_visible_hostile(Object *obj,
5195 struct kern_append_info *info)
5196 {
5197 class Being *subj;
5198
5199 /* Extract a pointer to the subject looking for hostiles */
5200 subj = (class Being *)info->data;
5201
5202 /* Filter out non-beings */
5203 if (obj->getLayer() != being_layer)
5204 return 0;
5205
5206 /* Filter out non-hostiles */
5207 if (! are_hostile(subj, (class Being*)obj))
5208 return 0;
5209
5210 /* Filter out objects not in los of the subject */
5211 if (! place_in_los(subj->getPlace(),subj->getX(),subj->getY(),
5212 obj->getPlace(),obj->getX(),obj->getY()))
5213 return 0;
5214
5215 /* Filter out object not in the vision radius of the subject */
5216 if (place_flying_distance(subj->getPlace(),subj->getX(),subj->getY(),
5217 obj->getX(),obj->getY())
5218 > subj->getVisionRadius())
5219 return 0;
5220
5221 /* Filter out invisible objects */
5222 if (! obj->isVisible())
5223 return 0;
5224
5225 return 1;
5226 }
5227
kern_filter_visible_allies(Object * obj,struct kern_append_info * info)5228 static int kern_filter_visible_allies(Object *obj,
5229 struct kern_append_info *info)
5230 {
5231 class Being *subj;
5232
5233 /* Extract a pointer to the subject looking for hostiles */
5234 subj = (class Being *)info->data;
5235
5236 /* Filter out non-beings */
5237 if (obj->getLayer() != being_layer)
5238 return 0;
5239
5240 /* Filter out non-allies */
5241 if (! are_allies(subj, (class Being*)obj))
5242 return 0;
5243
5244 /* Filter out objects not in los of the subject */
5245 if (! place_in_los(subj->getPlace(),subj->getX(),subj->getY(),
5246 obj->getPlace(),obj->getX(),obj->getY()))
5247 return 0;
5248
5249 /* Filter out object not in the vision radius of the subject */
5250 if (place_flying_distance(subj->getPlace(),subj->getX(),subj->getY(),
5251 obj->getX(),obj->getY())
5252 > subj->getVisionRadius())
5253 return 0;
5254
5255 /* Filter out invisible objects */
5256 if (! obj->isVisible())
5257 return 0;
5258
5259 return 1;
5260 }
5261
kern_append_object(Object * obj,void * data)5262 static void kern_append_object(Object *obj, void *data)
5263 {
5264 pointer cell;
5265 struct kern_append_info *info;
5266
5267 info = (struct kern_append_info *)data;
5268
5269 /* If there is a filter then use it */
5270 if (info->filter != NULL)
5271
5272 /* If the filter rejects the object then don't append it */
5273 if (! info->filter(obj, info))
5274 return;
5275
5276 cell = scm_mk_ptr(info->sc, obj);
5277 cell = _cons(info->sc, cell, info->sc->NIL, 0);
5278
5279 if (info->head == info->sc->NIL) {
5280 info->head = cell;
5281 info->tail = cell;
5282
5283 /* Protect the list from gc until we can return to scheme */
5284 scm_protect(info->sc, cell);
5285 } else {
5286 info->tail->_object._cons._cdr = cell;
5287 info->tail = cell;
5288 }
5289 }
5290
scm_mk_loc(scheme * sc,struct place * place,int x,int y)5291 static pointer scm_mk_loc(scheme *sc, struct place *place, int x, int y)
5292 {
5293 return pack(sc, "pdd", place, x, y);
5294 }
5295
5296 static pointer
kern_place_for_each_object_at(scheme * sc,struct place * place,int x,int y,int (* filter)(Object *,struct kern_append_info *),void * data)5297 kern_place_for_each_object_at(scheme *sc, struct place *place, int x, int y,
5298 int (*filter)(Object *,
5299 struct kern_append_info *),
5300 void *data)
5301 {
5302 struct kern_append_info info;
5303
5304 /* initialize the context used by the callback to append objects */
5305 info.sc = sc;
5306 info.head = sc->NIL;
5307 info.tail = sc->NIL;
5308 info.filter = filter;
5309 info.data = data;
5310
5311 /* build a scheme list of the objects at that location */
5312 place_for_each_object_at(place, x, y, kern_append_object, &info);
5313
5314 /* unprotect the list prior to return */
5315 if (info.head != sc->NIL)
5316 scm_unprotect(sc, info.head);
5317
5318 /* return the scheme list */
5319 return info.head;
5320
5321 }
5322
5323 static pointer
kern_place_for_each_object(scheme * sc,struct place * place,int (* filter)(Object *,struct kern_append_info *),void * data)5324 kern_place_for_each_object(scheme *sc, struct place *place,
5325 int (*filter)(Object *, struct kern_append_info *),
5326 void *data)
5327 {
5328 struct kern_append_info info;
5329
5330 /* initialize the context used by the callback to append objects */
5331 info.sc = sc;
5332 info.head = sc->NIL;
5333 info.tail = sc->NIL;
5334 info.filter = filter;
5335 info.data = data;
5336
5337 /* build a scheme list of the objects at that location */
5338 place_for_each_object(place, kern_append_object, &info);
5339
5340 /* unprotect the list prior to return */
5341 if (info.head != sc->NIL)
5342 scm_unprotect(sc, info.head);
5343
5344 /* return the scheme list */
5345 return info.head;
5346
5347 }
5348
5349
KERN_API_CALL(kern_get_objects_at)5350 KERN_API_CALL(kern_get_objects_at)
5351 {
5352 struct place *place;
5353 int x, y;
5354
5355 /* unpack the location */
5356 if (unpack_loc(sc, &args, &place, &x, &y, "kern-get-objects-at"))
5357 return sc->NIL;
5358
5359 /* get all objects with no filtering */
5360 return kern_place_for_each_object_at(sc, place, x, y, NULL, NULL);
5361 }
5362
KERN_API_CALL(kern_obj_is_char)5363 KERN_API_CALL(kern_obj_is_char)
5364 {
5365 /* OBSOLETE! Use kern-obj-is-being */
5366 Object *obj;
5367
5368 obj = unpack_obj(sc, &args, "kern-obj-is-char?");
5369 if (!obj)
5370 return sc->F;
5371
5372 return (obj->getLayer() == being_layer) ? sc->T : sc->F;
5373 }
5374
KERN_API_CALL(kern_obj_is_container)5375 KERN_API_CALL(kern_obj_is_container)
5376 {
5377 Object *obj;
5378
5379 obj = unpack_obj(sc, &args, "kern-obj-is-container?");
5380 if (!obj)
5381 return sc->F;
5382
5383 return (obj->getLayer() == container_layer) ? sc->T : sc->F;
5384 }
5385
KERN_API_CALL(kern_obj_is_field)5386 KERN_API_CALL(kern_obj_is_field)
5387 {
5388 Object *obj;
5389
5390 obj = unpack_obj(sc, &args, "kern-obj-is-field?");
5391 if (!obj)
5392 return sc->F;
5393
5394 return (obj->getLayer() == field_layer) ? sc->T : sc->F;
5395 }
5396
KERN_API_CALL(kern_obj_is_being)5397 KERN_API_CALL(kern_obj_is_being)
5398 {
5399 Object *obj;
5400
5401 obj = unpack_obj(sc, &args, "kern-obj-is-being?");
5402 if (!obj)
5403 return sc->F;
5404
5405 return (obj->getLayer() == being_layer) ? sc->T : sc->F;
5406 }
5407
KERN_API_CALL(kern_obj_is_mech)5408 KERN_API_CALL(kern_obj_is_mech)
5409 {
5410 Object *obj;
5411
5412 obj = unpack_obj(sc, &args, "kern-obj-is-mech?");
5413 if (!obj)
5414 return sc->F;
5415
5416 return (obj->getLayer() == mech_layer) ? sc->T : sc->F;
5417 }
5418
KERN_API_CALL(kern_obj_is_visible)5419 KERN_API_CALL(kern_obj_is_visible)
5420 {
5421 Object *obj;
5422
5423 obj = unpack_obj(sc, &args, "kern-obj-is-visible?");
5424 if (!obj)
5425 return sc->F;
5426
5427 return obj->isVisible() ? sc->T : sc->F;
5428 }
5429
KERN_API_CALL(kern_obj_is_submerged)5430 KERN_API_CALL(kern_obj_is_submerged)
5431 {
5432 Object *obj;
5433
5434 obj = unpack_obj(sc, &args, "kern-obj-is-submerged?");
5435 if (!obj)
5436 return sc->F;
5437
5438 return obj->isSubmerged() ? sc->T : sc->F;
5439 }
5440
KERN_API_CALL(kern_char_set_fleeing)5441 KERN_API_CALL(kern_char_set_fleeing)
5442 {
5443 int val;
5444 class Character *ch;
5445
5446 ch = (class Character*)unpack_obj(sc, &args, "kern-char-set-fleeing");
5447 if (!ch)
5448 return sc->NIL;
5449
5450 if (unpack(sc, &args, "b", &val)) {
5451 rt_err("kern-char-set-fleeing: bad args");
5452 return sc->NIL;
5453 }
5454
5455 ch->setFleeing(val);
5456
5457 return sc->NIL;
5458
5459 }
5460
KERN_API_CALL(kern_char_set_player_controlled)5461 KERN_API_CALL(kern_char_set_player_controlled)
5462 {
5463 int val;
5464 class Character *ch;
5465
5466 ch = (class Character*)unpack_obj(sc, &args, "kern-char-set-player-controlled");
5467 if (!ch)
5468 return sc->NIL;
5469
5470 if (unpack(sc, &args, "b", &val)) {
5471 rt_err("kern-char-set-player-controlled: bad args");
5472 return sc->NIL;
5473 }
5474
5475 ch->setPlayerControlled(val);
5476
5477 return sc->NIL;
5478
5479 }
5480
KERN_API_CALL(kern_char_get_species)5481 KERN_API_CALL(kern_char_get_species)
5482 {
5483 class Character *ch;
5484
5485 ch = (class Character*)unpack_obj(sc, &args, "kern-char-get-species");
5486 if (!ch)
5487 return sc->NIL;
5488
5489 return scm_mk_ptr(sc, ch->species);
5490 }
5491
KERN_API_CALL(kern_char_get_occ)5492 KERN_API_CALL(kern_char_get_occ)
5493 {
5494 class Character *ch;
5495
5496 ch = (class Character*)unpack_obj(sc, &args, "kern-char-get-occ");
5497 if (!ch || ! ch->occ)
5498 return sc->NIL;
5499
5500 return scm_mk_ptr(sc, ch->occ);
5501 }
5502
KERN_API_CALL(kern_char_get_mana)5503 KERN_API_CALL(kern_char_get_mana)
5504 {
5505 class Character *ch;
5506
5507 ch = (class Character*)unpack_obj(sc, &args, "kern-char-get-mana");
5508 if (!ch)
5509 return sc->NIL;
5510
5511 return scm_mk_integer(sc, ch->getMana());
5512 }
5513
KERN_API_CALL(kern_place_get_beings)5514 KERN_API_CALL(kern_place_get_beings)
5515 {
5516 struct place *place;
5517
5518 /* unpack the place */
5519 if (unpack(sc, &args, "p", &place)) {
5520 rt_err("kern-place-get-beings: bad args");
5521 return sc->NIL;
5522 }
5523 if (! place) {
5524 rt_err("kern-place-get-beings: null place");
5525 return sc->NIL;
5526 }
5527
5528 return kern_place_for_each_object(sc, place, kern_filter_being, NULL);
5529 }
5530
KERN_API_CALL(kern_being_get_visible_hostiles)5531 KERN_API_CALL(kern_being_get_visible_hostiles)
5532 {
5533 Object *subj;
5534
5535 /* Unpack the subject */
5536 subj = unpack_obj(sc, &args, "kern-place-get-visible-hostiles");
5537 if (!subj)
5538 return sc->NIL;
5539
5540 if (! subj->getPlace()) {
5541 rt_err("kern-place-get-visible-hostiles: null place");
5542 return sc->NIL;
5543 }
5544
5545 return kern_place_for_each_object(sc, subj->getPlace(),
5546 kern_filter_visible_hostile,
5547 subj);
5548 }
5549
KERN_API_CALL(kern_being_get_visible_allies)5550 KERN_API_CALL(kern_being_get_visible_allies)
5551 {
5552 Object *subj;
5553
5554 /* Unpack the subject */
5555 subj = unpack_obj(sc, &args, "kern-place-get-visible-allies");
5556 if (!subj)
5557 return sc->NIL;
5558
5559 if (! subj->getPlace()) {
5560 rt_err("kern-place-get-visible-allies: null place");
5561 return sc->NIL;
5562 }
5563
5564 return kern_place_for_each_object(sc, subj->getPlace(),
5565 kern_filter_visible_allies,
5566 subj);
5567 }
5568
KERN_API_CALL(kern_being_get_visible_tiles)5569 KERN_API_CALL(kern_being_get_visible_tiles)
5570 {
5571 Object *subj;
5572 struct place *place;
5573 int ox, oy, vr;
5574 pointer head = sc->NIL;
5575 pointer tail = sc->NIL;
5576 pointer cell;
5577
5578 /* Unpack the subject */
5579 subj = unpack_obj(sc, &args, "kern-being-get-visible-tiles");
5580 if (!subj)
5581 return sc->NIL;
5582
5583 place = subj->getPlace();
5584 if (! place) {
5585 rt_err("kern-being-get-visible-tiles: null place");
5586 return sc->NIL;
5587 }
5588
5589 ox = subj->getX();
5590 oy = subj->getY();
5591 vr = subj->getVisionRadius();
5592
5593 for (int y = 0; y < place_h(place); y++) {
5594 for (int x = 0; x < place_w(place); x++) {
5595
5596 /* Filter out tiles not in los of the subject */
5597 if (! place_in_los(place, ox, oy, place, x, y))
5598 continue;
5599
5600 /* Filter out tiles not in the vision radius of the
5601 * subject */
5602 if (place_flying_distance(place, ox, oy, x, y) > vr)
5603 continue;
5604
5605 /* else append this location to the list */
5606 cell = scm_mk_loc(sc, place, x, y);
5607 cell = _cons(sc, cell, sc->NIL, 0);
5608
5609 if (head == sc->NIL) {
5610 head = cell;
5611 tail = cell;
5612 scm_protect(sc, cell);
5613 } else {
5614 tail->_object._cons._cdr = cell;
5615 tail = cell;
5616 }
5617 }
5618 }
5619
5620 /* unprotect the list prior to returning */
5621 if (head != sc->NIL)
5622 scm_unprotect(sc, head);
5623
5624 return head;
5625 }
5626
KERN_API_CALL(kern_place_get_objects)5627 KERN_API_CALL(kern_place_get_objects)
5628 {
5629 struct place *place;
5630
5631 /* unpack the place */
5632 if (unpack(sc, &args, "p", &place)) {
5633 rt_err("kern-place-get-objects: bad args");
5634 return sc->NIL;
5635 }
5636 if (! place) {
5637 rt_err("kern-place-get-objects: null place");
5638 return sc->NIL;
5639 }
5640
5641 return kern_place_for_each_object(sc, place, NULL, NULL);
5642 }
5643
5644
5645 /* struct kern_place_get_objects_in_los_info { */
5646 /* struct kern_append_info ap_info; */
5647 /* struct place *place; */
5648 /* int ox; /\* looker's x *\/ */
5649 /* int oy; /\* looker's y *\/ */
5650 /* int rad; /\* looke r's rad *\/ */
5651 /* int vx; /\* vmask ulc x *\/ */
5652 /* int vy; /\* vmask ulc y *\/ */
5653 /* char *vmask; */
5654 /* }; */
5655
5656 /* static void kern_place_get_objects_in_los_cb(Object *obj, void *data) */
5657 /* { */
5658 /* struct kern_place_get_objects_in_los_info *info; */
5659 /* int x, y; */
5660
5661 /* info = (struct kern_place_get_objects_in_los_info *)data; */
5662
5663 /* /\* check if the object is within vision radius *\/ */
5664 /* if (place_flying_distance(info->place, */
5665 /* info->ox, */
5666 /* info->oy, */
5667 /* obj->getX(), */
5668 /* obj->getY()) */
5669 /* > info->rad) { */
5670 /* return; */
5671 /* } */
5672
5673 /* /\* translate the object's coordinates into coordinates offset from the */
5674 /* * upper left corner of the vmask region *\/ */
5675 /* x = obj->getX() - info->vx; */
5676 /* y = obj->getY() - info->vy; */
5677
5678 /* /\* check if the object is outside the vmask *\/ */
5679 /* if (x < 0 || */
5680 /* y < 0 || */
5681 /* x >= VMASK_W || */
5682 /* y >= VMASK_H) */
5683 /* return; */
5684
5685 /* /\* if the object's tile is marked as visible then add it to the list *\/ */
5686 /* if (info->vmask[y * VMASK_W + x]) */
5687 /* kern_append_object(obj, &info->ap_info); */
5688 /* } */
5689
5690 /* KERN_API_CALL(kern_place_get_objects_in_los) */
5691 /* { */
5692 /* class Object *obj; */
5693 /* struct kern_place_get_objects_in_los_info info; */
5694
5695 /* obj = unpack_obj(sc, &args, "kern-place-get-objects-in-los"); */
5696 /* if (! obj) */
5697 /* return sc->NIL; */
5698
5699 /* if (! obj->getPlace()) { */
5700 /* rt_err("kern-place-get-object-in-los: obj has null place"); */
5701 /* return sc->NIL; */
5702 /* } */
5703
5704 /* /\* initialize the context used by the callback to append objects *\/ */
5705 /* info.ap_info.sc = sc; */
5706 /* info.ap_info.head = sc->NIL; */
5707 /* info.ap_info.tail = sc->NIL; */
5708 /* info.place = obj->getPlace(); */
5709 /* info.ox = obj->getX(); */
5710 /* info.oy = obj->getY(); */
5711 /* info.rad = obj->getVisionRadius(); */
5712 /* info.vx = obj->getX() - VMASK_W / 2; */
5713 /* info.vy = obj->getY() - VMASK_H / 2; */
5714 /* info.vmask = vmask_get(obj->getPlace(), */
5715 /* obj->getX(), */
5716 /* obj->getY()); */
5717
5718 /* /\* build a scheme list of the objects *\/ */
5719 /* place_for_each_object(obj->getPlace(), */
5720 /* kern_place_get_objects_in_los_cb, &info); */
5721
5722 /* /\* return the scheme list *\/ */
5723 /* return info.ap_info.head; */
5724 /* } */
5725
KERN_API_CALL(kern_place_get_name)5726 KERN_API_CALL(kern_place_get_name)
5727 {
5728 struct place *place;
5729
5730 /* unpack the place */
5731 if (unpack(sc, &args, "p", &place)) {
5732 rt_err("kern-place-get-name: bad args");
5733 return sc->NIL;
5734 }
5735 if (! place) {
5736 rt_err("kern-place-get-name: null place");
5737 return sc->NIL;
5738 }
5739
5740 return scm_mk_string(sc, place->name);
5741 }
5742
KERN_API_CALL(kern_place_is_passable)5743 KERN_API_CALL(kern_place_is_passable)
5744 {
5745 struct place *place;
5746 int x, y;
5747 class Object *obj;
5748
5749 if (unpack_loc(sc, &args, &place, &x, &y, "kern-place-is-passable"))
5750 return sc->F;
5751
5752 obj = unpack_obj(sc, &args, "kern-place-is-passable");
5753 if (!obj)
5754 return sc->F;
5755
5756 return place_is_passable(place, x, y, obj, 0) ? sc->T : sc->F;
5757 }
5758
KERN_API_CALL(kern_place_move_is_passable)5759 KERN_API_CALL(kern_place_move_is_passable)
5760 {
5761 struct place *fplace, *tplace;
5762 int fx, fy, tx, ty;
5763 class Object *obj;
5764
5765 if (unpack_loc(sc, &args, &fplace, &fx, &fy,
5766 "kern-place-move-is-passable"))
5767 return sc->F;
5768
5769 if (unpack_loc(sc, &args, &tplace, &tx, &ty,
5770 "kern-place-move-is-passable"))
5771 return sc->F;
5772
5773 obj = unpack_obj(sc, &args, "kern-place-move-is-passable");
5774 if (!obj)
5775 return sc->F;
5776
5777 return place_move_is_passable(fplace, fx, fy, tx, ty, obj, 0) ? sc->T
5778 : sc->F;
5779 }
5780
KERN_API_CALL(kern_place_is_hazardous)5781 KERN_API_CALL(kern_place_is_hazardous)
5782 {
5783 struct place *place;
5784 int x, y;
5785 class Object *obj;
5786
5787 if (unpack_loc(sc, &args, &place, &x, &y, "kern-place-is-hazardous"))
5788 return sc->F;
5789
5790 obj = unpack_obj(sc, &args, "kern-place-is-hazardous");
5791 if (!obj)
5792 return sc->F;
5793
5794 return place_is_hazardous(place, x, y) ? sc->T : sc->F;
5795 }
5796
KERN_API_CALL(kern_place_set_terrain)5797 KERN_API_CALL(kern_place_set_terrain)
5798 {
5799 struct place *place;
5800 int x, y;
5801 struct terrain *terrain;
5802
5803 if (unpack_loc(sc, &args, &place, &x, &y, "kern-place-set-terrain"))
5804 return sc->F;
5805
5806 if (unpack(sc, &args, "p", &terrain)) {
5807 rt_err("kern-place-set-terrain: bad args");
5808 return sc->F;
5809 }
5810
5811 if (! terrain) {
5812 rt_err("kern-place-set-terrain: nil terrain");
5813 return sc->F;
5814 }
5815
5816 place_set_terrain(place, x, y, terrain);
5817
5818 /* Often changing the terrain requires us to recalculate LOS in the
5819 * surrounding area. */
5820 vmask_invalidate(place, x, y, 1, 1);
5821
5822 /* And that means the map usually needs repainting, too */
5823 mapSetDirty();
5824
5825 return sc->T;
5826 }
5827
KERN_API_CALL(kern_place_set_subplace)5828 KERN_API_CALL(kern_place_set_subplace)
5829 {
5830 struct place *place, *subplace;
5831 int x, y;
5832
5833 if (unpack(sc, &args, "p", &subplace)) {
5834 rt_err("kern-place-set-subplace: bad args");
5835 return sc->NIL;
5836 }
5837
5838 if (! subplace) {
5839 rt_err("kern-place-set-subplace: nil subplace");
5840 return sc->NIL;
5841 }
5842
5843 if (unpack_loc(sc, &args, &place, &x, &y, "kern-place-set-subplace"))
5844 return sc->NIL;
5845
5846
5847 place_add_subplace(place, subplace, x, y);
5848
5849 return scm_mk_ptr(sc, subplace);
5850 }
5851
KERN_API_CALL(kern_place_get_terrain)5852 KERN_API_CALL(kern_place_get_terrain)
5853 {
5854 struct place *place;
5855 int x, y;
5856 struct terrain *terrain;
5857
5858 if (unpack_loc(sc, &args, &place, &x, &y, "kern-place-get-terrain"))
5859 return sc->F;
5860
5861 terrain = place_get_terrain(place, x, y);
5862
5863 return terrain ? scm_mk_ptr(sc, terrain) : sc->NIL;
5864 }
5865
KERN_API_CALL(kern_place_get_movement_cost)5866 KERN_API_CALL(kern_place_get_movement_cost)
5867 {
5868 struct place *place;
5869 int x, y, cost=0;
5870 class Object *obj;
5871
5872 if (unpack_loc(sc, &args, &place, &x, &y, "kern-place-get-movement-cost"))
5873 goto done;
5874
5875 obj = unpack_obj(sc, &args, "kern-place-get-movement-cost");
5876 if (!obj)
5877 goto done;
5878
5879 cost = place_get_movement_cost(place, x, y, obj,0);
5880
5881 done:
5882 return scm_mk_integer(sc, cost);
5883 }
5884
KERN_API_CALL(kern_place_get_light)5885 KERN_API_CALL(kern_place_get_light)
5886 {
5887 struct place *place;
5888 int x, y;
5889
5890 if (unpack_loc(sc, &args, &place, &x, &y, "kern-place-get-light"))
5891 return sc->F;
5892
5893 return scm_mk_integer(sc, place_get_light(place, x, y));
5894 }
5895
KERN_API_CALL(kern_place_get_terrain_map)5896 KERN_API_CALL(kern_place_get_terrain_map)
5897 {
5898 struct place *place;
5899 struct terrain_map *map;
5900
5901 if (unpack(sc, &args, "p", &place)) {
5902 rt_err("kern-place-get-terrain-map: bad args");
5903 return sc->NIL;
5904 }
5905
5906 map = place_get_terrain_map(place);
5907 if (!map)
5908 return sc->NIL;
5909 return scm_mk_ptr(sc, map);
5910 }
5911
KERN_API_CALL(kern_place_set_terrain_map)5912 KERN_API_CALL(kern_place_set_terrain_map)
5913 {
5914 struct place *place;
5915 struct terrain_map *map;
5916
5917 if (unpack(sc, &args, "pp", &place, &map)) {
5918 rt_err("kern-place-set-terrain-map: bad args");
5919 return sc->NIL;
5920 }
5921
5922 place_set_terrain_map(place, map);
5923 return scm_mk_ptr(sc, place);
5924 }
5925
KERN_API_CALL(kern_place_blocks_los)5926 KERN_API_CALL(kern_place_blocks_los)
5927 {
5928 struct place *place;
5929 int x, y;
5930
5931 if (unpack_loc(sc, &args, &place, &x, &y, "kern-place-blocks-los?"))
5932 return sc->F;
5933
5934 return place_visibility(place, x, y) ? sc->F : sc->T;
5935 }
5936
KERN_API_CALL(kern_obj_set_temporary)5937 KERN_API_CALL(kern_obj_set_temporary)
5938 {
5939 class Object *obj;
5940 int val;
5941
5942 obj = unpack_obj(sc, &args, "kern-obj-set-temporary");
5943 if (!obj)
5944 return sc->NIL;
5945
5946 if (unpack(sc, &args, "b", &val)) {
5947 rt_err("kern-obj-set-temporary: bad value arg");
5948 return scm_mk_ptr(sc, obj);
5949 }
5950
5951 obj->setTemporary(val);
5952
5953 return scm_mk_ptr(sc, obj);
5954 }
5955
KERN_API_CALL(kern_obj_set_ignore_time_stop)5956 KERN_API_CALL(kern_obj_set_ignore_time_stop)
5957 {
5958 class Object *obj;
5959 int val;
5960
5961 obj = unpack_obj(sc, &args, "kern-obj-set-ignore-time-stop");
5962 if (!obj)
5963 return sc->NIL;
5964
5965 if (unpack(sc, &args, "b", &val)) {
5966 rt_err("kern-obj-set-ignore-time-stop: bad value arg");
5967 return scm_mk_ptr(sc, obj);
5968 }
5969
5970 obj->setIgnoreTimeStop(val);
5971
5972 return scm_mk_ptr(sc, obj);
5973 }
5974
KERN_API_CALL(kern_obj_wander)5975 KERN_API_CALL(kern_obj_wander)
5976 {
5977 class Object *obj;
5978
5979 obj = unpack_obj(sc, &args, "kern-obj-wander");
5980 if (!obj)
5981 return sc->NIL;
5982
5983 //moves can have nasty consequences,
5984 //so keep our own ref to the object for a bit
5985 obj_inc_ref(obj);
5986 ctrl_wander(obj);
5987 obj_dec_ref(obj);
5988
5989 return sc->NIL;
5990 }
5991
KERN_API_CALL(kern_obj_clone)5992 KERN_API_CALL(kern_obj_clone)
5993 {
5994 class Object *obj, *clone;
5995
5996 obj = unpack_obj(sc, &args, "kern-char-clone");
5997 if (!obj)
5998 return sc->NIL;
5999
6000 clone = obj->clone();
6001 assert(clone);
6002 clone->setTemporary(1);
6003
6004 return scm_mk_ptr(sc, clone);
6005 }
6006
KERN_API_CALL(kern_obj_freeze)6007 KERN_API_CALL(kern_obj_freeze)
6008 {
6009 class Object *obj;
6010 char* key;
6011 int x,y;
6012
6013 obj = unpack_obj(sc, &args, "kern-obj-freeze");
6014 if (!obj)
6015 return sc->NIL;
6016
6017 if (unpack(sc, &args, "sdd", &key, &x, &y)) {
6018 rt_err("kern-obj-freeze: bad args");
6019 return sc->NIL;
6020 }
6021
6022 obj_inc_ref(obj);
6023 freezer_freezeObject(key, x, y, obj);
6024
6025 return sc->NIL;
6026 }
6027
KERN_API_CALL(kern_obj_thaw)6028 KERN_API_CALL(kern_obj_thaw)
6029 {
6030 class Object *obj;
6031 struct place *place;
6032 char* key;
6033 int x,y;
6034
6035 if (unpack(sc, &args, "sp", &key, &place)) {
6036 rt_err("kern-obj-thaw-at: bad args");
6037 return sc->NIL;
6038 }
6039
6040 obj = freezer_thawObject(key, &x, &y);
6041
6042 if (obj)
6043 {
6044 obj->relocate(place, x, y, REL_NOTRIG);
6045 scm_mk_ptr(sc, obj);
6046 obj_dec_ref(obj);
6047 return scm_mk_ptr(sc, obj);
6048 }
6049
6050 return sc->NIL;
6051 }
6052
KERN_API_CALL(kern_set_wind)6053 KERN_API_CALL(kern_set_wind)
6054 {
6055 int dur, dir;
6056
6057 if (unpack(sc, &args, "dd", &dir, &dur)) {
6058 rt_err("kern-set-wind: bad args");
6059 return sc->F;
6060 }
6061
6062 windSetDirection(dir, dur);
6063 return sc->T;
6064 }
6065
KERN_API_CALL(kern_get_wind)6066 KERN_API_CALL(kern_get_wind)
6067 {
6068 return scm_mk_integer(sc, windGetDirection());
6069 }
6070
KERN_API_CALL(kern_ui_direction)6071 KERN_API_CALL(kern_ui_direction)
6072 {
6073 int dir = ui_get_direction();
6074
6075 if (dir == CANCEL)
6076 return sc->NIL;
6077
6078 return scm_mk_integer(sc, dir);
6079 }
6080
KERN_API_CALL(kern_place_get_neighbor)6081 KERN_API_CALL(kern_place_get_neighbor)
6082 {
6083 struct place *place;
6084 struct place *neighbor;
6085 int dir;
6086
6087 if (unpack(sc, &args, "pd", &place, &dir)) {
6088 rt_err("kern-place-get-neighbor: bad args");
6089 return sc->NIL;
6090 }
6091
6092 /* lookup neighbor */
6093 neighbor = place_get_neighbor(place, dir);
6094 if (neighbor)
6095 return scm_mk_ptr(sc, neighbor);
6096 else
6097 return sc->NIL;
6098 }
6099
KERN_API_CALL(kern_char_get_party)6100 KERN_API_CALL(kern_char_get_party)
6101 {
6102 class Character *ch;
6103 class Party *party;
6104
6105 ch = (class Character*)unpack_obj(sc, &args, "kern-char-get-party");
6106 if (!ch)
6107 return sc->NIL;
6108
6109 party = ch->getParty();
6110 if (party)
6111 return scm_mk_ptr(sc, party);
6112 else
6113 return sc->NIL;
6114 }
6115
KERN_API_CALL(kern_char_add_defense)6116 KERN_API_CALL(kern_char_add_defense)
6117 {
6118 int val;
6119 class Character *ch;
6120
6121 ch = (class Character*)unpack_obj(sc, &args, "kern-char-add-defense");
6122 if (!ch)
6123 return sc->NIL;
6124
6125 if (unpack(sc, &args, "d", &val)) {
6126 rt_err("kern-char-add-defense: bad args");
6127 return sc->NIL;
6128 }
6129
6130 ch->addDefense(val);
6131
6132 return sc->NIL;
6133 }
6134
KERN_API_CALL(kern_char_add_experience)6135 KERN_API_CALL(kern_char_add_experience)
6136 {
6137 int val;
6138 class Character *ch;
6139
6140 ch = (class Character*)unpack_obj(sc, &args,
6141 "kern-char-add-experience");
6142 if (!ch)
6143 return sc->NIL;
6144
6145 if (unpack(sc, &args, "d", &val)) {
6146 rt_err("kern-char-add-experience: bad args");
6147 goto done;
6148 }
6149
6150 ch->addExperience(val);
6151 done:
6152 return scm_mk_ptr(sc, ch);
6153 }
6154
KERN_API_CALL(kern_add_magic_negated)6155 KERN_API_CALL(kern_add_magic_negated)
6156 {
6157 int val;
6158
6159 if (unpack(sc, &args, "d", &val)) {
6160 rt_err("kern-add-magic-negated: bad args");
6161 return sc->F;
6162 }
6163
6164 add_magic_negated(val);
6165 foogodRepaint();
6166 return sc->T;
6167 }
6168
KERN_API_CALL(kern_get_magic_negated)6169 KERN_API_CALL(kern_get_magic_negated)
6170 {
6171 return scm_mk_integer(sc, MagicNegated);
6172 }
6173
KERN_API_CALL(kern_add_quicken)6174 KERN_API_CALL(kern_add_quicken)
6175 {
6176 int val;
6177
6178 if (unpack(sc, &args, "d", &val)) {
6179 rt_err("kern-add-quicken: bad args");
6180 return sc->F;
6181 }
6182
6183 add_quicken(val);
6184 foogodRepaint();
6185 return sc->T;
6186 }
6187
KERN_API_CALL(kern_set_time_accel)6188 KERN_API_CALL(kern_set_time_accel)
6189 {
6190 float val;
6191
6192 if (unpack(sc, &args, "f", &val)) {
6193 rt_err("kern-set-time-accel: bad args");
6194 return sc->F;
6195 }
6196
6197 session_set_time_accel(val);
6198 foogodRepaint();
6199 return sc->T;
6200 }
6201
KERN_API_CALL(kern_set_turn_count)6202 KERN_API_CALL(kern_set_turn_count)
6203 {
6204 int val;
6205
6206 if (unpack(sc, &args, "d", &val)) {
6207 rt_err("kern-set-turn-count: bad args");
6208 return sc->F;
6209 }
6210
6211 session_set_turn_count(val);
6212 return sc->T;
6213 }
6214
KERN_API_CALL(kern_add_reveal)6215 KERN_API_CALL(kern_add_reveal)
6216 {
6217 int val;
6218
6219 if (unpack(sc, &args, "d", &val)) {
6220 rt_err("kern-add-reveal: bad args");
6221 return sc->F;
6222 }
6223
6224 add_reveal(val);
6225 foogodRepaint();
6226 return sc->T;
6227 }
6228
KERN_API_CALL(kern_add_time_stop)6229 KERN_API_CALL(kern_add_time_stop)
6230 {
6231 int val;
6232
6233 if (unpack(sc, &args, "d", &val)) {
6234 rt_err("kern-add-time-stop: bad args");
6235 return sc->F;
6236 }
6237
6238 add_time_stop(val);
6239 foogodRepaint();
6240 return sc->T;
6241 }
6242
KERN_API_CALL(kern_being_is_hostile)6243 KERN_API_CALL(kern_being_is_hostile)
6244 {
6245 class Being *one, *another;
6246
6247 if (unpack(sc, &args, "pp", &one, &another)) {
6248 rt_err("kern-being-is-hostile: bad args");
6249 return sc->F;
6250 }
6251
6252 if (! one || ! another) {
6253 rt_err("kern-being-is-hostile: null character");
6254 return sc->F;
6255 }
6256
6257 return are_hostile(one, another) ? sc->T : sc->F;
6258 }
6259
KERN_API_CALL(kern_being_is_ally)6260 KERN_API_CALL(kern_being_is_ally)
6261 {
6262 class Being *one, *another;
6263
6264 if (unpack(sc, &args, "pp", &one, &another)) {
6265 rt_err("kern-being-is-ally: bad args");
6266 return sc->F;
6267 }
6268
6269 if (! one || ! another) {
6270 rt_err("kern-being-is-ally: null character");
6271 return sc->F;
6272 }
6273
6274 return are_allies(one, another) ? sc->T : sc->F;
6275 }
6276
KERN_API_CALL(kern_add_xray_vision)6277 KERN_API_CALL(kern_add_xray_vision)
6278 {
6279 int val;
6280
6281 if (unpack(sc, &args, "d", &val)) {
6282 rt_err("kern-add-xray-vision: bad args");
6283 return sc->F;
6284 }
6285
6286 add_xray(val);
6287 return sc->T;
6288 }
6289
KERN_API_CALL(kern_char_charm)6290 KERN_API_CALL(kern_char_charm)
6291 {
6292 int val;
6293 class Character *ch;
6294
6295 ch = (class Character*)unpack_obj(sc, &args, "kern-char-charm");
6296 if (!ch)
6297 return sc->NIL;
6298
6299 if (unpack(sc, &args, "d", &val)) {
6300 rt_err("kern-char-charm: bad args");
6301 return sc->NIL;
6302 }
6303
6304 ch->charm(val);
6305
6306 return sc->NIL;
6307 }
6308
KERN_API_CALL(kern_char_uncharm)6309 KERN_API_CALL(kern_char_uncharm)
6310 {
6311 class Character *ch;
6312
6313 ch = (class Character*)unpack_obj(sc, &args, "kern-char-charm");
6314 if (!ch)
6315 return sc->NIL;
6316
6317 ch->unCharm();
6318
6319 return sc->NIL;
6320 }
6321
KERN_API_CALL(kern_map_set_jitter)6322 KERN_API_CALL(kern_map_set_jitter)
6323 {
6324 int val;
6325
6326 if (unpack(sc, &args, "b", &val)) {
6327 rt_err("kern-map-set-jitter: bad args");
6328 return sc->F;
6329 }
6330
6331 mapJitter(val);
6332 return sc->T;
6333 }
6334
KERN_API_CALL(kern_image_load)6335 KERN_API_CALL(kern_image_load)
6336 {
6337 char *fname, *path;
6338 SDL_Surface *image = 0;
6339
6340 if (unpack(sc, &args, "s", &fname)) {
6341 rt_err("kern-image-load: bad args");
6342 return sc->NIL;
6343 }
6344
6345 path = file_mkpath(cfg_get("include-dirname"), fname);
6346 if (! path) {
6347 rt_err("kern-image-load: %s", file_get_error());
6348 return sc->NIL;
6349 }
6350
6351 image = IMG_Load(path);
6352 if (! image) {
6353 rt_err("kern-image-load: %s", SDL_GetError());
6354 }
6355 free(path);
6356
6357 return scm_mk_ptr(sc, image);
6358 }
6359
KERN_API_CALL(kern_image_free)6360 KERN_API_CALL(kern_image_free)
6361 {
6362 SDL_Surface *image;
6363
6364 if (unpack(sc, &args, "p", &image)) {
6365 rt_err("kern-image-free: bad args");
6366 return sc->NIL;
6367 }
6368
6369 SDL_FreeSurface(image);
6370 return sc->NIL;
6371 }
6372
KERN_API_CALL(kern_map_set_image)6373 KERN_API_CALL(kern_map_set_image)
6374 {
6375 SDL_Surface *image;
6376
6377 if (unpack(sc, &args, "p", &image)) {
6378 rt_err("kern-map-set-image: bad args");
6379 return sc->NIL;
6380 }
6381
6382 if (!image) {
6383 mapClearImage();
6384 mapUpdate(0);
6385 return sc->NIL;
6386 }
6387
6388 mapSetImage(image);
6389 return sc->NIL;
6390 }
6391
KERN_API_CALL(kern_map_blit_image)6392 KERN_API_CALL(kern_map_blit_image)
6393 {
6394 SDL_Surface *image;
6395 Uint32 x, y;
6396
6397 if (unpack(sc, &args, "pdd", &image, &x, &y)) {
6398 rt_err("kern-map-blit-image: bad args");
6399 return sc->NIL;
6400 }
6401
6402 if (!image) {
6403 return sc->NIL;
6404 }
6405
6406 mapBlitImage(image, x, y);
6407 return sc->NIL;
6408 }
6409
KERN_API_CALL(kern_map_get_width)6410 KERN_API_CALL(kern_map_get_width)
6411 {
6412 struct terrain_map *map;
6413
6414 if (unpack(sc, &args, "p", &map)) {
6415 rt_err("kern-map-get-width: bad args");
6416 return sc->NIL;
6417 }
6418
6419 if (!map) {
6420 rt_err("kern-map-get-width: null map");
6421 return sc->NIL;
6422 }
6423
6424 return scm_mk_integer(sc, map->w);
6425 }
6426
6427
KERN_API_CALL(kern_map_get_height)6428 KERN_API_CALL(kern_map_get_height)
6429 {
6430 struct terrain_map *map;
6431
6432 if (unpack(sc, &args, "p", &map)) {
6433 rt_err("kern-map-get-width: bad args");
6434 return sc->NIL;
6435 }
6436
6437 if (!map) {
6438 rt_err("kern-map-get-width: null map");
6439 return sc->NIL;
6440 }
6441
6442 return scm_mk_integer(sc, map->h);
6443 }
6444
KERN_API_CALL(kern_char_kill)6445 KERN_API_CALL(kern_char_kill)
6446 {
6447 class Character *ch;
6448
6449 ch = (class Character*)unpack_obj(sc, &args, "kern-char-kill");
6450 if (!ch)
6451 return sc->NIL;
6452
6453 ch->kill();
6454
6455 return sc->NIL;
6456 }
6457
KERN_API_CALL(kern_char_resurrect)6458 KERN_API_CALL(kern_char_resurrect)
6459 {
6460 class Character *ch;
6461
6462 ch = (class Character*)unpack_obj(sc, &args, "kern-char-resurrect");
6463 if (!ch)
6464 return sc->NIL;
6465
6466 ch->resurrect();
6467
6468 return scm_mk_ptr(sc, ch);
6469 }
6470
KERN_API_CALL(kern_is_valid_location)6471 KERN_API_CALL(kern_is_valid_location)
6472 {
6473 struct place *place;
6474 int x, y;
6475
6476 if (unpack_loc(sc, &args, &place, &x, &y, "kern-is-valid-location?"))
6477 return sc->F;
6478
6479 if (place->wraps)
6480 return sc->T;
6481
6482 if (x < 0 || x >= place_w(place) ||
6483 y < 0 || y >= place_h(place))
6484 return sc->F;
6485
6486 return sc->T;
6487 }
6488
KERN_API_CALL(kern_terrain_blocks_los)6489 KERN_API_CALL(kern_terrain_blocks_los)
6490 {
6491 struct terrain *terrain;
6492
6493 if (unpack(sc, &args, "p", &terrain)) {
6494 rt_err("kern-terrain-blocks-los?: bad args");
6495 return sc->NIL;
6496 }
6497
6498 if(! terrain) {
6499 rt_err("kern-terrain-blocks-los?: null terrain");
6500 return sc->NIL;
6501 }
6502
6503 return terrain->alpha ? sc->T : sc->F;
6504 }
6505
KERN_API_CALL(kern_terrain_get_pclass)6506 KERN_API_CALL(kern_terrain_get_pclass)
6507 {
6508 struct terrain *terrain;
6509
6510 if (unpack(sc, &args, "p", &terrain)) {
6511 rt_err("kern-terrain-get-pclass: bad args");
6512 return sc->NIL;
6513 }
6514
6515 if(! terrain) {
6516 rt_err("kern-terrain-get-pclass: null terrain");
6517 return sc->NIL;
6518 }
6519
6520 return scm_mk_integer(sc, terrain_pclass(terrain));
6521 }
6522
KERN_API_CALL(kern_terrain_set_combat_map)6523 KERN_API_CALL(kern_terrain_set_combat_map)
6524 {
6525 struct terrain *terrain;
6526 struct terrain_map *map;
6527
6528 if (unpack(sc, &args, "pp", &terrain, &map)) {
6529 rt_err("kern-terrain-set-combat-map: bad args");
6530 return sc->NIL;
6531 }
6532
6533 if(! terrain) {
6534 rt_err("kern-terrain-set-combat-map: null terrain");
6535 return sc->NIL;
6536 }
6537
6538 terrain->combat_map = map;
6539
6540 return scm_mk_ptr(sc, terrain);
6541 }
6542
KERN_API_CALL(kern_terrain_set_combat_handler)6543 KERN_API_CALL(kern_terrain_set_combat_handler)
6544 {
6545 struct terrain *terrain;
6546 pointer proc;
6547
6548 if (unpack(sc, &args, "po", &terrain, &proc)) {
6549 rt_err("kern-terrain-set-combat-handler: bad args");
6550 return sc->NIL;
6551 }
6552
6553 if(!terrain) {
6554 rt_err("kern-terrain-set-combat-handler: null terrain");
6555 return sc->NIL;
6556 }
6557
6558 if (proc != sc->NIL) {
6559 terrain->renderCombat = closure_new(sc, proc);
6560 closure_ref(terrain->renderCombat); //TODO clean up this nasty leaky hack
6561 }
6562
6563 return scm_mk_ptr(sc, terrain);
6564 }
6565
KERN_API_CALL(kern_terrain_map_inc_ref)6566 KERN_API_CALL(kern_terrain_map_inc_ref)
6567 {
6568 struct terrain_map *map;
6569
6570 if (unpack(sc, &args, "p", &map)) {
6571 rt_err("kern-terrain-map-inc-ref: bad args");
6572 return sc->NIL;
6573 }
6574
6575 terrain_map_ref(map);
6576 return scm_mk_ptr(sc, map);
6577 }
6578
KERN_API_CALL(kern_terrain_map_dec_ref)6579 KERN_API_CALL(kern_terrain_map_dec_ref)
6580 {
6581 struct terrain_map *map;
6582
6583 if (unpack(sc, &args, "p", &map)) {
6584 rt_err("kern-terrain-map-dec-ref: bad args");
6585 return sc->NIL;
6586 }
6587
6588 terrain_map_ref(map);
6589 return sc->NIL;
6590 }
6591
KERN_API_CALL(kern_mk_blender)6592 KERN_API_CALL(kern_mk_blender)
6593 {
6594 blender_t *blender;
6595 pointer rlist;
6596 int i = 0;
6597
6598 blender = (blender_t*)calloc(1, sizeof(*blender));
6599 list_init(&blender->list);
6600
6601 if (unpack(sc, &args, "p", &blender->inf)) {
6602 rt_err("kern-terrain-map-blend: bad args");
6603 goto abort;
6604 }
6605
6606 /* list of not-superior terrains */
6607 rlist = scm_car(sc, args);
6608 args = scm_cdr(sc, args);
6609
6610 if (! scm_is_pair(sc, rlist)) {
6611 rt_err("kern-terrain-map-blend: missing non-superior list");
6612 goto abort;
6613 }
6614
6615 while (scm_is_pair(sc, rlist)
6616 && blender->n_nonsup < BLENDER_MAX_NONSUP) {
6617 if (unpack(sc, &rlist, "p", &blender->nonsup[blender->n_nonsup])) {
6618 rt_err("kern-terrain-map-blend: non-superior terrain %d bad", i);
6619 goto abort;
6620 }
6621 blender->n_nonsup++;
6622 }
6623
6624 if (scm_is_pair(sc, rlist)) {
6625 warn("kern-terrain-map-blend: at most %d non-superior "\
6626 "terrains may be used, the rest will be ignored",
6627 BLENDER_MAX_NONSUP);
6628 }
6629
6630 /* list of target (range) terrains */
6631 i = 0;
6632 rlist = scm_car(sc, args);
6633 args = scm_cdr(sc, args);
6634
6635 if (! scm_is_pair(sc, rlist)) {
6636 rt_err("kern-terrain-map-blend: missing range list");
6637 goto abort;
6638 }
6639
6640 while (scm_is_pair(sc, rlist)
6641 && i < BLENDER_N_RANGE) {
6642
6643 if (unpack(sc, &rlist, "p", &blender->range[i])) {
6644 rt_err("kern-terrain-map-blend: range %d bad", i);
6645 return sc->NIL;
6646 }
6647
6648 i++;
6649 }
6650
6651 if (i < BLENDER_N_RANGE) {
6652 rt_err("kern-terrain-map-blend: expected %d ranges, got %d",
6653 BLENDER_N_RANGE, i);
6654 goto abort;
6655 }
6656
6657 session_add(Session, blender, blender_dtor, NULL, NULL);
6658 list_add(&Session->blenders, &blender->list);
6659
6660 return sc->T;
6661
6662 abort:
6663 free(blender);
6664 return sc->F;
6665 }
6666
KERN_API_CALL(kern_terrain_map_blend)6667 KERN_API_CALL(kern_terrain_map_blend)
6668 {
6669 struct terrain_map *map;
6670 struct terrain *inf, *nonsup[32], *range[16];
6671 pointer rlist;
6672 int i = 0;
6673 int n_nonsup = 0;
6674
6675 if (unpack(sc, &args, "pp", &map, &inf)) {
6676 rt_err("kern-terrain-map-blend: bad args");
6677 return sc->NIL;
6678 }
6679
6680 /* list of not-superior terrains */
6681 rlist = scm_car(sc, args);
6682 args = scm_cdr(sc, args);
6683
6684 if (! scm_is_pair(sc, rlist)) {
6685 rt_err("kern-terrain-map-blend: missing non-superior list");
6686 return sc->NIL;
6687 }
6688
6689 while (scm_is_pair(sc, rlist) && n_nonsup < array_sz(nonsup)) {
6690
6691 if (unpack(sc, &rlist, "p", &nonsup[n_nonsup])) {
6692 rt_err("kern-terrain-map-blend: non-superior terrain %d bad", i);
6693 return sc->NIL;
6694 }
6695
6696 n_nonsup++;
6697 }
6698
6699 if (scm_is_pair(sc, rlist)) {
6700 warn("kern-terrain-map-blend: at most %d non-superior "\
6701 "terrains may be used, the rest will be ignored",
6702 array_sz(nonsup));
6703 }
6704
6705 /* list of target (range) terrains */
6706 i = 0;
6707 rlist = scm_car(sc, args);
6708 args = scm_cdr(sc, args);
6709
6710 if (! scm_is_pair(sc, rlist)) {
6711 rt_err("kern-terrain-map-blend: missing range list");
6712 return sc->NIL;
6713 }
6714
6715 while (scm_is_pair(sc, rlist) && i < 16) {
6716
6717 if (unpack(sc, &rlist, "p", &range[i])) {
6718 rt_err("kern-terrain-map-blend: range %d bad", i);
6719 return sc->NIL;
6720 }
6721
6722 i++;
6723 }
6724
6725 if (i < 16) {
6726 rt_err("kern-terrain-map-blend: expected 16 ranges, got %d", i);
6727 return sc->NIL;
6728 }
6729
6730 terrain_map_blend(map, inf, n_nonsup, nonsup, range);
6731
6732 return scm_mk_ptr(sc, map);
6733 }
6734
KERN_API_CALL(kern_place_get_width)6735 KERN_API_CALL(kern_place_get_width)
6736 {
6737 struct place *place;
6738
6739 if (unpack(sc, &args, "p", &place)) {
6740 rt_err("kern-place-get-width: bad args");
6741 return sc->NIL;
6742 }
6743
6744 if (!place) {
6745 rt_err("kern-place-get-width: null place");
6746 return sc->NIL;
6747 }
6748
6749 return scm_mk_integer(sc, place_w(place));
6750 }
6751
KERN_API_CALL(kern_place_get_vehicle)6752 KERN_API_CALL(kern_place_get_vehicle)
6753 {
6754 struct place *place;
6755 int x, y;
6756 class Vehicle *veh;
6757
6758 if (unpack_loc(sc, &args, &place, &x, &y, "kern-place-get-vehicle"))
6759 return sc->NIL;
6760
6761 if (!place) {
6762 rt_err("kern-place-get-vehicle: null place");
6763 return sc->NIL;
6764 }
6765
6766 veh = place_get_vehicle(place, x, y);
6767
6768 return veh ? scm_mk_ptr(sc, veh) : sc->NIL;
6769 }
6770
KERN_API_CALL(kern_place_get_height)6771 KERN_API_CALL(kern_place_get_height)
6772 {
6773 struct place *place;
6774
6775 if (unpack(sc, &args, "p", &place)) {
6776 rt_err("kern-place-get-height: bad args");
6777 return sc->NIL;
6778 }
6779
6780 if (!place) {
6781 rt_err("kern-place-get-height: null place");
6782 return sc->NIL;
6783 }
6784
6785 return scm_mk_integer(sc, place_h(place));
6786 }
6787
KERN_API_CALL(kern_get_distance)6788 KERN_API_CALL(kern_get_distance)
6789 {
6790 struct place *p1, *p2;
6791 int x1, x2, y1, y2;
6792
6793 if (unpack_loc(sc, &args, &p1, &x1, &y1, "kern-get-distance") ||
6794 unpack_loc(sc, &args, &p2, &x2, &y2, "kern-get-distance"))
6795 return sc->NIL;
6796
6797 /* warn("p1=%s x1=%d y1=%d x2=%d y2=%d\n", p1->name, x1, y1, x2, y2); */
6798
6799 if (p1 != p2) {
6800 rt_err("kern-get-distance: place %s different from %s",
6801 p1->tag, p2->tag);
6802 return sc->NIL;
6803 }
6804
6805 return scm_mk_integer(sc, place_flying_distance(p1, x1, y1, x2, y2));
6806 }
6807
KERN_API_CALL(kern_in_los)6808 KERN_API_CALL(kern_in_los)
6809 {
6810 struct place *p1, *p2;
6811 int x1, x2, y1, y2;
6812
6813 if (unpack_loc(sc, &args, &p1, &x1, &y1, "kern-in-los?") ||
6814 unpack_loc(sc, &args, &p2, &x2, &y2, "kern-in-los?"))
6815 return sc->F;
6816
6817 if (p1 != p2) {
6818 /* happens sometimes when player exits a place and NPC's
6819 * looking for him in the same round */
6820 warn("kern-in-los?: place %s different from %s\n",
6821 p1->tag, p2->tag);
6822 return sc->F;
6823 }
6824
6825 return place_in_los(p1, x1, y1, p2, x2, y2) ? sc->T : sc->F;
6826 }
6827
KERN_API_CALL(kern_map_set_peering)6828 KERN_API_CALL(kern_map_set_peering)
6829 {
6830 int val;
6831 if (unpack(sc, &args, "b", &val)) {
6832 rt_err("kern-map-set-peering: bad args");
6833 return sc->NIL;
6834 }
6835 mapPeer(val);
6836 return sc->NIL;
6837 }
6838
KERN_API_CALL(kern_ui_waitkey)6839 KERN_API_CALL(kern_ui_waitkey)
6840 {
6841 int key;
6842 getkey(&key, anykey);
6843 return scm_mk_integer(sc, key);
6844 }
6845
KERN_API_CALL(kern_char_dec_mana)6846 KERN_API_CALL(kern_char_dec_mana)
6847 {
6848 int val;
6849 class Character *ch;
6850
6851 ch = (class Character*)unpack_obj(sc, &args, "kern-char-dec-mana");
6852 if (!ch)
6853 return sc->NIL;
6854
6855 if (unpack(sc, &args, "d", &val)) {
6856 rt_err("kern-char-dec-mana: bad args");
6857 return sc->NIL;
6858 }
6859
6860 ch->addMana(0 - val);
6861
6862 return sc->NIL;
6863 }
6864
KERN_API_CALL(kern_test_recursion)6865 KERN_API_CALL(kern_test_recursion)
6866 {
6867 pointer func;
6868
6869 if (unpack(sc, &args, "o", &func)) {
6870 rt_err("kern-test-recursion: bad args");
6871 return sc->NIL;
6872 }
6873
6874 scheme_call(sc, func, sc->NIL);
6875
6876 return sc->NIL;
6877 }
6878
KERN_API_CALL(kern_ui_select_from_list)6879 KERN_API_CALL(kern_ui_select_from_list)
6880 {
6881 struct KeyHandler kh;
6882 struct ScrollerContext data;
6883 const char **strings;
6884 int list_sz;
6885 int i = 0;
6886 enum StatusMode omode;
6887 char *selection = NULL;
6888
6889 list_sz = scm_len(sc, args);
6890 if (! list_sz)
6891 return sc->NIL;
6892
6893 strings = (const char**)calloc(list_sz, sizeof(strings[0]));
6894 assert(strings);
6895
6896 while (scm_is_pair(sc, args)) {
6897 if (unpack(sc, &args, "s", &strings[i])) {
6898 rt_err("kern-ui-select-from-list: bad args");
6899 goto done;
6900 }
6901 i++;
6902 }
6903
6904 foogodSetHintText(SCROLLER_HINT);
6905 foogodSetMode(FOOGOD_HINT);
6906 omode = statusGetMode();
6907 statusSetStringList("Select", list_sz, strings);
6908 statusSetMode(StringList);
6909
6910 data.selection = NULL;
6911 data.selector = String;
6912 kh.fx = scroller;
6913 kh.data = &data;
6914 eventPushKeyHandler(&kh);
6915 eventHandle();
6916 eventPopKeyHandler();
6917
6918 statusSetMode(omode);
6919 foogodSetMode(FOOGOD_DEFAULT);
6920
6921 selection = (char*)data.selection;
6922
6923 done:
6924 if (strings)
6925 free(strings);
6926
6927 if (selection)
6928 return scm_mk_string(sc, selection);
6929
6930 return sc->NIL;
6931
6932 }
6933
KERN_API_CALL(kern_ui_select_item)6934 KERN_API_CALL(kern_ui_select_item)
6935 {
6936 enum StatusMode omode;
6937 struct inv_entry *ie;
6938 class Character *ch;
6939
6940 ch = (class Character*)unpack_obj(sc, &args, "kern-ui-select-item");
6941 if (!ch || !ch->getInventoryContainer())
6942 return sc->NIL;
6943
6944 omode = statusGetMode();
6945 statusBrowseContainer(ch->getInventoryContainer(), "Select");
6946 ie = ui_select_item();
6947 statusSetMode(omode);
6948
6949 if (!ie) {
6950 return sc->NIL;
6951 }
6952
6953 return scm_mk_ptr(sc, ie->type);
6954 }
6955
KERN_API_CALL(kern_ui_page_text)6956 KERN_API_CALL(kern_ui_page_text)
6957 {
6958 struct KeyHandler kh;
6959 char *title;
6960 char *text = NULL;
6961 int len = 0;
6962 int lines = 0;
6963
6964 if (unpack(sc, &args, "s", &title)) {
6965 rt_err("kern-ui-status-page-text: bad title");
6966 return sc->NIL;
6967 }
6968
6969 while (scm_is_pair(sc, args)) {
6970
6971 char *line;
6972
6973 if (unpack(sc, &args, "s", &line)) {
6974 rt_err("kern-ui-status-page-text: bad text line");
6975 goto done;
6976 }
6977
6978 len += strlen(line);
6979 len++; /* for \n */
6980 text = (char*)realloc(text, len + 1 /* for \0 */);
6981 if (lines == 0) {
6982 text[0] = 0;
6983 }
6984 strcat(text, line);
6985 strcat(text, "\n");
6986 lines++;
6987 }
6988
6989 foogodSetHintText(PAGER_HINT);
6990 foogodSetMode(FOOGOD_HINT);
6991 statusSetPageText(title, text);
6992 statusSetMode(Page);
6993 consolePrint("[Hit ESC to continue]\n");
6994
6995 kh.fx = scroller;
6996 kh.data = NULL;
6997 eventPushKeyHandler(&kh);
6998 eventHandle();
6999 eventPopKeyHandler();
7000
7001 statusSetMode(ShowParty);
7002 foogodSetMode(FOOGOD_DEFAULT);
7003
7004 done:
7005 if (text)
7006 free(text);
7007
7008 return sc->NIL;
7009 }
7010
KERN_API_CALL(kern_obj_remove_from_inventory)7011 KERN_API_CALL(kern_obj_remove_from_inventory)
7012 {
7013 class Object *obj;
7014 class ObjectType *type;
7015 int amount;
7016
7017 if (unpack(sc, &args, "ppd", &obj, &type, &amount)) {
7018 rt_err("kern-obj-remove-from-inventory: bad args");
7019 return sc->NIL;
7020 }
7021
7022 if (! obj->takeOut(type, amount)) {
7023 rt_err("kern-obj-remove-from-inventory: failed! "\
7024 "(is quantity > amount available to take out?)");
7025 }
7026 return sc->NIL;
7027 }
7028
KERN_API_CALL(kern_obj_add_to_inventory)7029 KERN_API_CALL(kern_obj_add_to_inventory)
7030 {
7031 class Object *obj;
7032 class ObjectType *type;
7033 int amount;
7034
7035 if (unpack(sc, &args, "ppd", &obj, &type, &amount)) {
7036 rt_err("kern-obj-add-to-inventory: bad args");
7037 return sc->NIL;
7038 }
7039
7040 obj->add(type, amount);
7041 return sc->NIL;
7042 }
7043
KERN_API_CALL(kern_mk_ptable)7044 KERN_API_CALL(kern_mk_ptable)
7045 {
7046 int n_mmode;
7047 int n_pclass;
7048 int pclass;
7049 struct ptable *ptable;
7050 pointer row;
7051 pointer col;
7052
7053 /* The ptable table is a list of lists. Each row corresponds to a
7054 * passability class (a property of terrain, and objects which affect
7055 * passability onto a tile). Each column corresponds to a movement
7056 * mode. */
7057
7058 if (! scm_is_pair(sc, args)) {
7059 load_err("kern-mk-ptable: arg 0 not a list");
7060 return sc->NIL;
7061 }
7062
7063 /* count the number of passability classes and movement modes given in
7064 * the table */
7065 row = args;
7066 col = scm_car(sc, args);
7067
7068 n_pclass = scm_len(sc, row);
7069 n_mmode = scm_len(sc, col);
7070
7071 if (n_pclass <= 0) {
7072 load_err("kern-mk-ptable: 0 rows given");
7073 return sc->NIL;
7074 }
7075
7076 if (n_mmode <= 0) {
7077 load_err("kern-mk-ptable: row 0 has no columns");
7078 return sc->NIL;
7079 }
7080
7081 /* allocate the kernel passability table */
7082 ptable = ptable_new(n_mmode, n_pclass);
7083
7084 /* for each row (passability class) */
7085 for (pclass = 0; pclass < n_pclass; pclass++) {
7086
7087 int mmode;
7088
7089 col = scm_car(sc, row);
7090 row = scm_cdr(sc, row);
7091
7092 if (scm_len(sc, col) < n_mmode) {
7093 load_err("kern-mk-ptable: row %d has only %d columns",
7094 pclass, scm_len(sc, col));
7095 goto abort;
7096 }
7097
7098 /* for each column (movement mode) */
7099 for (mmode = 0; mmode < n_mmode; mmode++) {
7100
7101 int mcost;
7102
7103 /* get the movement cost */
7104 if (unpack(sc, &col, "d", &mcost)) {
7105 load_err("kern-mk-ptable: row %d col %d bad arg",
7106 pclass, mmode);
7107 goto abort;
7108 }
7109
7110 /* insert it into the passability table */
7111 ptable_set(ptable, mmode, pclass, mcost);
7112 }
7113 }
7114
7115
7116 /* associate the session with the new table */
7117 if (Session->ptable) {
7118 ptable_del(Session->ptable);
7119 }
7120 Session->ptable = ptable;
7121
7122 return sc->NIL;
7123
7124 abort:
7125 ptable_del(ptable);
7126 return sc->NIL;
7127 }
7128
KERN_API_CALL(kern_mk_dtable)7129 KERN_API_CALL(kern_mk_dtable)
7130 {
7131 int n_factions;
7132 int r_faction;
7133 struct dtable *dtable;
7134 pointer rows;
7135 pointer row;
7136
7137 /* The dtable table is a list of lists. Each row corresponds to a
7138 * passability class (a property of terrain, and objects which affect
7139 * passability onto a tile). Each column corresponds to a movement
7140 * mode. */
7141
7142 if (! scm_is_pair(sc, args)) {
7143 load_err("kern-mk-dtable: arg 0 not a list");
7144 return sc->NIL;
7145 }
7146
7147 /* count the number of factions given in the table */
7148 rows = args;
7149 row = scm_car(sc, rows);
7150 n_factions = scm_len(sc, rows);
7151 if (n_factions != scm_len(sc, row)) {
7152 load_err("kern-mk-dtable: # of rows and columns must be same");
7153 return sc->NIL;
7154 }
7155 if (n_factions <= 0) {
7156 load_err("kern-mk-dtable: 0 factions given");
7157 return sc->NIL;
7158 }
7159
7160 /* allocate the kernel table */
7161 dtable = dtable_new(n_factions);
7162
7163 /* for each row */
7164 for (r_faction = 0; r_faction < n_factions; r_faction++) {
7165
7166 int c_faction;
7167
7168 row = scm_car(sc, rows);
7169 rows = scm_cdr(sc, rows);
7170
7171 if (scm_len(sc, row) < n_factions) {
7172 load_err("kern-mk-dtable: row %d has only %d columns "
7173 "(expected %d)",
7174 r_faction, scm_len(sc, row),
7175 n_factions);
7176 goto abort;
7177 }
7178
7179 /* for each column up to the limit */
7180 for (c_faction = 0; c_faction < n_factions; c_faction++) {
7181
7182 int val;
7183
7184 /* unpack the value */
7185 if (unpack(sc, &row, "d", &val)) {
7186 load_err("kern-mk-dtable: row %d column %d "
7187 "is a bad entry", r_faction,
7188 c_faction);
7189 goto abort;
7190 }
7191
7192 /* poke it into the table */
7193 dtable_set(dtable, r_faction, c_faction, val);
7194 }
7195 }
7196
7197 /* associate the session with the new table */
7198 if (Session->dtable) {
7199 dtable_del(Session->dtable);
7200 }
7201 Session->dtable = dtable;
7202
7203 return scm_mk_ptr(sc, dtable);
7204
7205 abort:
7206 dtable_del(dtable);
7207 return sc->NIL;
7208 }
7209
7210 #define DTABLE_SET 0x81
7211 #define DTABLE_GET 0x05
7212 #define DTABLE_INC 0x06
7213 #define DTABLE_DEC 0x07
7214
7215 #define DTABLE_FX_USES_LEVEL(fx) ((fx) & 0x80)
7216
kern_dtable_aux(scheme * sc,pointer args,const char * name,int fx)7217 static pointer kern_dtable_aux(scheme *sc, pointer args, const char *name, int fx)
7218 {
7219 int f1, f2, level;
7220 const char *errstr = NULL;
7221
7222 if (! session_dtable()) {
7223 errstr = "no dtable";
7224 goto abort;
7225 }
7226
7227 if (unpack(sc, &args, "dd", &f1, &f2)) {
7228 errstr = "bad faction args";
7229 goto abort;
7230 }
7231
7232 if (DTABLE_FX_USES_LEVEL(fx)) {
7233 if (unpack(sc, &args, "d", &level)) {
7234 errstr = "bad level arg";
7235 goto abort;
7236 }
7237 }
7238
7239 switch (fx) {
7240 case DTABLE_SET:
7241 dtable_set(session_dtable(), f1, f2, level);
7242 break;
7243 case DTABLE_GET:
7244 level = dtable_get(session_dtable(), f1, f2);
7245 return scm_mk_integer(sc, level);
7246 break;
7247 case DTABLE_INC:
7248 dtable_inc(session_dtable(), f1, f2);
7249 break;
7250 case DTABLE_DEC:
7251 dtable_dec(session_dtable(), f1, f2);
7252 break;
7253 default:
7254 assert(0);
7255 break;
7256 }
7257
7258 return sc->T;
7259 abort:
7260 rt_err("%s: %s", name, errstr);
7261 return sc->F;
7262
7263 }
7264
KERN_API_CALL(kern_dtable_set)7265 KERN_API_CALL(kern_dtable_set)
7266 {
7267 return kern_dtable_aux(sc, args, "kern_dtable_set", DTABLE_SET);
7268 }
7269
KERN_API_CALL(kern_dtable_get)7270 KERN_API_CALL(kern_dtable_get)
7271 {
7272 return kern_dtable_aux(sc, args, "kern_dtable_get", DTABLE_GET);
7273 }
7274
KERN_API_CALL(kern_dtable_inc)7275 KERN_API_CALL(kern_dtable_inc)
7276 {
7277 return kern_dtable_aux(sc, args, "kern_dtable_inc", DTABLE_INC);
7278 }
7279
KERN_API_CALL(kern_dtable_dec)7280 KERN_API_CALL(kern_dtable_dec)
7281 {
7282 return kern_dtable_aux(sc, args, "kern_dtable_dec", DTABLE_DEC);
7283 }
7284
KERN_API_CALL(kern_party_add_member)7285 KERN_API_CALL(kern_party_add_member)
7286 {
7287 class Party *party;
7288 class Character *new_member;
7289
7290 party = (Party*)unpack_obj(sc, &args, "kern_party_add_member:<party>");
7291 if (!party)
7292 return sc->NIL;
7293
7294 new_member = (class Character*)unpack_obj(sc, &args,
7295 "kern_party_add_member:<member>");
7296 if (!new_member)
7297 return sc->NIL;
7298
7299 if (party->addMember(new_member))
7300 return sc->T;
7301
7302 return sc->F;
7303 }
7304
KERN_API_CALL(kern_party_set_vehicle)7305 KERN_API_CALL(kern_party_set_vehicle)
7306 {
7307 class Party *party;
7308 class Vehicle *vehicle;
7309
7310 party = (Party*)unpack_obj(sc, &args, "kern-party-set-vehicle");
7311 if (!party)
7312 return sc->NIL;
7313
7314 vehicle = (Vehicle*)unpack_obj(sc, &args, "kern-party-set-vehicle");
7315 party->setVehicle(vehicle);
7316
7317 return scm_mk_ptr(sc, party);
7318 }
7319
KERN_API_CALL(kern_party_get_vehicle)7320 KERN_API_CALL(kern_party_get_vehicle)
7321 {
7322 class Party *party;
7323 class Vehicle *vehicle;
7324
7325 party = (Party*)unpack_obj(sc, &args, "kern-party-get-vehicle");
7326 if (!party)
7327 return sc->NIL;
7328
7329 vehicle = party->getVehicle();
7330 if (vehicle)
7331 return scm_mk_ptr(sc, vehicle);
7332 return sc->NIL;
7333 }
7334
wrap_kern_append_obj(class Character * c,void * v)7335 static bool wrap_kern_append_obj(class Character *c, void *v)
7336 {
7337 kern_append_object(c, v);
7338 return false;
7339 }
7340
KERN_API_CALL(kern_get_time)7341 KERN_API_CALL(kern_get_time)
7342 {
7343 pointer head, tail, cell;
7344
7345 /* have to do everything in forward order so that our cells remain
7346 * protected from gc until the list is built */
7347 head = _cons(sc, scm_mk_integer(sc, clock_year()), sc->NIL, 0);
7348 tail = head;
7349 scm_protect(sc, head);
7350
7351 cell = _cons(sc, scm_mk_integer(sc, clock_month()), sc->NIL, 0);
7352 tail->_object._cons._cdr = cell;
7353 tail = cell;
7354
7355 cell = _cons(sc, scm_mk_integer(sc, clock_week()), sc->NIL, 0);
7356 tail->_object._cons._cdr = cell;
7357 tail = cell;
7358
7359 cell = _cons(sc, scm_mk_integer(sc, clock_day()), sc->NIL, 0);
7360 tail->_object._cons._cdr = cell;
7361 tail = cell;
7362
7363 cell = _cons(sc, scm_mk_integer(sc, clock_hour()), sc->NIL, 0);
7364 tail->_object._cons._cdr = cell;
7365 tail = cell;
7366
7367 cell = _cons(sc, scm_mk_integer(sc, clock_minute()), sc->NIL, 0);
7368 tail->_object._cons._cdr = cell;
7369 tail = cell;
7370
7371 scm_unprotect(sc, head);
7372 return head;
7373 }
7374
KERN_API_CALL(kern_get_time_remainder)7375 KERN_API_CALL(kern_get_time_remainder)
7376 {
7377 return scm_mk_integer(sc, clock_tick());
7378 }
7379
7380
KERN_API_CALL(kern_get_total_minutes)7381 KERN_API_CALL(kern_get_total_minutes)
7382 {
7383 return scm_mk_integer(sc, clock_time());
7384 }
7385
7386
KERN_API_CALL(kern_party_get_members)7387 KERN_API_CALL(kern_party_get_members)
7388 {
7389 class Party *party;
7390 struct kern_append_info info;
7391
7392 if (unpack(sc, &args, "p", &party)) {
7393 rt_err("kern-party-get-members: bad args");
7394 return sc->NIL;
7395 }
7396
7397 /* initialize the context used by the callback to append objects */
7398 info.sc = sc;
7399 info.head = sc->NIL;
7400 info.tail = sc->NIL;
7401 info.filter = NULL;
7402 info.data = NULL;
7403
7404 /* build a scheme list of the objects at that location */
7405 party->forEachMember(wrap_kern_append_obj, &info);
7406
7407 /* unprotect the list prior to return */
7408 if (info.head != sc->NIL)
7409 scm_unprotect(sc, info.head);
7410
7411 /* return the scheme list */
7412 return info.head;
7413 }
7414
KERN_API_CALL(kern_being_set_base_faction)7415 KERN_API_CALL(kern_being_set_base_faction)
7416 {
7417 class Being *being;
7418 int faction;
7419
7420 being = (class Being*)unpack_obj(sc, &args, "kern-being-set-base-faction");
7421 if (!being)
7422 goto done;
7423
7424 if (unpack(sc, &args, "d", &faction)) {
7425 rt_err("kern-being-set-base-faction: bad arg");
7426 goto done;
7427 }
7428
7429 being->setBaseFaction(faction);
7430 done:
7431 return scm_mk_ptr(sc, being);
7432
7433 }
7434
KERN_API_CALL(kern_being_set_current_faction)7435 KERN_API_CALL(kern_being_set_current_faction)
7436 {
7437 class Being *being;
7438 int faction;
7439
7440 being = (class Being*)unpack_obj(sc, &args, "kern-being-set-current-faction");
7441 if (!being)
7442 goto done;
7443
7444 if (unpack(sc, &args, "d", &faction)) {
7445 rt_err("kern-being-set-current-faction: bad arg");
7446 goto done;
7447 }
7448
7449 being->setCurrentFaction(faction);
7450 done:
7451 return scm_mk_ptr(sc, being);
7452
7453 }
7454
KERN_API_CALL(kern_being_set_name)7455 KERN_API_CALL(kern_being_set_name)
7456 {
7457 class Being *being;
7458 char *val;
7459
7460 being = (class Being*)unpack_obj(sc, &args, "kern-being-set-name");
7461 if (!being)
7462 goto done;
7463
7464 if (unpack(sc, &args, "s", &val)) {
7465 rt_err("kern-being-set-name: bad arg");
7466 goto done;
7467 }
7468
7469 being->setName(val);
7470 done:
7471 return scm_mk_ptr(sc, being);
7472
7473 }
7474
KERN_API_CALL(kern_vehicle_set_name)7475 KERN_API_CALL(kern_vehicle_set_name)
7476 {
7477 class Vehicle *vehicle;
7478 char *val;
7479
7480 vehicle = (class Vehicle*)unpack_obj(sc, &args, "kern-vehicle-set-name");
7481 if (!vehicle)
7482 goto done;
7483
7484 if (unpack(sc, &args, "s", &val)) {
7485 rt_err("kern-vehicle-set-name: bad arg");
7486 goto done;
7487 }
7488
7489 vehicle->setName(val);
7490 done:
7491 return scm_mk_ptr(sc, vehicle);
7492
7493 }
7494
KERN_API_CALL(kern_harm_relations)7495 KERN_API_CALL(kern_harm_relations)
7496 {
7497 class Character *cha;
7498 class Character *chb;
7499
7500 if (unpack(sc, &args, "pp", &cha, &chb)) {
7501 rt_err("kern-harm-relations: bad args");
7502 return sc->NIL;
7503 }
7504
7505 harm_relations(cha,chb);
7506
7507 return sc->NIL;
7508 }
7509
KERN_API_CALL(kern_being_get_current_faction)7510 KERN_API_CALL(kern_being_get_current_faction)
7511 {
7512 class Being *being;
7513 int faction = INVALID_FACTION;
7514
7515 being = (Being*)unpack_obj(sc, &args, "kern-being-get-current-faction");
7516 if (!being)
7517 goto done;
7518
7519 faction = being->getCurrentFaction();
7520 done:
7521 return scm_mk_integer(sc, faction);
7522 }
7523
KERN_API_CALL(kern_being_get_base_faction)7524 KERN_API_CALL(kern_being_get_base_faction)
7525 {
7526 class Being *being;
7527 int faction = INVALID_FACTION;
7528
7529 being = (Being*)unpack_obj(sc, &args, "kern-being-get-base-faction");
7530 if (!being)
7531 goto done;
7532
7533 faction = being->getBaseFaction();
7534 done:
7535 return scm_mk_integer(sc, faction);
7536 }
7537
KERN_API_CALL(kern_add_hook)7538 KERN_API_CALL(kern_add_hook)
7539 {
7540 pointer pproc;
7541 char *hookstr;
7542
7543 if(unpack(sc, &args, "yc", &hookstr, &pproc)) {
7544 load_err("%s: bad args", __FUNCTION__);
7545 return sc->NIL;
7546 }
7547
7548 //// printf("%s() %s: ", __FUNCTION__, hookstr);
7549 //// if (scm_is_sym(sc, pproc)) {
7550 //// printf("%s\n", scm_sym_val(sc, pproc));
7551 //// } else {
7552 //// printf("<raw code>\n");
7553 //// }
7554
7555 session_hook_id_t id = session_str_to_hook_id(hookstr);
7556 if (id >= NUM_HOOKS) {
7557 load_err("%s: bad hook id=%d (%s)", __FUNCTION__, id, hookstr);
7558 return sc->NIL;
7559 }
7560
7561 pointer pargs = sc->NIL;
7562 if (scm_is_pair(sc, args)) {
7563 pargs = scm_car(sc, args);
7564 }
7565 void *ret = session_add_hook(Session, (session_hook_id_t)id, closure_new(sc, pproc), pargs);
7566 return ret ? scm_mk_ptr(sc, ret) : sc->NIL;
7567 }
7568
KERN_API_CALL(kern_rm_hook)7569 KERN_API_CALL(kern_rm_hook)
7570 {
7571 pointer pproc;
7572 char *hookstr;
7573
7574 if(unpack(sc, &args, "yc", &hookstr, &pproc)) {
7575 load_err("%s: bad args", __FUNCTION__);
7576 return sc->NIL;
7577 }
7578
7579 session_hook_id_t id = session_str_to_hook_id(hookstr);
7580 if (id < NUM_HOOKS) {
7581 session_rm_hook(Session, (session_hook_id_t)id, pproc);
7582 }
7583
7584 return sc->NIL;
7585 }
7586
KERN_API_CALL(kern_add_query)7587 KERN_API_CALL(kern_add_query)
7588 {
7589 pointer pproc;
7590 char *str;
7591 int id = 0;
7592
7593 if(unpack(sc, &args, "yo", &str, &pproc)) {
7594 load_err("%s: bad args", __FUNCTION__);
7595 return sc->F;
7596 }
7597
7598 for (id = 0; id < NUM_HOOKS; id++) {
7599 if (! strcmp(query_to_id[id], str)) {
7600 session_add_query(Session, (session_query_id_t)id, closure_new(sc, pproc));
7601 return pproc;
7602 }
7603 }
7604
7605 return sc->F;
7606 }
7607
KERN_API_CALL(kern_player_set_follow_mode)7608 KERN_API_CALL(kern_player_set_follow_mode)
7609 {
7610 player_party->enableFollowMode();
7611 return sc->NIL;
7612 }
7613
KERN_API_CALL(kern_obj_has)7614 KERN_API_CALL(kern_obj_has)
7615 {
7616 class Object *object;
7617 class ObjectType *type;
7618 int has = 0;
7619
7620 object = (Object*)unpack_obj(sc, &args, "kern-obj-has");
7621 if (!object)
7622 goto done;
7623
7624 if (unpack(sc, &args, "p", &type)) {
7625 rt_err("kern-obj-has?");
7626 goto done;
7627 }
7628
7629 has = object->hasInInventory(type);
7630 done:
7631 return has ? sc->T : sc->F;
7632 }
7633
kern_astar_path_to_scheme_list(scheme * sc,struct astar_node * path)7634 static pointer kern_astar_path_to_scheme_list(scheme *sc, struct astar_node *path)
7635 {
7636 pointer head;
7637 pointer cell;
7638
7639 /* base case - end of path */
7640 if (!path)
7641 return sc->NIL;
7642
7643 /* create a scheme pair (x, y) */
7644 cell = _cons(sc,
7645 scm_mk_integer(sc, path->x),
7646 scm_mk_integer(sc, path->y),
7647 0);
7648
7649 /* recursively build a scheme list of pairs */
7650 head = _cons(sc,
7651 cell,
7652 kern_astar_path_to_scheme_list(sc, path->next),
7653 0);
7654
7655 /* cleanup the node */
7656 astar_node_destroy(path);
7657
7658 return head;
7659 }
7660
KERN_API_CALL(kern_obj_find_path)7661 KERN_API_CALL(kern_obj_find_path)
7662 {
7663 class Object *object;
7664 struct place *place;
7665 struct astar_node *path = NULL;
7666 struct astar_search_info as_info;
7667 pointer sc_path;
7668
7669 memset(&as_info, 0, sizeof (as_info));
7670
7671 object = (Object*)unpack_obj(sc, &args, "kern-obj-find-path");
7672 if (!object)
7673 return sc->NIL;
7674
7675 if (unpack_loc(sc, &args, &place, &as_info.x1, &as_info.y1,
7676 "kern-obj-find-path")) {
7677 return sc->NIL;
7678 }
7679
7680 /* can't pathfind between places */
7681 if (object->getPlace() != place)
7682 return sc->NIL;
7683
7684 /* find the path */
7685 as_info.x0 = object->getX();
7686 as_info.y0 = object->getY();
7687 path = place_find_path(place, &as_info, object);
7688 if (! path)
7689 return sc->NIL;
7690
7691 /* convert the path to a scheme list */
7692 sc_path = kern_astar_path_to_scheme_list(sc, path);
7693 return sc_path;
7694 }
7695
kern_build_weapon_list(scheme * sc,class Character * character,class ArmsType * weapon,int * armsIndex)7696 static pointer kern_build_weapon_list(scheme *sc,
7697 class Character *character,
7698 class ArmsType *weapon,
7699 int *armsIndex)
7700 {
7701 /* base case */
7702 if (! weapon)
7703 return sc->NIL;
7704
7705 /* recursive case */
7706 return _cons(sc,
7707 scm_mk_ptr(sc, weapon),
7708 kern_build_weapon_list(sc,
7709 character,
7710 character->getNextWeapon(armsIndex),
7711 armsIndex),
7712 0);
7713 }
7714
KERN_API_CALL(kern_char_get_weapons)7715 KERN_API_CALL(kern_char_get_weapons)
7716 {
7717 class Character *character;
7718
7719 /* unpack the character */
7720 character = (class Character*)unpack_obj(sc, &args,
7721 "kern-char-get-weapons");
7722 if (!character)
7723 return sc->NIL;
7724
7725 /* recursively enumerate the character's available weapons into a
7726 * scheme list */
7727 int armsIndex = 0;
7728 return kern_build_weapon_list(sc,
7729 character,
7730 character->enumerateWeapons(&armsIndex),
7731 &armsIndex);
7732 }
7733
7734 /**
7735 * A generic append-to-scheme-list function.
7736 */
kern_list_append(struct kern_append_info * info,void * data)7737 static void kern_list_append(struct kern_append_info *info, void *data)
7738 {
7739 /* alloc a cell */
7740 pointer cell = scm_mk_ptr(info->sc, data);
7741
7742 /* make it a list element */
7743 cell = _cons(info->sc, cell, info->sc->NIL, 0);
7744
7745 /* add it to the list */
7746 if (info->head == info->sc->NIL) {
7747 info->head = cell;
7748 info->tail = cell;
7749
7750 /* Protect the head from garbage collection. As long as the
7751 * head is protected the entire list is protected. The caller
7752 * must unprotect the head just before returning the list back
7753 * to scheme, so the collector will clean it up when the script
7754 * no longer needs it. */
7755 scm_protect(info->sc, cell);
7756
7757 } else {
7758 info->tail->_object._cons._cdr = cell;
7759 info->tail = cell;
7760 }
7761 }
7762
7763 /**
7764 * Used by kern-char-get-skills to add all the skills in a skill set to the
7765 * list.
7766 */
kern_add_skill_set(struct kern_append_info * info,int pclvl,struct skill_set * skset)7767 static void kern_add_skill_set(struct kern_append_info *info, int pclvl,
7768 struct skill_set *skset)
7769 {
7770 struct list *elem;
7771
7772 /* for each skill in the skill set */
7773 list_for_each(&skset->skills, elem) {
7774
7775 struct skill_set_entry *ssent;
7776 ssent = list_entry(elem, struct skill_set_entry, list);
7777
7778 /* is the character of sufficient level? */
7779 if (pclvl < ssent->level) {
7780 continue;
7781 }
7782
7783 kern_list_append(info, ssent->skill);
7784 }
7785 }
7786
7787 /**
7788 * A generic append-to-scheme-list function.
7789 */
kern_list_append_pointer(struct kern_append_info * info,pointer cell)7790 static void kern_list_append_pointer(struct kern_append_info *info, pointer cell)
7791 {
7792 /* make it a list element */
7793 cell = _cons(info->sc, cell, info->sc->NIL, 0);
7794
7795 /* add it to the list */
7796 if (info->head == info->sc->NIL) {
7797 info->head = cell;
7798 info->tail = cell;
7799
7800 /* Protect the head from garbage collection. As long as the
7801 * head is protected the entire list is protected. The caller
7802 * must unprotect the head just before returning the list back
7803 * to scheme, so the collector will clean it up when the script
7804 * no longer needs it. */
7805 scm_protect(info->sc, cell);
7806
7807 } else {
7808 info->tail->_object._cons._cdr = cell;
7809 info->tail = cell;
7810 }
7811 }
7812
7813 /**
7814 * A generic pagination function.
7815 * Copies one line of text to output.
7816 * output should be pre-allocated, and large enough to glom all of input if necessary
7817 * returns a pointer offset to the location the search finished at
7818 */
kern_paginate_text(char * input,char * output)7819 static char* kern_paginate_text(char *input, char *output)
7820 {
7821 int curlength = 0;
7822 char* endinput = NULL;
7823 char* endoutput = output;
7824 while (*input != 0)
7825 {
7826 if (isspace(*input))
7827 {
7828 endinput = input;
7829 endoutput = output;
7830 //printf("[ ]");
7831 }
7832 else if (*input == '^') // handle colour codes
7833 {
7834 //printf("[col:");
7835 *output=*input;
7836 input++;
7837 output++;
7838 if (*input == 0) break;
7839 if (*input != 'c')
7840 {
7841 //printf("?%c]",*input);
7842 *output=*input;
7843 input++;
7844 output++;
7845 continue;
7846 }
7847 *output=*input;
7848 input++;
7849 output++;
7850 if (*input == 0) break;
7851 if (*input == '+')
7852 {
7853 //printf("+");
7854 *output=*input;
7855 input++;
7856 output++;
7857 if (*input == 0) break;
7858 }
7859 //printf("%c]",*input);
7860 *output=*input;
7861 input++;
7862 output++;
7863 continue;
7864 }
7865 else
7866 {
7867 //printf("%c",*input);
7868 }
7869 if (curlength >= STAT_CHARS_PER_LINE)
7870 {
7871 //printf("[LEN]\n");
7872 if (endinput != NULL)
7873 {
7874 *endoutput = '\0';
7875 return (endinput + 1);
7876 }
7877 else
7878 {
7879 *output = '\0';
7880 return input;
7881 }
7882 }
7883 *output=*input;
7884 curlength++;
7885 input++;
7886 output++;
7887 }
7888 //printf("[EOS]\n");
7889 *output='\0';
7890 return input;
7891 }
7892
KERN_API_CALL(kern_ui_paginate_text)7893 KERN_API_CALL(kern_ui_paginate_text)
7894 {
7895 struct kern_append_info info;
7896
7897 /* initialize the context used by the callback to append objects */
7898 info.sc = sc;
7899 info.head = sc->NIL;
7900 info.tail = sc->NIL;
7901 info.filter = NULL;
7902 info.data = NULL;
7903
7904 while (scm_is_pair(sc, args))
7905 {
7906 char *line;
7907 if (unpack(sc, &args, "s", &line))
7908 {
7909 rt_err("kern-ui-paginate-text: bad text line");
7910 break;
7911 }
7912 // shortcut empty strings
7913 if (*line == '\0')
7914 {
7915 pointer paginated_string_element=scm_mk_string(sc,line);
7916 kern_list_append_pointer(&info, paginated_string_element);
7917 continue;
7918 }
7919
7920 char *buffer;
7921 int totallen = strlen(line);
7922 buffer = (char *)malloc((1+totallen)*sizeof(char));
7923 assert(buffer);
7924 assert(line[totallen]==0);
7925
7926 char* seek=line;
7927 while (*seek != 0)
7928 {
7929 *buffer='\0';
7930 seek = kern_paginate_text(seek,buffer);
7931 pointer paginated_string_element=scm_mk_string(sc,buffer);
7932 kern_list_append_pointer(&info, paginated_string_element);
7933 }
7934
7935 free(buffer);
7936 }
7937
7938 /* unprotect the list prior to return */
7939 if (info.head != sc->NIL)
7940 scm_unprotect(sc, info.head);
7941
7942 return info.head;
7943 }
7944
7945
KERN_API_CALL(kern_char_get_skills)7946 KERN_API_CALL(kern_char_get_skills)
7947 {
7948 class Character *subj;
7949 struct kern_append_info info;
7950
7951 /* unpack the character */
7952 subj = (class Character*)unpack_obj(sc, &args,
7953 "kern-char-get-skills");
7954 if (!subj) {
7955 return sc->NIL;
7956 }
7957
7958 /* initialize the relevant list-building info */
7959 memset(&info, 0, sizeof(info));
7960 info.sc = sc;
7961 info.head = sc->NIL;
7962 info.tail = sc->NIL;
7963
7964 /* add species skills */
7965 if (subj->species
7966 && subj->species->skills) {
7967 kern_add_skill_set(&info, subj->getLevel(),
7968 subj->species->skills);
7969 }
7970
7971 /* add occupation skills */
7972 if (subj->occ
7973 && subj->occ->skills) {
7974 kern_add_skill_set(&info, subj->getLevel(),
7975 subj->occ->skills);
7976 }
7977
7978 /* allow the list to be gc'd when the script is done with it */
7979 if (info.head != sc->NIL) {
7980 scm_unprotect(sc, info.head);
7981 }
7982
7983 return info.head;
7984 }
7985
kern_build_arm_list(scheme * sc,class Character * character,class ArmsType * arm,int * armsIndex)7986 static pointer kern_build_arm_list(scheme *sc,
7987 class Character *character,
7988 class ArmsType *arm,
7989 int *armsIndex)
7990 {
7991 /* base case */
7992 if (! arm)
7993 return sc->NIL;
7994
7995 /* recursive case */
7996 return _cons(sc,
7997 scm_mk_ptr(sc, arm),
7998 kern_build_arm_list(sc,
7999 character,
8000 character->getNextArms(armsIndex),
8001 armsIndex),
8002 0);
8003 }
8004
KERN_API_CALL(kern_char_get_arms)8005 KERN_API_CALL(kern_char_get_arms)
8006 {
8007 class Character *character;
8008
8009 /* unpack the character */
8010 character = (class Character*)unpack_obj(sc, &args,
8011 "kern-char-get-arms");
8012 if (!character)
8013 return sc->NIL;
8014
8015 /* recursively enumerate the character's available arms into a
8016 * scheme list */
8017 int armsIndex=0;
8018 return kern_build_arm_list(sc,
8019 character,
8020 character->enumerateArms(&armsIndex),
8021 &armsIndex);
8022 }
8023
KERN_API_CALL(kern_char_arm_self)8024 KERN_API_CALL(kern_char_arm_self)
8025 {
8026 class Character *character;
8027
8028 /* unpack the character */
8029 character = (class Character*)unpack_obj(sc, &args,
8030 "kern-char-get-weapons");
8031 if (!character)
8032 return sc->NIL;
8033
8034 /* recursively enumerate the character's available weapons into a
8035 * scheme list */
8036 character->armThyself();
8037
8038 return scm_mk_ptr(sc, character);
8039 }
8040
kern_build_container_list(scheme * sc,class Container * container,struct inv_entry * ie)8041 static pointer kern_build_container_list(scheme *sc,
8042 class Container *container,
8043 struct inv_entry *ie)
8044 {
8045 pointer cell;
8046
8047 /* base case */
8048 if (! ie)
8049 return sc->NIL;
8050
8051 /* make a type/count pair */
8052 cell = _cons(sc,
8053 scm_mk_ptr(sc, ie->type),
8054 scm_mk_integer(sc, ie->count),
8055 0);
8056
8057 /* recursively build a list of such pairs */
8058 return _cons(sc,
8059 cell,
8060 kern_build_container_list(sc,
8061 container,
8062 container->next(ie, NULL)),
8063 0);
8064 }
8065
KERN_API_CALL(kern_char_get_inventory)8066 KERN_API_CALL(kern_char_get_inventory)
8067 {
8068 class Container *container;
8069 class Character *character;
8070
8071 /* unpack the character */
8072 character = (class Character*)unpack_obj(sc, &args,
8073 "kern-char-get-inventory");
8074 if (!character)
8075 return sc->NIL;
8076
8077 /* grab it's inventory container */
8078 container = character->getInventoryContainer();
8079 if (!container)
8080 return sc->NIL;
8081
8082 /* enumerate its contents into a scheme list */
8083 return kern_build_container_list(sc, container, container->first(NULL));
8084 }
8085
KERN_API_CALL(kern_char_get_hp)8086 KERN_API_CALL(kern_char_get_hp)
8087 {
8088 class Character *character;
8089
8090 /* unpack the character */
8091 character = (class Character*)unpack_obj(sc, &args,
8092 "kern-char-get-hp");
8093 if (!character)
8094 return sc->NIL;
8095
8096 return scm_mk_integer(sc, character->getHp());
8097 }
8098
KERN_API_CALL(kern_obj_get_hp)8099 KERN_API_CALL(kern_obj_get_hp)
8100 {
8101 class Object *kobj;
8102
8103 /* unpack the character */
8104 kobj = (class Object*)unpack_obj(sc, &args,
8105 "kern-obj-get-hp");
8106 if (!kobj)
8107 return sc->NIL;
8108
8109 return scm_mk_integer(sc, kobj->getHp());
8110 }
8111
KERN_API_CALL(kern_char_get_max_hp)8112 KERN_API_CALL(kern_char_get_max_hp)
8113 {
8114 class Character *character;
8115
8116 /* unpack the character */
8117 character = (class Character*)unpack_obj(sc, &args,
8118 "kern-char-get-max-hp");
8119 if (!character)
8120 return sc->NIL;
8121
8122 return scm_mk_integer(sc, character->getMaxHp());
8123 }
8124
KERN_API_CALL(kern_char_get_max_mana)8125 KERN_API_CALL(kern_char_get_max_mana)
8126 {
8127 class Character *character;
8128
8129 /* unpack the character */
8130 character = (class Character*)unpack_obj(sc, &args,
8131 "kern-char-get-max-mana");
8132 if (!character)
8133 return sc->NIL;
8134
8135 return scm_mk_integer(sc, character->getMaxMana());
8136 }
8137
KERN_API_CALL(kern_char_get_level)8138 KERN_API_CALL(kern_char_get_level)
8139 {
8140 class Character *character;
8141
8142 /* unpack the character */
8143 character = (class Character*)unpack_obj(sc, &args, "kern-char-get-level");
8144 if (!character)
8145 return sc->NIL;
8146
8147 return scm_mk_integer(sc, character->getLevel());
8148 }
8149
8150
KERN_API_CALL(kern_char_get_experience_value)8151 KERN_API_CALL(kern_char_get_experience_value)
8152 {
8153 class Character *character;
8154
8155 /* unpack the character */
8156 character = (class Character*)unpack_obj(sc, &args, "kern-char-get-level");
8157 if (!character)
8158 return sc->NIL;
8159
8160 return scm_mk_integer(sc, character->getExperienceValue());
8161 }
8162
KERN_API_CALL(kern_char_set_level)8163 KERN_API_CALL(kern_char_set_level)
8164 {
8165 class Character *character;
8166 int val = 0;
8167
8168 /* unpack the character */
8169 character = (class Character*)unpack_obj(sc, &args, "kern-char-set-level");
8170 if (!character)
8171 return sc->NIL;
8172
8173 if (unpack(sc, &args, "d", &val)) {
8174 rt_err("kern-char-set-level: bad args");
8175 return sc->NIL;
8176 }
8177
8178 character->setLevel(val);
8179 return scm_mk_ptr(sc, character);
8180 }
8181
KERN_API_CALL(kern_char_get_strength)8182 KERN_API_CALL(kern_char_get_strength)
8183 {
8184 class Character *character;
8185
8186 /* unpack the character */
8187 character = (class Character*)unpack_obj(sc, &args, "kern-char-get-strength");
8188 if (!character)
8189 return sc->NIL;
8190
8191 return scm_mk_integer(sc, character->getStrength());
8192 }
8193
KERN_API_CALL(kern_char_get_dexterity)8194 KERN_API_CALL(kern_char_get_dexterity)
8195 {
8196 class Character *character;
8197
8198 /* unpack the character */
8199 character = (class Character*)unpack_obj(sc, &args, "kern-char-get-dexterity");
8200 if (!character)
8201 return sc->NIL;
8202
8203 return scm_mk_integer(sc, character->getDexterity());
8204 }
8205
KERN_API_CALL(kern_char_get_intelligence)8206 KERN_API_CALL(kern_char_get_intelligence)
8207 {
8208 class Character *character;
8209
8210 /* unpack the character */
8211 character = (class Character*)unpack_obj(sc, &args, "kern-char-get-intelligence");
8212 if (!character)
8213 return sc->NIL;
8214
8215 return scm_mk_integer(sc, character->getIntelligence());
8216
8217 }
8218
KERN_API_CALL(kern_char_get_base_strength)8219 KERN_API_CALL(kern_char_get_base_strength)
8220 {
8221 class Character *character;
8222
8223 /* unpack the character */
8224 character = (class Character*)unpack_obj(sc, &args, "kern-char-get-strength");
8225 if (!character)
8226 return sc->NIL;
8227
8228 return scm_mk_integer(sc, character->getBaseStrength());
8229 }
8230
KERN_API_CALL(kern_char_get_base_dexterity)8231 KERN_API_CALL(kern_char_get_base_dexterity)
8232 {
8233 class Character *character;
8234
8235 /* unpack the character */
8236 character = (class Character*)unpack_obj(sc, &args, "kern-char-get-dexterity");
8237 if (!character)
8238 return sc->NIL;
8239
8240 return scm_mk_integer(sc, character->getBaseDexterity());
8241 }
8242
KERN_API_CALL(kern_char_get_base_intelligence)8243 KERN_API_CALL(kern_char_get_base_intelligence)
8244 {
8245 class Character *character;
8246
8247 /* unpack the character */
8248 character = (class Character*)unpack_obj(sc, &args, "kern-char-get-intelligence");
8249 if (!character)
8250 return sc->NIL;
8251
8252 return scm_mk_integer(sc, character->getBaseIntelligence());
8253
8254 }
8255
KERN_API_CALL(kern_char_set_strength)8256 KERN_API_CALL(kern_char_set_strength)
8257 {
8258 class Character *character;
8259 int val = 0;
8260
8261 /* unpack the character */
8262 character = (class Character*)unpack_obj(sc, &args, "kern-char-set-strength");
8263 if (!character)
8264 return sc->NIL;
8265
8266 if (unpack(sc, &args, "d", &val)) {
8267 rt_err("kern-char-set-strength: bad args");
8268 return sc->NIL;
8269 }
8270
8271 character->setStrength(val);
8272 return scm_mk_ptr(sc, character);
8273 }
8274
KERN_API_CALL(kern_char_set_dexterity)8275 KERN_API_CALL(kern_char_set_dexterity)
8276 {
8277 class Character *character;
8278 int val = 0;
8279
8280 /* unpack the character */
8281 character = (class Character*)unpack_obj(sc, &args, "kern-char-set-dexterity");
8282 if (!character)
8283 return sc->NIL;
8284
8285 if (unpack(sc, &args, "d", &val)) {
8286 rt_err("kern-char-set-dexterity: bad args");
8287 return sc->NIL;
8288 }
8289
8290 character->setDexterity(val);
8291 return scm_mk_ptr(sc, character);
8292 }
8293
KERN_API_CALL(kern_char_set_intelligence)8294 KERN_API_CALL(kern_char_set_intelligence)
8295 {
8296 class Character *character;
8297 int val = 0;
8298
8299 /* unpack the character */
8300 character = (class Character*)unpack_obj(sc, &args, "kern-char-set-intelligence");
8301 if (!character)
8302 return sc->NIL;
8303
8304 if (unpack(sc, &args, "d", &val)) {
8305 rt_err("kern-char-set-intelligence: bad args");
8306 return sc->NIL;
8307 }
8308
8309 character->setIntelligence(val);
8310 return scm_mk_ptr(sc, character);
8311 }
8312
KERN_API_CALL(kern_char_get_speed)8313 KERN_API_CALL(kern_char_get_speed)
8314 {
8315 class Character *character;
8316
8317 /* unpack the character */
8318 character = (class Character*)unpack_obj(sc, &args, "kern-char-get-speed");
8319 if (!character)
8320 return sc->NIL;
8321
8322 return scm_mk_integer(sc, character->getSpeed());
8323 }
8324
KERN_API_CALL(kern_char_set_speed)8325 KERN_API_CALL(kern_char_set_speed)
8326 {
8327 class Character *character;
8328 int val = 0;
8329
8330 /* unpack the character */
8331 character = (class Character*)unpack_obj(sc, &args, "kern-char-set-speed");
8332 if (!character)
8333 return sc->NIL;
8334
8335 if (unpack(sc, &args, "d", &val)) {
8336 rt_err("kern-char-set-speed: bad args");
8337 return sc->NIL;
8338 }
8339
8340 character->setSpeed(val);
8341 return scm_mk_ptr(sc, character);
8342 }
8343
KERN_API_CALL(kern_obj_get_ap)8344 KERN_API_CALL(kern_obj_get_ap)
8345 {
8346 class Object *object;
8347
8348 /* unpack the object */
8349 object = (class Object*)unpack_obj(sc, &args, "kern-obj-get-ap");
8350 if (!object)
8351 return sc->NIL;
8352
8353 return scm_mk_integer(sc, object->getActionPoints());
8354 }
8355
KERN_API_CALL(kern_obj_get_count)8356 KERN_API_CALL(kern_obj_get_count)
8357 {
8358 class Object *object;
8359
8360 /* unpack the object */
8361 object = (class Object*)unpack_obj(sc, &args, "kern-obj-get-count");
8362 if (!object)
8363 return sc->NIL;
8364
8365 return scm_mk_integer(sc, object->getCount());
8366 }
8367
KERN_API_CALL(kern_arms_type_get_range)8368 KERN_API_CALL(kern_arms_type_get_range)
8369 {
8370 class ArmsType *type;
8371
8372 /* unpack the type (should be an arms type, but no way to safely
8373 * tell) */
8374 if (unpack(sc, &args, "p", &type)) {
8375 rt_err("kern-arms-type-get-range");
8376 return scm_mk_integer(sc, 0);
8377 }
8378
8379 if (! type) {
8380 rt_err("kern-arms-type-get-range: null type");
8381 return scm_mk_integer(sc, 0);
8382 }
8383
8384 /* get the range */
8385 return scm_mk_integer(sc, type->getRange());
8386 }
8387
KERN_API_CALL(kern_arms_type_get_ammo_type)8388 KERN_API_CALL(kern_arms_type_get_ammo_type)
8389 {
8390 class ArmsType *type;
8391 class ObjectType *ammo;
8392
8393 /* unpack the type (should be an arms type, but no way to safely
8394 * tell) */
8395 if (unpack(sc, &args, "p", &type)) {
8396 rt_err("kern-char-arms-type");
8397 return sc->NIL;
8398 }
8399
8400 /* get the ammo type */
8401 ammo = type->getAmmoType();
8402
8403 /* return it, if any */
8404 return ammo ? scm_mk_ptr(sc, ammo) : sc->NIL;
8405 }
8406
KERN_API_CALL(kern_arms_type_set_mmode)8407 KERN_API_CALL(kern_arms_type_set_mmode)
8408 {
8409 class ArmsType *type;
8410 struct mmode *mmode;
8411
8412 /* unpack the type (should be an arms type, but no way to safely
8413 * tell) */
8414 if (unpack(sc, &args, "pp", &type, &mmode)) {
8415 rt_err("kern-arms-type-set-mmode");
8416 return sc->NIL;
8417 }
8418
8419 if (! type) {
8420 rt_err("kern-arms-type-set-mmode: null type");
8421 return sc->NIL;
8422 }
8423
8424 type->setMovementMode(mmode);
8425
8426 return sc->NIL;
8427 }
8428
8429
KERN_API_CALL(kern_arms_type_fire_in_direction)8430 KERN_API_CALL(kern_arms_type_fire_in_direction)
8431 {
8432 class ArmsType *type;
8433 struct place *place;
8434 int startx, starty;
8435 int dx,dy;
8436
8437 /* unpack the type (should be an arms type, but no way to safely
8438 * tell) */
8439 if (unpack(sc, &args, "p", &type)) {
8440 rt_err("kern_arms_type_fire_in_direction");
8441 return sc->NIL;
8442 }
8443
8444 if (unpack_loc(sc, &args, &place, &startx,&starty, "kern_arms_type_fire_in_direction"))
8445 return sc->NIL;
8446
8447 if (unpack(sc, &args, "dd", &dx,&dy)) {
8448 rt_err("kern_arms_type_fire_in_direction");
8449 return sc->NIL;
8450 }
8451
8452 if (! type) {
8453 rt_err("kern_arms_type_fire_in_direction: null type");
8454 return sc->NIL;
8455 }
8456
8457 if (! place) {
8458 rt_err("kern_arms_type_fire_in_direction: null place");
8459 return sc->NIL;
8460 }
8461
8462 type->fireInDirection(place, startx, starty, dx, dy, NULL);
8463
8464 return sc->NIL;
8465 }
8466
KERN_API_CALL(kern_obj_move)8467 KERN_API_CALL(kern_obj_move)
8468 {
8469 class Object *object;
8470 int dx, dy;
8471 enum MoveResult result;
8472
8473 object = (Object*)unpack_obj(sc, &args, "kern-obj-move");
8474 if (!object)
8475 return sc->F;
8476
8477 if (unpack(sc, &args, "dd", &dx, &dy))
8478 {
8479 rt_err("kern-obj-move: bad args");
8480 return sc->F;
8481 }
8482
8483 //moves can have nasty consequences,
8484 //so keep our own ref to the object for a bit
8485 obj_inc_ref(object);
8486 result = object->move(dx, dy);
8487 obj_dec_ref(object);
8488
8489 switch (result)
8490 {
8491 case MovedOk:
8492 case ExitedMap:
8493 case SwitchedOccupants:
8494 return sc->T;
8495 break;
8496 default:
8497 return sc->F;
8498 }
8499 }
8500
KERN_API_CALL(kern_get_ticks)8501 KERN_API_CALL(kern_get_ticks)
8502 {
8503 return scm_mk_integer(sc, SDL_GetTicks());
8504 }
8505
KERN_API_CALL(kern_ticks_per_turn)8506 KERN_API_CALL(kern_ticks_per_turn)
8507 {
8508 return scm_mk_integer(sc, session_ticks_per_turn());
8509 }
8510
kern_obj_is_type(class Object * obj,struct kern_append_info * info)8511 static int kern_obj_is_type(class Object *obj, struct kern_append_info *info)
8512 {
8513 return (obj->getObjectType() == (class ObjectType*)info->data);
8514 }
8515
kern_append_loc(Object * obj,void * data)8516 static void kern_append_loc(Object *obj, void *data)
8517 {
8518 pointer cell;
8519 struct kern_append_info *info;
8520
8521 info = (struct kern_append_info *)data;
8522
8523 /* If there is a filter then use it */
8524 if (info->filter != NULL)
8525
8526 /* If the filter rejects the object then don't append it */
8527 if (! info->filter(obj, info))
8528 return;
8529
8530 cell = scm_mk_loc(info->sc, obj->getPlace(), obj->getX(), obj->getY());
8531 cell = _cons(info->sc, cell, info->sc->NIL, 0);
8532
8533 if (info->head == info->sc->NIL) {
8534 info->head = cell;
8535 info->tail = cell;
8536 scm_protect(info->sc, cell);
8537 } else {
8538 info->tail->_object._cons._cdr = cell;
8539 info->tail = cell;
8540 }
8541 }
8542
KERN_API_CALL(kern_search_rect)8543 KERN_API_CALL(kern_search_rect)
8544 {
8545 struct place *place;
8546 int ulc_x, ulc_y, w, h, lrc_x, lrc_y, x, y;
8547 struct terrain *ter;
8548 class ObjectType *objtype;
8549 struct kern_append_info info;
8550
8551 /* unpack the args */
8552 if (unpack(sc, &args, "pddddpp", &place, &ulc_x, &ulc_y, &w, &h,
8553 &ter, &objtype)) {
8554 rt_err("kern-search-rect: bad args");
8555 return sc->NIL;
8556 }
8557
8558 /* check the place */
8559 if (! place) {
8560 rt_err("kern-search-rect: null place");
8561 return sc->NIL;
8562 }
8563
8564 /* clip the rectangle */
8565 lrc_x = ulc_x + w;
8566 lrc_y = ulc_y + h;
8567 place_clip_to_map(place, &ulc_x, &ulc_y);
8568 place_clip_to_map(place, &lrc_x, &lrc_y);
8569
8570 /* prepare to search */
8571 info.sc = sc;
8572 info.head = sc->NIL;
8573 info.tail = sc->NIL;
8574 info.filter = kern_obj_is_type;
8575 info.data = objtype;
8576
8577 /* iterate over the tiles */
8578 for (y = ulc_y; y < lrc_y; y++) {
8579 for (x = ulc_x; x < lrc_x; x++) {
8580
8581 /* check if terrain matches */
8582 if (place_get_terrain(place, x, y) == ter) {
8583
8584 pointer cell = scm_mk_loc(info.sc,
8585 place, x, y);
8586 cell = _cons(info.sc, cell, info.sc->NIL, 0);
8587
8588 if (info.head == info.sc->NIL) {
8589 info.head = cell;
8590 info.tail = cell;
8591 scm_protect(sc, cell);
8592 } else {
8593 info.tail->_object._cons._cdr = cell;
8594 info.tail = cell;
8595 }
8596
8597
8598 } else {
8599
8600 /* check for an object match */
8601 place_for_each_object_at(place, x, y,
8602 kern_append_loc,
8603 &info);
8604 }
8605 }
8606 }
8607
8608 /* unprotect the list prior to returning */
8609 if (info.head != sc->NIL)
8610 scm_unprotect(sc, info.head);
8611
8612 return info.head;
8613 }
8614
KERN_API_CALL(kern_search_rect_for_obj_type)8615 KERN_API_CALL(kern_search_rect_for_obj_type)
8616 {
8617 struct place *place;
8618 int ulc_x, ulc_y, w, h, lrc_x, lrc_y, x, y;
8619 class ObjectType *objtype;
8620 struct kern_append_info info;
8621
8622 /* unpack the args */
8623 if (unpack(sc, &args, "pddddp", &place, &ulc_x, &ulc_y, &w, &h,
8624 &objtype)) {
8625 rt_err("kern-search-rect-for-obj-type: bad args");
8626 return sc->NIL;
8627 }
8628
8629 /* check the place */
8630 if (! place) {
8631 rt_err("kern-search-rect-for-obj-type: null place");
8632 return sc->NIL;
8633 }
8634
8635 /* clip the rectangle */
8636 lrc_x = ulc_x + w;
8637 lrc_y = ulc_y + h;
8638 place_clip_to_map(place, &ulc_x, &ulc_y);
8639 place_clip_to_map(place, &lrc_x, &lrc_y);
8640
8641 /* prepare to search */
8642 info.sc = sc;
8643 info.head = sc->NIL;
8644 info.tail = sc->NIL;
8645 info.filter = kern_obj_is_type;
8646 info.data = objtype;
8647
8648 /* iterate over the tiles */
8649 for (y = ulc_y; y < lrc_y; y++) {
8650 for (x = ulc_x; x < lrc_x; x++) {
8651
8652 /* check for an object match */
8653 place_for_each_object_at(place, x, y,
8654 kern_append_loc,
8655 &info);
8656 }
8657 }
8658
8659 /* unprotect the list prior to returning */
8660 if (info.head != sc->NIL)
8661 scm_unprotect(sc, info.head);
8662
8663 return info.head;
8664 }
8665
KERN_API_CALL(kern_search_rect_for_terrain)8666 KERN_API_CALL(kern_search_rect_for_terrain)
8667 {
8668 struct place *place;
8669 int ulc_x, ulc_y, w, h, lrc_x, lrc_y, x, y;
8670 struct terrain *ter;
8671 pointer cell;
8672 struct kern_append_info info;
8673
8674 /* unpack the args */
8675 if (unpack(sc, &args, "pddddp", &place, &ulc_x, &ulc_y, &w, &h,
8676 &ter)) {
8677 rt_err("kern-search-rect-for-terrain: bad args");
8678 return sc->NIL;
8679 }
8680
8681 /* check the place */
8682 if (! place) {
8683 rt_err("kern-search-rect-for-terrain: null place");
8684 return sc->NIL;
8685 }
8686
8687 /* clip the rectangle */
8688 lrc_x = ulc_x + w;
8689 lrc_y = ulc_y + h;
8690 place_clip_to_map(place, &ulc_x, &ulc_y);
8691 place_clip_to_map(place, &lrc_x, &lrc_y);
8692
8693 /* prepare to search */
8694 info.sc = sc;
8695 info.head = sc->NIL;
8696 info.tail = sc->NIL;
8697 info.filter = NULL;
8698
8699 /* iterate over the tiles */
8700 for (y = ulc_y; y < lrc_y; y++) {
8701 for (x = ulc_x; x < lrc_x; x++) {
8702
8703 /* check if terrain matches */
8704 if (place_get_terrain(place, x, y) != ter)
8705 continue;
8706
8707 /* make a scheme-style loc */
8708 cell = scm_mk_loc(info.sc, place, x, y);
8709
8710 /* make it a list element */
8711 cell = _cons(info.sc, cell, info.sc->NIL, 0);
8712
8713 /* append it to the list */
8714 if (info.head == info.sc->NIL) {
8715 info.head = cell;
8716 info.tail = cell;
8717 } else {
8718 info.tail->_object._cons._cdr = cell;
8719 info.tail = cell;
8720 }
8721 }
8722 }
8723
8724 /* unprotect the list prior to returning */
8725 if (info.head != sc->NIL)
8726 scm_unprotect(sc, info.head);
8727
8728 /* return the list of locations */
8729 return info.head;
8730 }
8731
8732
KERN_API_CALL(kern_fold_rect)8733 KERN_API_CALL(kern_fold_rect)
8734 {
8735 struct place *place;
8736 int ulc_x, ulc_y, w, h, lrc_x, lrc_y, x, y;
8737 pointer proc;
8738 pointer val;
8739
8740 /* unpack the args */
8741 if (unpack(sc, &args, "pdddd", &place, &ulc_x, &ulc_y, &w, &h)) {
8742 rt_err("kern-fold-rect: bad args");
8743 return sc->NIL;
8744 }
8745
8746 /* check the place */
8747 if (! place) {
8748 rt_err("kern-fold-rect: null place");
8749 return sc->NIL;
8750 }
8751
8752 /* get a ptr to the procedure */
8753 if (! scm_is_pair(sc, args)) {
8754 rt_err("kern-fold-rect: no proc arg");
8755 return sc->NIL;
8756 }
8757 proc = scm_car(sc, args);
8758 args = scm_cdr(sc, args);
8759
8760 /* get a ptr to the initial value */
8761 if (! scm_is_pair(sc, args)) {
8762 rt_err("kern-fold-rect: no proc arg");
8763 return sc->NIL;
8764 }
8765 val = scm_car(sc, args);
8766 args = scm_cdr(sc, args);
8767
8768 /* clip the rectangle */
8769 lrc_x = ulc_x + w;
8770 lrc_y = ulc_y + h;
8771 place_clip_to_map(place, &ulc_x, &ulc_y);
8772 place_clip_to_map(place, &lrc_x, &lrc_y);
8773
8774 /* iterate over the tiles */
8775 for (y = ulc_y; y < lrc_y; y++) {
8776 for (x = ulc_x; x < lrc_x; x++) {
8777
8778 /* val may be unreferenced by the script, so protect it
8779 * while we allocate cells (I don't think it matters if
8780 * val is immutable, but we could always test that) */
8781 scm_protect(sc, val);
8782
8783 /* make the location for the closure callback */
8784 pointer loc = scm_mk_loc(sc, place, x, y);
8785
8786 /* NOTE: don't need to protect the loc, the args to
8787 * _cons are always protected within it */
8788
8789 /* make the arg list (val, loc) */
8790 pointer pargs = _cons(sc, val,
8791 _cons(sc, loc, sc->NIL, 0), 0);
8792
8793 /* done with allocations, so val does not need
8794 * protection any more */
8795 scm_unprotect(sc, val);
8796
8797 /* call the procedure, storing the return val for
8798 * later */
8799 val = scheme_call(sc, proc, pargs);
8800 }
8801 }
8802
8803 return val;
8804 }
8805
KERN_API_CALL(kern_player_get_gold)8806 KERN_API_CALL(kern_player_get_gold)
8807 {
8808 return scm_mk_integer(sc, player_party->gold);
8809 }
8810
KERN_API_CALL(kern_player_set_gold)8811 KERN_API_CALL(kern_player_set_gold)
8812 {
8813 int val;
8814
8815 if (unpack(sc, &args, "d", &val)) {
8816 rt_err("kern-player-set-gold: bad args");
8817 return sc->F;
8818 }
8819
8820 player_party->gold = val;
8821 foogodRepaint();
8822 return sc->T;
8823 }
8824
KERN_API_CALL(kern_player_get_food)8825 KERN_API_CALL(kern_player_get_food)
8826 {
8827 return scm_mk_integer(sc, player_party->food);
8828 }
8829
KERN_API_CALL(kern_player_set_food)8830 KERN_API_CALL(kern_player_set_food)
8831 {
8832 int val;
8833
8834 if (unpack(sc, &args, "d", &val)) {
8835 rt_err("kern-player-set-food: bad args");
8836 return sc->F;
8837 }
8838
8839 player_party->food = val;
8840 foogodRepaint();
8841 return sc->T;
8842 }
8843
KERN_API_CALL(kern_begin_combat)8844 KERN_API_CALL(kern_begin_combat)
8845 {
8846 struct move_info info;
8847 struct combat_info cinfo;
8848 class Party *party;
8849 struct place *place;
8850 int x, y;
8851
8852 if (unpack_loc(sc, &args, &place, &x, &y, "kern-begin-combat")) {
8853 return sc->NIL;
8854 }
8855
8856 party = (class Party*)unpack_obj(sc, &args, "kern-begin-combat");
8857 if (!party)
8858 return sc->NIL;
8859
8860 /* Combat expects the npc party to have valid coords, whereas I don't
8861 * expect the script to always put the npc party on the map before
8862 * calling this function, so force the location of the npc party to the
8863 * location specified. */
8864 party->setPlace(place);
8865 party->setX(x);
8866 party->setY(y);
8867
8868 memset(&info, 0, sizeof(info));
8869 info.place = place;
8870 info.x = x;
8871 info.y = y;
8872 info.dx = party->getDx();
8873 info.dy = party->getDy();
8874 info.px = player_party->getX();
8875 info.py = player_party->getY();
8876 info.npc_party = party;
8877
8878 /* If the npc party has a null or invalid direction vector (this is the
8879 * case with an ambush) then use the opposite of the player's direction
8880 * vector. */
8881 if ((!info.dx && !info.dy) ||
8882 (info.dx && info.dy)) {
8883 info.dx = - player_party->getDx();
8884 info.dy = - player_party->getDy();
8885 }
8886
8887 memset(&cinfo, 0, sizeof(cinfo));
8888 cinfo.defend = true;
8889 cinfo.move = &info;
8890
8891 combat_enter(&cinfo);
8892 return sc->T;
8893 }
8894
KERN_API_CALL(kern_ambush_while_camping)8895 KERN_API_CALL(kern_ambush_while_camping)
8896 {
8897 class Party *party;
8898 int dx, dy;
8899 struct place *place;
8900
8901 /* we need to be in town or wilderness combat for this to work; this
8902 * will leak memory if it fails and the caller does not destroy the
8903 * party */
8904 if (place_is_wilderness(Place)) {
8905 rt_err("kern-ambush-while-camping: not in combat");
8906 return sc->F;
8907 }
8908
8909 /* unpack the npc party */
8910 party = (class Party*)unpack_obj(sc, &args, "kern-ambush-while-camping");
8911 if (!party)
8912 return sc->F;
8913
8914 if (unpack(sc, &args, "p", &place)) {
8915 rt_err("kern-ambush-while-camping: bad args");
8916 return sc->F;
8917 }
8918
8919 if (! place) {
8920 rt_err("kern-ambush-while-camping: null place");
8921 return sc->F;
8922 }
8923
8924 /* Workaround for 1808708: if both the player and npc party are in
8925 * vehicles then don't do the normal ambush routine (the combat map
8926 * will be wrong). Instead, let's just wake the player up. */
8927 if (party->getVehicle()
8928 && player_party->getVehicle()) {
8929
8930 log_begin(0);
8931 Session->subject = player_party;
8932 party->describe();
8933 log_continue(" approaches!");
8934 log_end(0);
8935
8936 player_party->endCamping();
8937 player_party->removeMembers();
8938 return sc->T;
8939 }
8940
8941 /* If the npc party has a null or invalid direction vector then
8942 * generate a random one. */
8943 dx = party->getDx();
8944 dy = party->getDy();
8945 while (! dx && ! dy) {
8946 /* gmcnutt: the following is not random. Was there a reason for
8947 * it? */
8948 //dx = - player_party->getDx();
8949 //dy = - player_party->getDy();
8950 dx = (rand() % 3) - 1;
8951 dy = (rand() % 3) - 1;
8952 }
8953
8954 /* Partial bugfix for 1612006: If the player is on impassable terrain,
8955 * and the npc is in a vehicle, disembark first, and move them directly
8956 * over the player's location. This prevents ships from coming ashore
8957 * onto your camping map (and bringing part of the ocean with them). */
8958 if (! place_is_passable(player_party->getPlace(),
8959 player_party->getX(),
8960 player_party->getY(),
8961 party, 0)
8962 && party->getVehicle()) {
8963 int newx = player_party->getX();
8964 int newy = player_party->getY();
8965 party->disembark();
8966 place_move_object(party->getPlace(), party, newx, newy);
8967 party->setX(newx);
8968 party->setY(newy);
8969 }
8970
8971 if (combat_add_party(party, dx, dy, 0, place, 0, 0)) {
8972 player_party->ambushWhileCamping();
8973 return sc->T;
8974 }
8975 return sc->F;
8976 }
8977
8978 /*
8979 * kern_being_pathfind_to -- wrapper for Being::pathfindTo
8980 */
KERN_API_CALL(kern_being_pathfind_to)8981 KERN_API_CALL(kern_being_pathfind_to)
8982 {
8983 class Being *being;
8984 struct place *place;
8985 int x, y;
8986
8987 /* unpack being */
8988 being = (class Being*)unpack_obj(sc, &args, "kern-being-pathfind-to");
8989 if (! being)
8990 return sc->F;
8991
8992 /* unpack destination */
8993 if (unpack_loc(sc, &args, &place, &x, &y, "kern-being-pathfind-to"))
8994 return sc->F;
8995
8996 //moves can have nasty consequences,
8997 //so keep our own ref to the object for a bit
8998 obj_inc_ref(being);
8999
9000
9001 /* pathfind */
9002 if (being->pathfindTo(place, x, y))
9003 {
9004 obj_dec_ref(being);
9005 return sc->T;
9006 }
9007 obj_dec_ref(being);
9008 return sc->F;
9009 }
9010
KERN_API_CALL(kern_get_player)9011 KERN_API_CALL(kern_get_player)
9012 {
9013 return scm_mk_ptr(sc, player_party);
9014 }
9015
KERN_API_CALL(kern_species_get_hp_mod)9016 KERN_API_CALL(kern_species_get_hp_mod)
9017 {
9018 struct species *species;
9019
9020 if (unpack(sc, &args, "p", &species)) {
9021 rt_err("kern-species-get-hp-mod: bad args");
9022 return scm_mk_integer(sc, 0);
9023 }
9024
9025 if (! species) {
9026 rt_err("kern-species-get-hp-mod: null species");
9027 return scm_mk_integer(sc, 0);
9028 }
9029
9030 return scm_mk_integer(sc, species->hp_mod);
9031 }
9032
KERN_API_CALL(kern_species_get_hp_mult)9033 KERN_API_CALL(kern_species_get_hp_mult)
9034 {
9035 struct species *species;
9036
9037 if (unpack(sc, &args, "p", &species)) {
9038 rt_err("kern-species-get-hp-mult: bad args");
9039 return scm_mk_integer(sc, 0);
9040 }
9041
9042 if (! species) {
9043 rt_err("kern-species-get-hp-mult: null species");
9044 return scm_mk_integer(sc, 0);
9045 }
9046
9047 return scm_mk_integer(sc, species->hp_mult);
9048 }
9049
KERN_API_CALL(kern_species_get_mp_mod)9050 KERN_API_CALL(kern_species_get_mp_mod)
9051 {
9052 struct species *species;
9053
9054 if (unpack(sc, &args, "p", &species)) {
9055 rt_err("kern-species-get-mp-mod: bad args");
9056 return scm_mk_integer(sc, 0);
9057 }
9058
9059 if (! species) {
9060 rt_err("kern-species-get-mp-mod: null species");
9061 return scm_mk_integer(sc, 0);
9062 }
9063
9064 return scm_mk_integer(sc, species->mp_mod);
9065 }
9066
KERN_API_CALL(kern_species_get_mp_mult)9067 KERN_API_CALL(kern_species_get_mp_mult)
9068 {
9069 struct species *species;
9070
9071 if (unpack(sc, &args, "p", &species)) {
9072 rt_err("kern-species-get-mp-mult: bad args");
9073 return scm_mk_integer(sc, 0);
9074 }
9075
9076 if (! species) {
9077 rt_err("kern-species-get-mp-mult: null species");
9078 return scm_mk_integer(sc, 0);
9079 }
9080
9081 return scm_mk_integer(sc, species->mp_mult);
9082 }
9083
KERN_API_CALL(kern_occ_get_hp_mod)9084 KERN_API_CALL(kern_occ_get_hp_mod)
9085 {
9086 struct occ *occ;
9087
9088 if (unpack(sc, &args, "p", &occ)) {
9089 rt_err("kern-occ-get-hp-mod: bad args");
9090 return scm_mk_integer(sc, 0);
9091 }
9092
9093 if (! occ) {
9094 rt_err("kern-occ-get-hp-mod: null occ");
9095 return scm_mk_integer(sc, 0);
9096 }
9097
9098 return scm_mk_integer(sc, occ->hp_mod);
9099 }
9100
KERN_API_CALL(kern_occ_get_hp_mult)9101 KERN_API_CALL(kern_occ_get_hp_mult)
9102 {
9103 struct occ *occ;
9104
9105 if (unpack(sc, &args, "p", &occ)) {
9106 rt_err("kern-occ-get-hp-mult: bad args");
9107 return scm_mk_integer(sc, 0);
9108 }
9109
9110 if (! occ) {
9111 rt_err("kern-occ-get-hp-mult: null occ");
9112 return scm_mk_integer(sc, 0);
9113 }
9114
9115 return scm_mk_integer(sc, occ->hp_mult);
9116 }
9117
KERN_API_CALL(kern_occ_get_mp_mod)9118 KERN_API_CALL(kern_occ_get_mp_mod)
9119 {
9120 struct occ *occ;
9121
9122 if (unpack(sc, &args, "p", &occ)) {
9123 rt_err("kern-occ-get-mp-mod: bad args");
9124 return scm_mk_integer(sc, 0);
9125 }
9126
9127 if (! occ) {
9128 rt_err("kern-occ-get-mp-mod: null occ");
9129 return scm_mk_integer(sc, 0);
9130 }
9131
9132 return scm_mk_integer(sc, occ->mp_mod);
9133 }
9134
KERN_API_CALL(kern_occ_get_mp_mult)9135 KERN_API_CALL(kern_occ_get_mp_mult)
9136 {
9137 struct occ *occ;
9138
9139 if (unpack(sc, &args, "p", &occ)) {
9140 rt_err("kern-occ-get-mp-mult: bad args");
9141 return scm_mk_integer(sc, 0);
9142 }
9143
9144 if (! occ) {
9145 rt_err("kern-occ-get-mp-mult: null occ");
9146 return scm_mk_integer(sc, 0);
9147 }
9148
9149 return scm_mk_integer(sc, occ->mp_mult);
9150 }
9151
KERN_API_CALL(kern_occ_get_gob)9152 KERN_API_CALL(kern_occ_get_gob)
9153 {
9154 struct occ *occ;
9155
9156 if (unpack(sc, &args, "p", &occ)) {
9157 rt_err("kern-occ-get-gob: bad args");
9158 return sc->NIL;
9159 }
9160
9161 if (! occ) {
9162 rt_err("kern-occ-get-gob: null occ");
9163 return sc->NIL;
9164 }
9165
9166 if (occ->gob == NULL)
9167 {
9168 return sc->NIL;
9169 }
9170
9171 // It's already a scheme pointer so just return it directly
9172 return occ->gob->p;
9173 }
9174
KERN_API_CALL(kern_occ_set_gob)9175 KERN_API_CALL(kern_occ_set_gob)
9176 {
9177
9178 struct occ *occ;
9179
9180 if (unpack(sc, &args, "p", &occ)) {
9181 rt_err("kern-occ-set-gob: bad args");
9182 return sc->NIL;
9183 }
9184
9185 if (! scm_is_pair(sc, args)) {
9186 rt_err("kern-occ-set-gob: no gob specified");
9187 return sc->NIL;
9188 }
9189
9190 occ->gob = gob_new(sc, scm_car(sc, args));
9191
9192 return sc->NIL;
9193 }
9194
KERN_API_CALL(kern_end_game)9195 KERN_API_CALL(kern_end_game)
9196 {
9197 Quit = true;
9198 return sc->NIL;
9199 }
9200
KERN_API_CALL(kern_sprite_clone)9201 KERN_API_CALL(kern_sprite_clone)
9202 {
9203 struct sprite *orig, *clone;
9204 char *tag;
9205
9206 if (unpack(sc, &args, "py", &orig, &tag)) {
9207 rt_err("kern-sprite-clone: bad args");
9208 return sc->NIL;
9209 }
9210 clone = sprite_clone(orig, tag);
9211 if (clone) {
9212 pointer ret = scm_mk_ptr(sc, clone);
9213 session_add(Session, clone, sprite_dtor, NULL, NULL);
9214
9215 /* Tags are optional on clones, but only clones with tags will
9216 * be assigned to scheme variables. */
9217 if (tag) {
9218 scm_define(sc, tag, ret);
9219 }
9220 return ret;
9221 }
9222 return sc->NIL;
9223 }
9224
KERN_API_CALL(kern_sprite_append_decoration)9225 KERN_API_CALL(kern_sprite_append_decoration)
9226 {
9227 struct sprite *orig, *decor;
9228
9229 if (unpack(sc, &args, "pp", &orig, &decor)) {
9230 rt_err("kern-sprite-append-decoration: bad args");
9231 return sc->NIL;
9232 }
9233 if (!orig || ! decor) {
9234 rt_err("kern-sprite-append-decoration: null arg");
9235 return sc->NIL;
9236 }
9237 sprite_append_decoration(orig, decor);
9238 return scm_mk_ptr(sc, orig);
9239 }
9240
KERN_API_CALL(kern_sprite_blit_over)9241 KERN_API_CALL(kern_sprite_blit_over)
9242 {
9243 struct sprite *orig, *decor;
9244
9245 if (unpack(sc, &args, "pp", &orig, &decor)) {
9246 rt_err("kern-sprite-append-decoration: bad args");
9247 return sc->NIL;
9248 }
9249 if (!orig || ! decor) {
9250 rt_err("kern-sprite-append-decoration: null arg");
9251 return sc->NIL;
9252 }
9253 sprite_blit_over(orig, decor);
9254 return scm_mk_ptr(sc, orig);
9255 }
9256
KERN_API_CALL(kern_sprite_strip_decorations)9257 KERN_API_CALL(kern_sprite_strip_decorations)
9258 {
9259 struct sprite *orig;
9260
9261 if (unpack(sc, &args, "p", &orig)) {
9262 rt_err("kern-sprite-strip-decoration: bad args");
9263 return sc->NIL;
9264 }
9265 sprite_strip_decorations(orig);
9266 return scm_mk_ptr(sc, orig);
9267 }
9268
KERN_API_CALL(kern_sprite_apply_matrix)9269 KERN_API_CALL(kern_sprite_apply_matrix)
9270 {
9271 struct sprite *sprite;
9272 float matrix[4][3];
9273 int row;
9274 pointer pcol;
9275
9276 /* unpack the sprite */
9277 if (unpack(sc, &args, "p", &sprite)) {
9278 load_err("kern-sprite-apply-matrix: bad args");
9279 return sc->NIL;
9280 }
9281
9282 if (!scm_is_pair(sc, args)) {
9283 load_err("kern-sprite-apply-matrix: no matrix!");
9284 goto abort;
9285 }
9286 args = scm_car(sc, args);
9287
9288 /* unpack the matrix */
9289 for (row = 0; row < 4; row++) {
9290 if (! scm_is_pair(sc, args)) {
9291 load_err("kern-sprite-apply-matrix: only %d of 4 rows!", row);
9292 goto abort;
9293 }
9294 pcol = scm_car(sc, args);
9295 args = scm_cdr(sc, args);
9296 if (unpack(sc, &pcol, "fff", &matrix[row][0],
9297 &matrix[row][1],
9298 &matrix[row][2])) {
9299 load_err("kern-sprite-apply-matrix: bad args in row %d!", row);
9300 goto abort;
9301 }
9302 }
9303
9304 sprite_apply_matrix(sprite, matrix);
9305 abort:
9306 return scm_mk_ptr(sc, sprite);
9307 }
9308
9309
KERN_API_CALL(kern_los_invalidate)9310 KERN_API_CALL(kern_los_invalidate)
9311 {
9312 vmask_flush_all();
9313 return sc->T;
9314 }
9315
KERN_API_CALL(kern_cfg_set)9316 KERN_API_CALL(kern_cfg_set)
9317 {
9318 char *key, *val;
9319
9320 while (scm_is_pair(sc, args)) {
9321 if (unpack(sc, &args, "ss", &key, &val)) {
9322 rt_err("kern-cfg-set: bad args");
9323 return sc->NIL;
9324 }
9325 cfg_set(key, val);
9326 }
9327 return sc->NIL;
9328 }
9329
KERN_API_CALL(kern_cfg_get)9330 KERN_API_CALL(kern_cfg_get)
9331 {
9332 char *key, *val;
9333
9334 if (unpack(sc, &args, "s", &key)) {
9335 rt_err("kern-cfg-get: bad args");
9336 return sc->NIL;
9337 }
9338 val = cfg_get(key);
9339 if (!val)
9340 return sc->NIL;
9341 return scm_mk_string(sc, cfg_get(key));
9342 }
9343
KERN_API_CALL(kern_set_kern_intvar)9344 KERN_API_CALL(kern_set_kern_intvar)
9345 {
9346 char *key;
9347 int value;
9348
9349 while (scm_is_pair(sc, args)) {
9350 if (unpack(sc, &args, "sd", &key, &value)) {
9351 rt_err("kern-set-kern-intvar: bad args");
9352 return sc->NIL;
9353 }
9354 kern_intvar_set(key, value);
9355 }
9356 return sc->NIL;
9357 }
9358
KERN_API_CALL(kern_get_kern_intvar)9359 KERN_API_CALL(kern_get_kern_intvar)
9360 {
9361 char *key;
9362 int value;
9363
9364 if (unpack(sc, &args, "s", &key)) {
9365 rt_err("kern_get_kern_intvar: bad args");
9366 return sc->NIL;
9367 }
9368 value = kern_intvar_get(key);
9369
9370 return scm_mk_integer(sc, value);
9371 }
9372
KERN_API_CALL(kern_add_save_game)9373 KERN_API_CALL(kern_add_save_game)
9374 {
9375 char *fname;
9376
9377 while (scm_is_pair(sc, args)) {
9378 if (unpack(sc, &args, "s", &fname)) {
9379 rt_err("kern-add-save-game: bad args");
9380 }
9381 menu_add_saved_game(fname);
9382 }
9383
9384 return sc->NIL;
9385 }
9386
KERN_API_CALL(kern_type_set_gob)9387 KERN_API_CALL(kern_type_set_gob)
9388 {
9389 ObjectType *type = 0;
9390
9391 if (unpack(sc, &args, "p", &type)) {
9392 rt_err("kern-type-set-gob: bad args");
9393 return sc->NIL;
9394 }
9395
9396 if (! scm_is_pair(sc, args)) {
9397 rt_err("kern-type-set-gob: no gob specified");
9398 } else {
9399 type->setGob(gob_new(sc, scm_car(sc, args)));
9400 }
9401
9402 return scm_mk_ptr(sc, type);
9403 }
9404
KERN_API_CALL(kern_type_set_quest_item_flag)9405 KERN_API_CALL(kern_type_set_quest_item_flag)
9406 {
9407 ObjectType *type = 0;
9408 int val = 0;
9409
9410 if (unpack(sc, &args, "pb", &type, &val)) {
9411 rt_err("kern-type-set-quest-item-flag: bad args");
9412 return sc->NIL;
9413 }
9414
9415 type->setQuestItemFlag(val);
9416 return sc->NIL;
9417 }
9418
KERN_API_CALL(kern_type_get_gob)9419 KERN_API_CALL(kern_type_get_gob)
9420 {
9421 ObjectType *type = 0;
9422
9423 if (unpack(sc, &args, "p", &type)) {
9424 rt_err("kern-type-get-gob: bad args");
9425 return sc->NIL;
9426 }
9427
9428 if (!type) {
9429 rt_err("kern-type-get-gob: null obj");
9430 return sc->NIL;
9431 }
9432
9433 if (! type->getGob()) {
9434 return sc->NIL;
9435 }
9436
9437 return type->getGob()->p;
9438 }
9439
KERN_API_CALL(kern_set_quicken_sprite)9440 KERN_API_CALL(kern_set_quicken_sprite)
9441 {
9442 struct sprite *sprite;
9443 if (unpack(sc, &args, "p", &sprite)) {
9444 load_err("kern-set-quicken-sprite: bad args");
9445 return sc->F;
9446 }
9447 quicken_effect_sprite() = sprite;
9448 return sc->T;
9449 }
9450
KERN_API_CALL(kern_set_magic_negated_sprite)9451 KERN_API_CALL(kern_set_magic_negated_sprite)
9452 {
9453 struct sprite *sprite;
9454 if (unpack(sc, &args, "p", &sprite)) {
9455 load_err("kern-set-magic-negated-sprite: bad args");
9456 return sc->F;
9457 }
9458 magic_negated_effect_sprite() = sprite;
9459 return sc->T;
9460 }
9461
KERN_API_CALL(kern_set_reveal_sprite)9462 KERN_API_CALL(kern_set_reveal_sprite)
9463 {
9464 struct sprite *sprite;
9465 if (unpack(sc, &args, "p", &sprite)) {
9466 load_err("kern-set-reveal-sprite: bad args");
9467 return sc->F;
9468 }
9469 reveal_effect_sprite() = sprite;
9470 return sc->T;
9471 }
9472
KERN_API_CALL(kern_set_xray_vision_sprite)9473 KERN_API_CALL(kern_set_xray_vision_sprite)
9474 {
9475 struct sprite *sprite;
9476 if (unpack(sc, &args, "p", &sprite)) {
9477 load_err("kern-set-xray-vision-sprite: bad args");
9478 return sc->F;
9479 }
9480 xray_vision_effect_sprite() = sprite;
9481 return sc->T;
9482 }
9483
KERN_API_CALL(kern_set_time_stop_sprite)9484 KERN_API_CALL(kern_set_time_stop_sprite)
9485 {
9486 struct sprite *sprite;
9487 if (unpack(sc, &args, "p", &sprite)) {
9488 load_err("kern-set-time_stop-sprite: bad args");
9489 return sc->F;
9490 }
9491 time_stop_effect_sprite() = sprite;
9492 return sc->T;
9493 }
9494
KERN_API_CALL(kern_obj_set_mmode)9495 KERN_API_CALL(kern_obj_set_mmode)
9496 {
9497 Object *obj;
9498 struct mmode *mmode;
9499
9500 if (!(obj = unpack_obj(sc, &args, "kern-obj-set-mmode")))
9501 return sc->NIL;
9502
9503 if (unpack(sc, &args, "p", &mmode)) {
9504 rt_err("kern-obj-set-mmode: bad args");
9505 return sc->NIL;
9506 }
9507
9508 obj->setMovementMode(mmode);
9509
9510 return scm_mk_ptr(sc, obj);
9511
9512 }
9513
KERN_API_CALL(kern_progress_bar_start)9514 KERN_API_CALL(kern_progress_bar_start)
9515 {
9516 char *title = 0;
9517 unsigned int max_steps = 0;
9518
9519 if (unpack(sc, &args, "sd", &title, &max_steps)) {
9520 load_err("kern-progress-bar-start: bad args");
9521 return sc->NIL;
9522 }
9523
9524 foogod_progress_bar_set_title(title);
9525 foogod_progress_bar_set_max_steps(max_steps);
9526 foogodSetMode(FOOGOD_PROGRESS_BAR);
9527
9528 return sc->NIL;
9529 }
9530
KERN_API_CALL(kern_progress_bar_advance)9531 KERN_API_CALL(kern_progress_bar_advance)
9532 {
9533 unsigned int steps = 0;
9534
9535 if (unpack(sc, &args, "d", &steps)) {
9536 load_err("kern-progress-bar-advance: bad args");
9537 return sc->NIL;
9538 }
9539
9540 foogod_progress_bar_advance(steps);
9541 foogodRepaint();
9542
9543 return sc->NIL;
9544 }
9545
KERN_API_CALL(kern_progress_bar_finish)9546 KERN_API_CALL(kern_progress_bar_finish)
9547 {
9548 foogod_progress_bar_finish();
9549 foogodRepaint();
9550
9551 return sc->NIL;
9552 }
9553
9554 /**
9555 * (kern-ztats-add-pane <enter> <scroll> <paint> <gob>)
9556 *
9557 * <enter> is (enter <gob> <kparty> <dir> <x> <y> <w> <h>)
9558 * <scroll> is (scroll <gob> <dir>), returning #t iff the scroll was handled
9559 * <paint> is (paint <gob>)
9560 * <gob> is script info
9561 */
9562 struct kern_ztats_pane {
9563 struct ztats_pane base;
9564 struct closure *enter, *scroll, *paint, *select;
9565 struct gob *gob;
9566 scheme *sc;
9567 unsigned char added:1;
9568 };
9569
pack_rect(scheme * sc,SDL_Rect * rect)9570 static pointer pack_rect(scheme *sc, SDL_Rect *rect)
9571 {
9572 return pack(sc, "dddd", rect->x, rect->y, rect->w, rect->h);
9573 }
9574
kern_ztats_pane_enter(struct ztats_pane * pane,class Party * party,enum StatusScrollDir via,SDL_Rect * dims)9575 static void kern_ztats_pane_enter(struct ztats_pane *pane, class Party *party, enum StatusScrollDir via,
9576 SDL_Rect *dims)
9577 {
9578 struct kern_ztats_pane *kzp = (struct kern_ztats_pane*)pane;
9579 pointer prect = pack_rect(kzp->sc, dims);
9580 scm_protect(kzp->sc, prect);
9581 closure_exec(kzp->enter, "lpdl", kzp->gob->p, party, via, prect);
9582 scm_unprotect(kzp->sc, prect);
9583 }
9584
kern_ztats_pane_scroll(struct ztats_pane * pane,enum StatusScrollDir dir)9585 static int kern_ztats_pane_scroll(struct ztats_pane *pane, enum StatusScrollDir dir)
9586 {
9587 struct kern_ztats_pane *kzp = (struct kern_ztats_pane*)pane;
9588 return closure_exec(kzp->scroll, "ld", kzp->gob->p, dir);
9589 }
9590
kern_ztats_pane_paint(struct ztats_pane * pane)9591 static void kern_ztats_pane_paint(struct ztats_pane *pane)
9592 {
9593 struct kern_ztats_pane *kzp = (struct kern_ztats_pane*)pane;
9594 closure_exec(kzp->paint, "l", kzp->gob->p);
9595 }
9596
kern_ztats_pane_select(struct ztats_pane * pane)9597 static void kern_ztats_pane_select(struct ztats_pane *pane)
9598 {
9599 struct kern_ztats_pane *kzp = (struct kern_ztats_pane*)pane;
9600 closure_exec(kzp->select, "l", kzp->gob->p);
9601 }
9602
kern_ztats_pane_dtor(void * val)9603 static void kern_ztats_pane_dtor(void *val)
9604 {
9605 struct kern_ztats_pane *kzp = (struct kern_ztats_pane*)val;
9606
9607 if (kzp->added) {
9608 ztats_rm_pane(&kzp->base);
9609 }
9610
9611 if (kzp->gob) {
9612 gob_unref(kzp->gob);
9613 }
9614 if (kzp->paint) {
9615 closure_unref(kzp->paint);
9616 }
9617 if (kzp->scroll) {
9618 closure_unref(kzp->scroll);
9619 }
9620 if (kzp->enter) {
9621 closure_unref(kzp->enter);
9622 }
9623 if (kzp->select) {
9624 closure_unref(kzp->select);
9625 }
9626 free(kzp);
9627 }
9628
9629 static struct ztats_pane_ops kern_ztats_pane_ops = {
9630 kern_ztats_pane_enter,
9631 kern_ztats_pane_scroll,
9632 kern_ztats_pane_paint,
9633 kern_ztats_pane_select
9634 };
9635
KERN_API_CALL(kern_ztats_add_pane)9636 KERN_API_CALL(kern_ztats_add_pane)
9637 {
9638 pointer penter, pscroll, ppaint, pselect, pgob;
9639 struct kern_ztats_pane *kzp;
9640
9641 #ifndef USE_QUESTS
9642 return sc->F;
9643 #endif
9644
9645 if (unpack(sc, &args, "ooool", &penter, &pscroll, &ppaint, &pselect, &pgob)) {
9646 load_err("kern-ztats-add-pane: bad args");
9647 return sc->NIL;
9648 }
9649
9650 if (!(kzp = (struct kern_ztats_pane*)calloc(1, sizeof(*kzp)))) {
9651 load_err("alloc failed");
9652 return sc->NIL;
9653 }
9654
9655 kzp->base.ops = &kern_ztats_pane_ops;
9656 kzp->sc = sc;
9657 if (! (kzp->enter = closure_new_ref(sc, penter))) {
9658 goto fail;
9659 }
9660 if (! (kzp->scroll = closure_new_ref(sc, pscroll))) {
9661 goto fail;
9662 }
9663 if (! (kzp->paint = closure_new_ref(sc, ppaint))) {
9664 goto fail;
9665 }
9666 if (! (kzp->select = closure_new_ref(sc, pselect))) {
9667 goto fail;
9668 }
9669 if (! (kzp->gob = gob_new(sc, pgob))) {
9670 goto fail;
9671 }
9672 gob_ref(kzp->gob);
9673
9674 ztats_add_pane(&kzp->base);
9675
9676 /* Mark that we've added it so that we remember to remove it in the
9677 * dtor. */
9678 kzp->added = 1;
9679
9680 session_add(Session, kzp, kern_ztats_pane_dtor, NULL, NULL);
9681 return sc->T;
9682
9683 fail:
9684 kern_ztats_pane_dtor(kzp);
9685 return sc->F;
9686 }
9687
KERN_API_CALL(kern_status_set_title)9688 KERN_API_CALL(kern_status_set_title)
9689 {
9690 char *title;
9691 if (unpack(sc, &args, "s", &title)) {
9692 load_err("%s: bad args", __FUNCTION__);
9693 return sc->NIL;
9694 }
9695
9696 status_set_title(title);
9697 return sc->T;
9698 }
9699
9700 /**
9701 * (kern-screen-print (<x> <y> <w> <h>) <flags> <...>)
9702 *
9703 * <x> <y> <w> <h> are the rect (absolute screen coords) to print to
9704 * <flags> are the SP_* #defines in screen.h
9705 * <fmt> is std printf format plus the color tag extensions of ascii.h
9706 * <...> are the varargs
9707 */
KERN_API_CALL(kern_screen_print)9708 KERN_API_CALL(kern_screen_print)
9709 {
9710 static char buf[256];
9711 int room = sizeof(buf);
9712 char *ptr = buf;
9713 SDL_Rect rect;
9714 int flags = 0;
9715
9716 if (unpack_rect(sc, &args, &rect)) {
9717 load_err("%s: error unpacking rect", __FUNCTION__);
9718 return sc->NIL;
9719 }
9720
9721 if (unpack(sc, &args, "d", &flags)) {
9722 load_err("%s: error unpacking flags", __FUNCTION__);
9723 return sc->NIL;
9724 }
9725
9726 while (scm_is_pair(sc, args) && (room > 1)) {
9727
9728 pointer val = scm_car(sc, args);
9729 args = scm_cdr(sc, args);
9730 int n = 0;
9731
9732 if (scm_is_str(sc, val)) {
9733 n = snprintf(ptr, room, scm_str_val(sc, val));
9734 } else if (scm_is_int(sc, val)) {
9735 n = snprintf(ptr, room, "%ld", scm_int_val(sc, val));
9736 } else if (scm_is_real(sc, val)) {
9737 n = snprintf(ptr, room, "%f", scm_real_val(sc, val));
9738 } else {
9739 rt_err("%s: unknown type", __FUNCTION__);
9740 }
9741
9742 ptr += n;
9743 room -= n;
9744 }
9745
9746 screenPrint(&rect, flags, buf);
9747
9748 return sc->NIL;
9749 }
9750
9751 /**
9752 * (kern-screen-draw-sprite (<x> <y> <w> <h>) <flags> <sprite>)
9753 *
9754 * <x> <y> <w> <h> are the rect (absolute screen coords) to print to
9755 * <flags> are the SP_* #defines in screen.h
9756 * <fmt> is std printf format plus the color tag extensions of ascii.h
9757 * <sprite> is the sprite to draw
9758 */
KERN_API_CALL(kern_screen_draw_sprite)9759 KERN_API_CALL(kern_screen_draw_sprite)
9760 {
9761 SDL_Rect rect;
9762 int flags = 0;
9763 struct sprite *toblit;
9764
9765 if (unpack_rect(sc, &args, &rect)) {
9766 load_err("%s: error unpacking rect", __FUNCTION__);
9767 return sc->NIL;
9768 }
9769
9770 if (unpack(sc, &args, "d", &flags)) {
9771 load_err("%s: error unpacking flags", __FUNCTION__);
9772 return sc->NIL;
9773 }
9774
9775 if (unpack(sc, &args, "p", &toblit)) {
9776 rt_err("kern-sprite-clone: bad args");
9777 return sc->NIL;
9778 }
9779
9780 sprite_paint_direct(toblit, 0, &rect);
9781
9782 //screenBlit(toblit->rsurf->surf, &toblit->frames[0], &rect);
9783
9784 return sc->NIL;
9785 }
9786
9787 /**
9788 * (kern-screen-shade <rect> <amount>)
9789 *
9790 * <rect> specifies the area of the screen to shade
9791 * <amount> is a value from 0 (transparent) to 255 (opaque black)
9792 */
KERN_API_CALL(kern_screen_shade)9793 KERN_API_CALL(kern_screen_shade)
9794 {
9795 SDL_Rect rect;
9796 int amount;
9797
9798 if (unpack_rect(sc, &args, &rect)) {
9799 load_err("%s: error unpacking 'screenrect' arg", __FUNCTION__);
9800 return sc->NIL;
9801 }
9802
9803 if (unpack(sc, &args, "d", &amount)) {
9804 load_err("%s: error unpacking 'amount' arg", __FUNCTION__);
9805 return sc->NIL;
9806 }
9807
9808 screenShade(&rect, amount);
9809 return sc->NIL;
9810 }
9811
KERN_API_CALL(kern_screen_erase)9812 KERN_API_CALL(kern_screen_erase)
9813 {
9814 SDL_Rect rect;
9815
9816 if (unpack_rect(sc, &args, &rect)) {
9817 load_err("%s: error unpacking 'screenrect' arg", __FUNCTION__);
9818 return sc->NIL;
9819 }
9820
9821 screenErase(&rect);
9822 return sc->T;
9823 }
9824
KERN_API_CALL(kern_screen_update)9825 KERN_API_CALL(kern_screen_update)
9826 {
9827 SDL_Rect rect;
9828
9829 if (unpack_rect(sc, &args, &rect)) {
9830 load_err("%s: error unpacking 'screenrect' arg", __FUNCTION__);
9831 return sc->NIL;
9832 }
9833
9834 screenUpdate(&rect);
9835 return sc->T;
9836 }
9837
9838
9839
9840 /**
9841 * (kern-event-push-keyhandler <keyh>)
9842 *
9843 * <keyh> is a proc of the form (keyh key keymod)
9844 */
kern_keyh_fx(struct KeyHandler * keyh,int key,int keymod)9845 static int kern_keyh_fx(struct KeyHandler *keyh, int key, int keymod)
9846 {
9847 DECL_CAST(struct closure, proc, keyh->data);
9848 return closure_exec(proc, "dd", key, keymod) ? 1 : 0;
9849 }
9850
KERN_API_CALL(kern_event_run_keyhandler)9851 KERN_API_CALL(kern_event_run_keyhandler)
9852 {
9853 pointer pclos;
9854 struct closure *proc;
9855
9856 if (unpack(sc, &args, "o", &pclos)) {
9857 load_err("%s: error in arg", __FUNCTION__);
9858 return sc->F;
9859 }
9860
9861 if (sc->NIL == pclos) {
9862 load_err("%s: NIL closure arg", __FUNCTION__);
9863 return sc->F;
9864 }
9865
9866 if (! (proc =closure_new_ref(sc, pclos))) {
9867 load_err("%s: closure_new failed", __FUNCTION__);
9868 return sc->F;
9869 }
9870
9871 eventRunKeyHandler(kern_keyh_fx, proc);
9872 closure_unref(proc);
9873 return sc->T;
9874 }
9875
9876 /**
9877 * (kern-applet-run <run> <paint>)
9878 *
9879 * <run> is a proc of form (run <dims>), dims being the screen rect.
9880 * <paint> is a proc of form (paint)
9881 */
9882 struct kern_applet {
9883 struct applet base;
9884 struct closure *run, *paint;
9885 struct gob *gob;
9886 scheme *sc;
9887 };
9888
kern_applet_run(struct applet * applet,SDL_Rect * dims,struct session * session)9889 static void kern_applet_run(struct applet *applet, SDL_Rect *dims, struct session *session)
9890 {
9891 DECL_CAST(struct kern_applet, ka, applet);
9892 pointer prect = pack_rect(ka->sc, dims);
9893 closure_exec(ka->run, "ll", ka->gob->p, prect);
9894 }
9895
kern_applet_paint(struct applet * applet)9896 static void kern_applet_paint(struct applet *applet)
9897 {
9898 DECL_CAST(struct kern_applet, ka, applet);
9899 closure_exec(ka->paint, "l", ka->gob->p);
9900 }
9901
kern_applet_dtor(void * val)9902 static void kern_applet_dtor(void *val)
9903 {
9904 struct kern_applet *ka = (struct kern_applet*)val;
9905 if (ka->gob) {
9906 gob_unref(ka->gob);
9907 }
9908 if (ka->paint) {
9909 closure_unref(ka->paint);
9910 }
9911 if (ka->run) {
9912 closure_unref(ka->run);
9913 }
9914 KERN_FREE(ka);
9915 }
9916
9917 static struct applet_ops kern_applet_ops = {
9918 kern_applet_run,
9919 kern_applet_paint
9920 };
9921
KERN_API_CALL(kern_applet_run)9922 KERN_API_CALL(kern_applet_run)
9923 {
9924 pointer prun, ppaint, pgob;
9925 struct kern_applet *ka;
9926
9927 if (unpack(sc, &args, "ool", &prun, &ppaint, &pgob)) {
9928 load_err("%s: bad args", __FUNCTION__);
9929 return sc->NIL;
9930 }
9931
9932 if (!(ka = KERN_ALLOC(struct kern_applet))) {
9933 load_err("%s: alloc failed", __FUNCTION__);
9934 return sc->NIL;
9935 }
9936
9937 ka->base.ops = &kern_applet_ops;
9938 ka->sc = sc;
9939 if (! (ka->run = closure_new_ref(sc, prun))) {
9940 goto fail;
9941 }
9942 if (! (ka->paint = closure_new_ref(sc, ppaint))) {
9943 goto fail;
9944 }
9945 if (! (ka->gob = gob_new(sc, pgob))) {
9946 goto fail;
9947 }
9948 gob_ref(ka->gob);
9949
9950 statusRunApplet(&ka->base);
9951 kern_applet_dtor(ka);
9952
9953 return sc->T;
9954
9955 fail:
9956 kern_applet_dtor(ka);
9957 return sc->F;
9958
9959
9960 }
9961
9962 /**
9963 * (kern-define <symbol> <value>)
9964 *
9965 * This is a way to define mutable scheme variables that persist across
9966 * sessions. In other words, you can declare a variable in scheme, change
9967 * something about it during the game, and rest assured that when the game
9968 * reloads the value will be the same. By way of contrast, normal statements
9969 * like (define foo (list 'a 6)) define variables for the current session only.
9970 */
9971
9972 struct kern_define_data {
9973 scheme *sc;
9974 char *sym;
9975 pointer cell;
9976 };
9977
kern_define_dtor(void * val)9978 static void kern_define_dtor(void *val)
9979 {
9980 DECL_CAST(struct kern_define_data, data, val);
9981 free(data->sym);
9982 KERN_FREE(val);
9983 }
9984
kern_define_save(save_t * save,void * val)9985 static void kern_define_save(save_t *save, void *val)
9986 {
9987 DECL_CAST(struct kern_define_data, data, val);
9988 save->write(save, "(kern-define '%s ", data->sym);
9989 scheme_serialize(data->sc, data->cell, save);
9990 save->write(save, ")\n");
9991 }
9992
KERN_API_CALL(kern_define)9993 KERN_API_CALL(kern_define)
9994 {
9995 char *str;
9996 pointer pcell;
9997 struct kern_define_data *data;
9998
9999 if (unpack(sc, &args, "yl", &str, &pcell)) {
10000 load_err("%s: bad args", __FUNCTION__);
10001 return sc->NIL;
10002 }
10003
10004 if (!(data = KERN_ALLOC(struct kern_define_data))) {
10005 load_err("%s: alloc failed", __FUNCTION__);
10006 return sc->NIL;
10007 }
10008
10009 if (!(data->sym = strdup(str))) {
10010 KERN_FREE(data);
10011 load_err("%s: strdup failed", __FUNCTION__);
10012 return sc->NIL;
10013 }
10014
10015 data->sc = sc;
10016 data->cell = pcell;
10017 session_add(Session, data, kern_define_dtor, kern_define_save, NULL);
10018 scm_define(sc, str, pcell);
10019 return sc->NIL;
10020 }
10021
KERN_API_CALL(kern_obj_set_portrait)10022 KERN_API_CALL(kern_obj_set_portrait)
10023 {
10024 class Object *obj;
10025 struct sprite *sprite;
10026
10027 if (unpack(sc, &args, "pp", &obj, &sprite)) {
10028 rt_err("%s: bad args", __FUNCTION__);
10029 return sc->NIL;
10030 }
10031
10032 if (!obj) {
10033 rt_err("%s: null object", __FUNCTION__);
10034 return sc->NIL;
10035 }
10036
10037 obj->setPortrait(sprite);
10038
10039 return scm_mk_ptr(sc, obj);
10040
10041 }
10042
KERN_API_CALL(kern_script_version)10043 KERN_API_CALL(kern_script_version)
10044 {
10045 char *verstr = NULL;
10046
10047 if (unpack(sc, &args, "s", &verstr)) {
10048 char buffer[40]; // max length of unsigned int = 10 digits
10049 sprintf(buffer,"%u.%u.%u",Session->major, Session->minor,Session->release);
10050 return scm_mk_string(sc, buffer);
10051 }
10052
10053 if (sscanf(verstr, "%u.%u.%u", &Session->major, &Session->minor,
10054 &Session->release) != 3) {
10055 load_err("%s: bad version string '%s'", __FUNCTION__, verstr);
10056 return sc->NIL;
10057 }
10058
10059 return sc->NIL;
10060 }
10061
10062 KERN_OBSOLETE_CALL(kern_set_ascii);
10063 KERN_OBSOLETE_CALL(kern_set_frame);
10064 KERN_OBSOLETE_CALL(kern_set_cursor);
10065
10066 static int fincount=0; /* for debug */
kern_finalize(scheme * sc,pointer pp)10067 static void kern_finalize(scheme *sc, pointer pp)
10068 {
10069 class Object *obj = (class Object*)pp;
10070 obj_dec_ref(obj);
10071 fincount++;
10072 }
10073
kern_init(void)10074 scheme *kern_init(void)
10075 {
10076 scheme *sc;
10077
10078 sc = (scheme*)malloc(sizeof(*sc));
10079 if (!sc) {
10080 warn("error: could not allocate interpreter");
10081 return 0;
10082 }
10083
10084 if(!scheme_init(sc)) {
10085 warn("load error: could not initialize script interpreter\n");
10086 free(sc);
10087 return 0;
10088 }
10089
10090 fincount=0;
10091 scheme_set_custom_finalize(sc, kern_finalize);
10092
10093 /* Setup the script-to-kernel API */
10094
10095 /* kern-arms-type api */
10096 API_DECL(sc, "kern-arms-type-get-ammo-type", kern_arms_type_get_ammo_type);
10097 API_DECL(sc, "kern-arms-type-get-range", kern_arms_type_get_range);
10098 API_DECL(sc, "kern-arms-type-set-mmode", kern_arms_type_set_mmode);
10099 API_DECL(sc, "kern-arms-type-fire-in-direction", kern_arms_type_fire_in_direction);
10100
10101 /* kern-astral-body api */
10102 API_DECL(sc, "kern-astral-body-get-gob", kern_astral_body_get_gob);
10103 API_DECL(sc, "kern-astral-body-get-phase", kern_astral_body_get_phase);
10104 API_DECL(sc, "kern-astral-body-set-gob", kern_astral_body_set_gob);
10105
10106 /* kern-being-api */
10107 API_DECL(sc, "kern-being-get-base-faction", kern_being_get_base_faction);
10108 API_DECL(sc, "kern-being-get-current-faction", kern_being_get_current_faction);
10109 API_DECL(sc, "kern-being-get-visible-hostiles", kern_being_get_visible_hostiles);
10110 API_DECL(sc, "kern-being-get-visible-allies", kern_being_get_visible_allies);
10111 API_DECL(sc, "kern-being-get-visible-tiles", kern_being_get_visible_tiles);
10112 API_DECL(sc, "kern-being-is-hostile?", kern_being_is_hostile);
10113 API_DECL(sc, "kern-being-is-ally?", kern_being_is_ally);
10114 API_DECL(sc, "kern-being-set-name", kern_being_set_name);
10115 API_DECL(sc, "kern-being-pathfind-to", kern_being_pathfind_to);
10116 API_DECL(sc, "kern-being-set-base-faction", kern_being_set_base_faction);
10117 API_DECL(sc, "kern-being-set-current-faction", kern_being_set_current_faction);
10118
10119 /* kern-char api */
10120 API_DECL(sc, "kern-char-add-defense", kern_char_add_defense);
10121 API_DECL(sc, "kern-char-add-experience", kern_char_add_experience);
10122 API_DECL(sc, "kern-char-arm-self", kern_char_arm_self);
10123 API_DECL(sc, "kern-char-attack", kern_char_attack);
10124 API_DECL(sc, "kern-char-dec-mana", kern_char_dec_mana);
10125 API_DECL(sc, "kern-char-charm", kern_char_charm);
10126 API_DECL(sc, "kern-char-force-drop", kern_char_force_drop);
10127 API_DECL(sc, "kern-char-get-arms", kern_char_get_arms);
10128 API_DECL(sc, "kern-char-get-experience-value", kern_char_get_experience_value);
10129 API_DECL(sc, "kern-char-get-hp", kern_char_get_hp);
10130 API_DECL(sc, "kern-char-get-inventory", kern_char_get_inventory);
10131 API_DECL(sc, "kern-char-get-level", kern_char_get_level);
10132 API_DECL(sc, "kern-char-get-mana", kern_char_get_mana);
10133 API_DECL(sc, "kern-char-get-occ", kern_char_get_occ);
10134 API_DECL(sc, "kern-char-get-max-hp", kern_char_get_max_hp);
10135 API_DECL(sc, "kern-char-get-max-mana", kern_char_get_max_mana);
10136 API_DECL(sc, "kern-char-get-party", kern_char_get_party);
10137 API_DECL(sc, "kern-char-get-readied-weapons", kern_char_get_readied_weapons);
10138 API_DECL(sc, "kern-char-get-species", kern_char_get_species);
10139 API_DECL(sc, "kern-char-get-strength", kern_char_get_strength);
10140 API_DECL(sc, "kern-char-get-dexterity", kern_char_get_dexterity);
10141 API_DECL(sc, "kern-char-get-intelligence", kern_char_get_intelligence);
10142 API_DECL(sc, "kern-char-get-base-strength", kern_char_get_base_strength);
10143 API_DECL(sc, "kern-char-get-base-dexterity", kern_char_get_base_dexterity);
10144 API_DECL(sc, "kern-char-get-base-intelligence", kern_char_get_base_intelligence);
10145 API_DECL(sc, "kern-char-set-sched", kern_char_set_sched);
10146 API_DECL(sc, "kern-char-set-speed", kern_char_set_speed);
10147 API_DECL(sc, "kern-char-get-speed", kern_char_get_speed);
10148 API_DECL(sc, "kern-char-set-strength", kern_char_set_strength);
10149 API_DECL(sc, "kern-char-set-dexterity", kern_char_set_dexterity);
10150 API_DECL(sc, "kern-char-set-intelligence", kern_char_set_intelligence);
10151 API_DECL(sc, "kern-char-task-abort", kern_char_task_abort);
10152 API_DECL(sc, "kern-char-task-begin", kern_char_task_begin);
10153 API_DECL(sc, "kern-char-task-continue", kern_char_task_continue);
10154 API_DECL(sc, "kern-char-task-end", kern_char_task_end);
10155 API_DECL(sc, "kern-char-get-skills", kern_char_get_skills);
10156 API_DECL(sc, "kern-char-get-weapons", kern_char_get_weapons);
10157 API_DECL(sc, "kern-char-is-asleep?", kern_char_is_asleep);
10158 API_DECL(sc, "kern-char-is-dead?", kern_char_is_dead);
10159 API_DECL(sc, "kern-char-is-known?", kern_char_is_known);
10160 API_DECL(sc, "kern-char-join-player", kern_char_join_player);
10161 API_DECL(sc, "kern-char-kill", kern_char_kill);
10162 API_DECL(sc, "kern-char-leave-player", kern_char_leave_player);
10163 API_DECL(sc, "kern-char-resurrect", kern_char_resurrect);
10164 API_DECL(sc, "kern-char-set-ai", kern_char_set_ai);
10165 API_DECL(sc, "kern-char-set-control-mode", kern_char_set_control_mode);
10166 API_DECL(sc, "kern-char-set-fleeing", kern_char_set_fleeing);
10167 API_DECL(sc, "kern-char-set-hp", kern_char_set_hp);
10168 API_DECL(sc, "kern-char-set-known", kern_char_set_known);
10169 API_DECL(sc, "kern-char-set-level", kern_char_set_level);
10170 API_DECL(sc, "kern-char-set-mana", kern_char_set_mana);
10171 API_DECL(sc, "kern-char-set-player-controlled", kern_char_set_player_controlled);
10172 API_DECL(sc, "kern-char-set-schedule", kern_char_set_schedule);
10173 API_DECL(sc, "kern-char-set-sleep", kern_char_set_sleep);
10174 API_DECL(sc, "kern-char-uncharm", kern_char_uncharm);
10175 API_DECL(sc, "kern-char-unready", kern_char_unready);
10176
10177 /* kern-event api */
10178 API_DECL(sc, "kern-event-run-keyhandler", kern_event_run_keyhandler);
10179
10180 /* kern-map api */
10181 API_DECL(sc, "kern-map-rotate", kern_map_rotate);
10182
10183 /* kern-mk api */
10184 API_DECL(sc, "kern-mk-arms-type", kern_mk_arms_type);
10185 API_DECL(sc, "kern-mk-astral-body", kern_mk_astral_body);
10186 API_DECL(sc, "kern-mk-blender", kern_mk_blender);
10187 API_DECL(sc, "kern-mk-char", kern_mk_char);
10188 API_DECL(sc, "kern-mk-inventory", kern_mk_inventory);
10189 API_DECL(sc, "kern-mk-effect", kern_mk_effect);
10190 API_DECL(sc, "kern-mk-field", kern_mk_field);
10191 API_DECL(sc, "kern-mk-field-type", kern_mk_field_type);
10192 API_DECL(sc, "kern-mk-map", kern_mk_map);
10193 API_DECL(sc, "kern-mk-missile-type", kern_mk_missile_type);
10194 API_DECL(sc, "kern-mk-composite-map", kern_mk_composite_map);
10195 API_DECL(sc, "kern-mk-mmode", kern_mk_mmode);
10196 API_DECL(sc, "kern-mk-obj", kern_mk_obj);
10197 API_DECL(sc, "kern-mk-obj-type", kern_mk_obj_type);
10198 API_DECL(sc, "kern-mk-occ", kern_mk_occ);
10199 API_DECL(sc, "kern-mk-palette", kern_mk_palette);
10200 API_DECL(sc, "kern-mk-party", kern_mk_party);
10201 API_DECL(sc, "kern-mk-place", kern_mk_place);
10202 API_DECL(sc, "kern-mk-player", kern_mk_player);
10203 API_DECL(sc, "kern-mk-ptable", kern_mk_ptable);
10204 API_DECL(sc, "kern-mk-sched", kern_mk_sched);
10205 API_DECL(sc, "kern-mk-skill", kern_mk_skill);
10206 API_DECL(sc, "kern-mk-skill-set", kern_mk_skill_set);
10207 API_DECL(sc, "kern-mk-sound", kern_mk_sound);
10208 API_DECL(sc, "kern-mk-species", kern_mk_species);
10209 API_DECL(sc, "kern-mk-sprite", kern_mk_sprite);
10210 API_DECL(sc, "kern-mk-sprite-set", kern_mk_sprite_set);
10211 API_DECL(sc, "kern-mk-templ", kern_mk_templ);
10212 API_DECL(sc, "kern-mk-terrain", kern_mk_terrain);
10213 API_DECL(sc, "kern-mk-vehicle", kern_mk_vehicle);
10214 API_DECL(sc, "kern-mk-vehicle-type", kern_mk_vehicle_type);
10215
10216 /* kern-obj api */
10217 API_DECL(sc, "kern-obj-add-food", kern_obj_add_food);
10218 API_DECL(sc, "kern-obj-add-gold", kern_obj_add_gold);
10219 API_DECL(sc, "kern-obj-add-effect", kern_obj_add_effect);
10220 API_DECL(sc, "kern-obj-add-to-inventory", kern_obj_add_to_inventory);
10221 API_DECL(sc, "kern-obj-apply-damage", kern_obj_apply_damage);
10222 API_DECL(sc, "kern-obj-inflict-damage", kern_obj_inflict_damage);
10223 API_DECL(sc, "kern-obj-clone", kern_obj_clone);
10224 API_DECL(sc, "kern-obj-dec-ap", kern_obj_dec_ap);
10225 API_DECL(sc, "kern-obj-dec-light", kern_obj_dec_light);
10226 API_DECL(sc, "kern-obj-dec-ref", kern_obj_dec_ref);
10227 /*API_DECL(sc, "kern-obj-destroy", kern_obj_destroy);*/
10228 API_DECL(sc, "kern-obj-find-path", kern_obj_find_path);
10229 API_DECL(sc, "kern-obj-get-activity", kern_obj_get_activity);
10230 API_DECL(sc, "kern-obj-get-ap", kern_obj_get_ap);
10231 API_DECL(sc, "kern-obj-get-count", kern_obj_get_count);
10232 API_DECL(sc, "kern-obj-get-dir", kern_obj_get_dir);
10233 API_DECL(sc, "kern-obj-get-hp", kern_obj_get_hp);
10234 API_DECL(sc, "kern-obj-get-effects", kern_obj_get_effects);
10235 API_DECL(sc, "kern-obj-get-facing", kern_obj_get_facing);
10236 API_DECL(sc, "kern-obj-get-gob", kern_obj_get_gob);
10237 API_DECL(sc, "kern-obj-get-light", kern_obj_get_light);
10238 API_DECL(sc, "kern-obj-get-location", kern_obj_get_location);
10239 API_DECL(sc, "kern-obj-get-mmode", kern_obj_get_mmode);
10240 API_DECL(sc, "kern-obj-get-movecost", kern_obj_get_movecost);
10241 API_DECL(sc, "kern-obj-get-name", kern_obj_get_name);
10242 API_DECL(sc, "kern-obj-get-sprite", kern_obj_get_sprite);
10243 API_DECL(sc, "kern-obj-get-type", kern_obj_get_type);
10244 API_DECL(sc, "kern-obj-get-vision-radius", kern_obj_get_vision_radius);
10245 API_DECL(sc, "kern-obj-has?", kern_obj_has);
10246 API_DECL(sc, "kern-obj-heal", kern_obj_heal);
10247 API_DECL(sc, "kern-obj-inc-light", kern_obj_inc_light);
10248 API_DECL(sc, "kern-obj-inc-ref", kern_obj_inc_ref);
10249 API_DECL(sc, "kern-obj-is-being?", kern_obj_is_being);
10250 API_DECL(sc, "kern-obj-is-char?", kern_obj_is_char);
10251 API_DECL(sc, "kern-obj-is-container?", kern_obj_is_container);
10252 API_DECL(sc, "kern-obj-is-field?", kern_obj_is_field);
10253 API_DECL(sc, "kern-obj-is-mech?", kern_obj_is_mech);
10254 API_DECL(sc, "kern-obj-is-submerged?", kern_obj_is_submerged);
10255 API_DECL(sc, "kern-obj-is-visible?", kern_obj_is_visible);
10256 API_DECL(sc, "kern-obj-move", kern_obj_move);
10257 API_DECL(sc, "kern-obj-put-at", kern_obj_put_at);
10258 API_DECL(sc, "kern-obj-put-into", kern_obj_put_into);
10259 API_DECL(sc, "kern-obj-relocate", kern_obj_relocate);
10260 API_DECL(sc, "kern-obj-remove", kern_obj_remove);
10261 API_DECL(sc, "kern-obj-remove-effect", kern_obj_remove_effect);
10262 API_DECL(sc, "kern-obj-remove-from-inventory", kern_obj_remove_from_inventory);
10263 API_DECL(sc, "kern-obj-set-ap", kern_obj_set_ap);
10264 API_DECL(sc, "kern-obj-set-conv", kern_obj_set_conv);
10265 API_DECL(sc, "kern-obj-set-facing", kern_obj_set_facing);
10266 API_DECL(sc, "kern-obj-set-gob", kern_obj_set_gob);
10267 API_DECL(sc, "kern-obj-set-ignore-time-stop", kern_obj_set_ignore_time_stop);
10268 API_DECL(sc, "kern-obj-set-light", kern_obj_set_light);
10269 API_DECL(sc, "kern-obj-set-opacity", kern_obj_set_opacity);
10270 API_DECL(sc, "kern-obj-set-pclass", kern_obj_set_pclass);
10271 API_DECL(sc, "kern-obj-set-mmode", kern_obj_set_mmode);
10272 API_DECL(sc, "kern-obj-set-portrait", kern_obj_set_portrait);
10273 API_DECL(sc, "kern-obj-set-sprite", kern_obj_set_sprite);
10274 API_DECL(sc, "kern-obj-set-submerged", kern_obj_set_submerged);
10275 API_DECL(sc, "kern-obj-set-temporary", kern_obj_set_temporary);
10276 API_DECL(sc, "kern-obj-set-ttl", kern_obj_set_ttl);
10277 API_DECL(sc, "kern-obj-set-visible", kern_obj_set_visible);
10278 API_DECL(sc, "kern-obj-wander", kern_obj_wander);
10279 API_DECL(sc, "kern-obj-freeze", kern_obj_freeze);
10280 API_DECL(sc, "kern-obj-thaw", kern_obj_thaw);
10281
10282 /* kern-occ api */
10283 API_DECL(sc, "kern-occ-get-hp-mod", kern_occ_get_hp_mod);
10284 API_DECL(sc, "kern-occ-get-hp-mult", kern_occ_get_hp_mult);
10285 API_DECL(sc, "kern-occ-get-mp-mod", kern_occ_get_mp_mod);
10286 API_DECL(sc, "kern-occ-get-mp-mult", kern_occ_get_mp_mult);
10287 API_DECL(sc, "kern-occ-get-gob", kern_occ_get_gob);
10288 API_DECL(sc, "kern-occ-set-gob", kern_occ_set_gob);
10289
10290 /* kern-place api */
10291 API_DECL(sc, "kern-place-add-on-entry-hook", kern_place_add_on_entry_hook);
10292 API_DECL(sc, "kern-place-apply-tile-effects", kern_place_apply_tile_effects);
10293 API_DECL(sc, "kern-place-set-subplace", kern_place_set_subplace);
10294 API_DECL(sc, "kern-place-get-beings", kern_place_get_beings);
10295 API_DECL(sc, "kern-place-get-height", kern_place_get_height);
10296 API_DECL(sc, "kern-place-get-light", kern_place_get_light);
10297 API_DECL(sc, "kern-place-get-location", kern_place_get_location);
10298 API_DECL(sc, "kern-place-get-movement-cost", kern_place_get_movement_cost);
10299 API_DECL(sc, "kern-place-get-name", kern_place_get_name);
10300 API_DECL(sc, "kern-place-get-neighbor", kern_place_get_neighbor);
10301 API_DECL(sc, "kern-place-get-objects", kern_place_get_objects);
10302 API_DECL(sc, "kern-place-get-terrain", kern_place_get_terrain);
10303 API_DECL(sc, "kern-place-get-terrain-map", kern_place_get_terrain_map);
10304 API_DECL(sc, "kern-place-get-vehicle", kern_place_get_vehicle);
10305 API_DECL(sc, "kern-place-get-width", kern_place_get_width);
10306 API_DECL(sc, "kern-place-is-passable", kern_place_is_passable);
10307 API_DECL(sc, "kern-place-is-hazardous", kern_place_is_hazardous);
10308 API_DECL(sc, "kern-place-is-wrapping?", kern_place_is_wrapping);
10309 API_DECL(sc, "kern-place-is-wilderness?", kern_place_is_wilderness);
10310 API_DECL(sc, "kern-place-blocks-los?", kern_place_blocks_los);
10311 API_DECL(sc, "kern-place-map", kern_place_map);
10312 API_DECL(sc, "kern-place-move-is-passable?", kern_place_move_is_passable);
10313 API_DECL(sc, "kern-place-set-neighbor", kern_place_set_neighbor);
10314 API_DECL(sc, "kern-place-set-terrain", kern_place_set_terrain);
10315 API_DECL(sc, "kern-place-set-terrain-map", kern_place_set_terrain_map);
10316 API_DECL(sc, "kern-place-synch", kern_place_synch);
10317 API_DECL(sc, "kern-place-is-visible?", kern_place_is_visible);
10318 API_DECL(sc, "kern-place-is-combat-map?", kern_place_is_combat_map);
10319
10320 /* player api */
10321 API_DECL(sc, "kern-player-get-food", kern_player_get_food);
10322 API_DECL(sc, "kern-player-get-gold", kern_player_get_gold);
10323 API_DECL(sc, "kern-player-set-follow-mode", kern_player_set_follow_mode);
10324 API_DECL(sc, "kern-player-set-food", kern_player_set_food);
10325 API_DECL(sc, "kern-player-set-gold", kern_player_set_gold);
10326
10327 /* screen api */
10328 API_DECL(sc, "kern-screen-erase", kern_screen_erase);
10329 API_DECL(sc, "kern-screen-print", kern_screen_print);
10330 API_DECL(sc, "kern-screen-shade", kern_screen_shade);
10331 API_DECL(sc, "kern-screen-update", kern_screen_update);
10332 API_DECL(sc, "kern-screen-draw-sprite", kern_screen_draw_sprite);
10333
10334 /* kern-set api */
10335 API_DECL(sc, "kern-set-crosshair", kern_set_crosshair);
10336 API_DECL(sc, "kern-set-damage-sprite", kern_set_damage_sprite);
10337 API_DECL(sc, "kern-set-clock", kern_set_clock);
10338
10339 /* kern-species api */
10340 API_DECL(sc, "kern-species-get-hp-mod", kern_species_get_hp_mod);
10341 API_DECL(sc, "kern-species-get-hp-mult", kern_species_get_hp_mult);
10342 API_DECL(sc, "kern-species-get-mp-mod", kern_species_get_mp_mod);
10343 API_DECL(sc, "kern-species-get-mp-mult", kern_species_get_mp_mult);
10344
10345 /* kern-terrain api */
10346 API_DECL(sc, "kern-terrain-blocks-los?", kern_terrain_blocks_los);
10347 API_DECL(sc, "kern-terrain-get-pclass", kern_terrain_get_pclass);
10348 API_DECL(sc, "kern-terrain-set-combat-map", kern_terrain_set_combat_map);
10349 API_DECL(sc, "kern-terrain-set-combat-handler", kern_terrain_set_combat_handler);
10350 API_DECL(sc, "kern-terrain-map-inc-ref", kern_terrain_map_inc_ref);
10351 API_DECL(sc, "kern-terrain-map-dec-ref", kern_terrain_map_dec_ref);
10352 API_DECL(sc, "kern-terrain-map-blend", kern_terrain_map_blend);
10353 API_DECL(sc, "kern-terrainmap-get-width", kern_map_get_width);
10354 API_DECL(sc, "kern-terrainmap-get-height", kern_map_get_height);
10355
10356 /* kern-type api */
10357 API_DECL(sc, "kern-type-describe", kern_type_describe);
10358 API_DECL(sc, "kern-type-get-gifc", kern_type_get_gifc);
10359 API_DECL(sc, "kern-type-get-gob", kern_type_get_gob);
10360 API_DECL(sc, "kern-type-get-name", kern_type_get_name);
10361 API_DECL(sc, "kern-type-set-gob", kern_type_set_gob);
10362 API_DECL(sc, "kern-type-set-quest-item-flag", kern_type_set_quest_item_flag);
10363
10364 /* misc api */
10365 API_DECL(sc, "kern-add-magic-negated", kern_add_magic_negated);
10366 API_DECL(sc, "kern-add-quicken", kern_add_quicken);
10367 API_DECL(sc, "kern-add-reveal", kern_add_reveal);
10368 API_DECL(sc, "kern-add-save-game", kern_add_save_game);
10369 API_DECL(sc, "kern-add-spell", kern_add_spell);
10370 API_DECL(sc, "kern-add-tick-job", kern_add_tick_job);
10371 API_DECL(sc, "kern-add-time-stop", kern_add_time_stop);
10372 API_DECL(sc, "kern-ambush-while-camping", kern_ambush_while_camping);
10373 API_DECL(sc, "kern-add-xray-vision", kern_add_xray_vision);
10374 API_DECL(sc, "kern-begin-combat", kern_begin_combat);
10375 API_DECL(sc, "kern-blit-map", kern_blit_map);
10376 API_DECL(sc, "kern-init-random", kern_init_random);
10377 API_DECL(sc, "kern-define", kern_define);
10378 API_DECL(sc, "kern-dice-roll", kern_dice_roll);
10379 API_DECL(sc, "kern-end-game" , kern_end_game);
10380 API_DECL(sc, "kern-fire-missile", kern_fire_missile);
10381 API_DECL(sc, "kern-fire-missile-to-max", kern_fire_missile_to_max);
10382 API_DECL(sc, "kern-fold-rect", kern_fold_rect);
10383 API_DECL(sc, "kern-get-distance", kern_get_distance);
10384 API_DECL(sc, "kern-get-objects-at", kern_get_objects_at);
10385 API_DECL(sc, "kern-get-magic-negated", kern_get_magic_negated);
10386 API_DECL(sc, "kern-get-player", kern_get_player);
10387 API_DECL(sc, "kern-get-ticks", kern_get_ticks);
10388 API_DECL(sc, "kern-get-time", kern_get_time);
10389 API_DECL(sc, "kern-time-get-remainder", kern_get_time_remainder);
10390 API_DECL(sc, "kern-get-total-minutes", kern_get_total_minutes);
10391 API_DECL(sc, "kern-harm-relations", kern_harm_relations);
10392 API_DECL(sc, "kern-in-los?", kern_in_los);
10393 API_DECL(sc, "kern-los-invalidate", kern_los_invalidate);
10394 API_DECL(sc, "kern-include", kern_include);
10395 API_DECL(sc, "kern-interp-error", kern_interp_error);
10396 API_DECL(sc, "kern-is-valid-location?", kern_is_valid_location);
10397 API_DECL(sc, "kern-print", kern_print);
10398 API_DECL(sc, "kern-search-rect", kern_search_rect);
10399 API_DECL(sc, "kern-search-rect-for-terrain",
10400 kern_search_rect_for_terrain);
10401 API_DECL(sc, "kern-search-rect-for-obj-type",
10402 kern_search_rect_for_obj_type);
10403 API_DECL(sc, "kern-add-hook", kern_add_hook);
10404 API_DECL(sc, "kern-add-query", kern_add_query);
10405 API_DECL(sc, "kern-rm-hook", kern_rm_hook);
10406 API_DECL(sc, "kern-set-quicken-sprite", kern_set_quicken_sprite);
10407 API_DECL(sc, "kern-set-time-stop-sprite", kern_set_time_stop_sprite);
10408 API_DECL(sc, "kern-set-magic-negated-sprite", kern_set_magic_negated_sprite);
10409 API_DECL(sc, "kern-set-reveal-sprite", kern_set_reveal_sprite);
10410 API_DECL(sc, "kern-set-xray-vision-sprite", kern_set_xray_vision_sprite);
10411 API_DECL(sc, "kern-set-spell-words", kern_set_spell_words);
10412 API_DECL(sc, "kern-set-wind", kern_set_wind);
10413 API_DECL(sc, "kern-get-wind", kern_get_wind);
10414 API_DECL(sc, "kern-set-time-accel", kern_set_time_accel);
10415 API_DECL(sc, "kern-sleep", kern_sleep);
10416 API_DECL(sc, "kern-music-play", kern_music_play);
10417 API_DECL(sc, "kern-sound-play", kern_sound_play);
10418 API_DECL(sc, "kern-sound-play-at", kern_sound_play_at);
10419 API_DECL(sc, "kern-sound-play-ambient", kern_sound_play_ambient);
10420 API_DECL(sc, "kern-tag", kern_tag);
10421 API_DECL(sc, "kern-test-recursion", kern_test_recursion);
10422 API_DECL(sc, "kern-ticks-per-turn", kern_ticks_per_turn);
10423 API_DECL(sc, "kern-set-turn-count", kern_set_turn_count);
10424 API_DECL(sc, "kern-map-flash-sprite", kern_map_flash_sprite);
10425 API_DECL(sc, "kern-script-version", kern_script_version);
10426
10427 /* ui api */
10428 API_DECL(sc, "kern-ui-direction", kern_ui_direction);
10429 API_DECL(sc, "kern-ui-paginate-text", kern_ui_paginate_text);
10430 API_DECL(sc, "kern-ui-page-text", kern_ui_page_text);
10431 API_DECL(sc, "kern-ui-select-from-list", kern_ui_select_from_list);
10432 API_DECL(sc, "kern-ui-select-item", kern_ui_select_item);
10433 API_DECL(sc, "kern-ui-select-party-member", kern_ui_select_party_member);
10434 API_DECL(sc, "kern-ui-target", kern_ui_target);
10435 API_DECL(sc, "kern-ui-target-generic", kern_ui_target_generic);
10436 API_DECL(sc, "kern-ui-waitkey", kern_ui_waitkey);
10437 API_DECL(sc, "kern-applet-run", kern_applet_run);
10438
10439 /* conv api */
10440 API_DECL(sc, "kern-conv-begin", kern_conv_begin);
10441 API_DECL(sc, "kern-conv-end", kern_conv_end);
10442 API_DECL(sc, "kern-conv-say", kern_conv_say);
10443 API_DECL(sc, "kern-conv-get-amount", kern_conv_get_amount);
10444 API_DECL(sc, "kern-conv-get-yes-no?", kern_conv_get_yes_no);
10445 API_DECL(sc, "kern-conv-trade", kern_conv_trade);
10446 API_DECL(sc, "kern-conv-get-reply", kern_conv_get_reply);
10447 API_DECL(sc, "kern-conv-get-string", kern_conv_get_string);
10448
10449 /* kern-map api */
10450 API_DECL(sc, "kern-map-blit-image", kern_map_blit_image);
10451 API_DECL(sc, "kern-map-center-camera", kern_map_center_camera);
10452 API_DECL(sc, "kern-map-flash", kern_map_flash);
10453 API_DECL(sc, "kern-map-repaint", kern_map_repaint);
10454 API_DECL(sc, "kern-map-set-dirty", kern_map_set_dirty);
10455 API_DECL(sc, "kern-map-set-image", kern_map_set_image);
10456 API_DECL(sc, "kern-map-set-jitter", kern_map_set_jitter);
10457 API_DECL(sc, "kern-map-set-peering", kern_map_set_peering);
10458 API_DECL(sc, "kern-map-view-create", kern_map_view_create);
10459 API_DECL(sc, "kern-map-view-destroy", kern_map_view_destroy);
10460 API_DECL(sc, "kern-map-view-center", kern_map_view_center);
10461 API_DECL(sc, "kern-map-view-add", kern_map_view_add);
10462 API_DECL(sc, "kern-map-view-rm", kern_map_view_rm);
10463 API_DECL(sc, "kern-map-view-add", kern_map_view_add);
10464 API_DECL(sc, "kern-map-view-rm", kern_map_view_rm);
10465
10466 /* kern-log api */
10467 API_DECL(sc, "kern-log-begin", kern_log_begin);
10468 API_DECL(sc, "kern-log-continue", kern_log_continue);
10469 API_DECL(sc, "kern-log-end", kern_log_end);
10470 API_DECL(sc, "kern-log-enable", kern_log_enable);
10471 API_DECL(sc, "kern-log-flush", kern_log_flush);
10472 API_DECL(sc, "kern-log-msg", kern_log_msg);
10473 API_DECL(sc, "kern-stdout-msg", kern_stdout_msg);
10474
10475 /* kern-dtable api */
10476 API_DECL(sc, "kern-mk-dtable", kern_mk_dtable);
10477 API_DECL(sc, "kern-dtable-get", kern_dtable_get);
10478 API_DECL(sc, "kern-dtable-set", kern_dtable_set);
10479 API_DECL(sc, "kern-dtable-inc", kern_dtable_inc);
10480 API_DECL(sc, "kern-dtable-dec", kern_dtable_dec);
10481
10482 /* kern-party-api */
10483 API_DECL(sc, "kern-party-add-member", kern_party_add_member);
10484 API_DECL(sc, "kern-party-get-members", kern_party_get_members);
10485 API_DECL(sc, "kern-party-get-vehicle", kern_party_get_vehicle);
10486 API_DECL(sc, "kern-party-set-vehicle", kern_party_set_vehicle);
10487
10488 /* kern-sprite api */
10489 API_DECL(sc, "kern-sprite-clone", kern_sprite_clone);
10490 API_DECL(sc, "kern-sprite-append-decoration", kern_sprite_append_decoration);
10491 API_DECL(sc, "kern-sprite-apply-matrix", kern_sprite_apply_matrix);
10492 API_DECL(sc, "kern-sprite-blit-over", kern_sprite_blit_over);
10493 API_DECL(sc, "kern-sprite-strip-decorations", kern_sprite_strip_decorations);
10494
10495
10496 /* kern-vehicle-api */
10497 API_DECL(sc, "kern-vehicle-set-name", kern_vehicle_set_name);
10498
10499 /* kern-cfg api */
10500 API_DECL(sc, "kern-cfg-set", kern_cfg_set);
10501 API_DECL(sc, "kern-cfg-get", kern_cfg_get);
10502
10503 API_DECL(sc, "kern-set-kern-intvar", kern_set_kern_intvar);
10504 API_DECL(sc, "kern-get-kern-intvar", kern_get_kern_intvar);
10505
10506
10507 /* kern-image api */
10508 API_DECL(sc, "kern-image-load", kern_image_load);
10509 API_DECL(sc, "kern-image-free", kern_image_free);
10510
10511 /* kern-progress-bar api */
10512 API_DECL(sc, "kern-progress-bar-start", kern_progress_bar_start);
10513 API_DECL(sc, "kern-progress-bar-advance", kern_progress_bar_advance);
10514 API_DECL(sc, "kern-progress-bar-finish", kern_progress_bar_finish);
10515
10516 /* kern-ztats api */
10517 API_DECL(sc, "kern-ztats-add-pane", kern_ztats_add_pane);
10518 API_DECL(sc, "kern-status-set-title", kern_status_set_title);
10519
10520 /* obsolete (keep these until old save games are unlikely to use
10521 * them) */
10522 API_DECL(sc, "kern-set-frame", kern_set_frame);
10523 API_DECL(sc, "kern-set-cursor", kern_set_cursor);
10524 API_DECL(sc, "kern-set-ascii", kern_set_ascii);
10525
10526
10527 /* Revisit: probably want to provide some kind of custom port here. */
10528 scheme_set_output_port_file(sc, stderr);
10529
10530 /* Shared constants */
10531 scm_define_int(sc, "kern-key-esc", SDLK_ESCAPE);
10532 scm_define_int(sc, "kern-key-space", SDLK_SPACE);
10533 scm_define_int(sc, "kern-key-return", '\n'); // remapped in event.c::mapKey
10534 scm_define_int(sc, "kern-key-enter", SDLK_KP_ENTER);
10535 scm_define_int(sc, "kern-key-up", SDLK_KP8); // also handles arrowkeys
10536 scm_define_int(sc, "kern-key-down", SDLK_KP2); // also handles arrowkeys
10537 scm_define_int(sc, "kern-key-kp-pgup", SDLK_KP9);
10538 scm_define_int(sc, "kern-key-kp-pgdn", SDLK_KP3);
10539 scm_define_int(sc, "kern-key-pgup", SDLK_PAGEUP);
10540 scm_define_int(sc, "kern-key-pgdn", SDLK_PAGEDOWN);
10541 scm_define_int(sc, "kern-sp-centered", SP_CENTERED);
10542 scm_define_int(sc, "kern-ascii-h", ASCII_H);
10543 return sc;
10544 }
10545