Implemented garglk_set_program_name(), garglk_set_program_info(), garglk_set_story_name()
[rodin/chimara.git] / interpreters / frotz / object.c
1 /* object.c - Object manipulation opcodes
2  *        Copyright (c) 1995-1997 Stefan Jokisch
3  *
4  * This file is part of Frotz.
5  *
6  * Frotz is free software; you can redistribute it and/or modify
7  * it under the terms of the GNU General Public License as published by
8  * the Free Software Foundation; either version 2 of the License, or
9  * (at your option) any later version.
10  *
11  * Frotz is distributed in the hope that it will be useful,
12  * but WITHOUT ANY WARRANTY; without even the implied warranty of
13  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14  * GNU General Public License for more details.
15  *
16  * You should have received a copy of the GNU General Public License
17  * along with this program; if not, write to the Free Software
18  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA
19  */
20
21 #include "frotz.h"
22
23 #define MAX_OBJECT 2000
24
25 #define O1_PARENT 4
26 #define O1_SIBLING 5
27 #define O1_CHILD 6
28 #define O1_PROPERTY_OFFSET 7
29 #define O1_SIZE 9
30
31 #define O4_PARENT 6
32 #define O4_SIBLING 8
33 #define O4_CHILD 10
34 #define O4_PROPERTY_OFFSET 12
35 #define O4_SIZE 14
36
37 /*
38  * object_address
39  *
40  * Calculate the address of an object.
41  *
42  */
43
44 static zword object_address (zword obj)
45 {
46 /*    zchar obj_num[10]; */
47
48     /* Check object number */
49
50     if (obj > ((h_version <= V3) ? 255 : MAX_OBJECT)) {
51         print_string("@Attempt to address illegal object ");
52         print_num(obj);
53         print_string(".  This is normally fatal.");
54         new_line();
55         runtime_error (ERR_ILL_OBJ);
56     }
57
58     /* Return object address */
59
60     if (h_version <= V3)
61         return h_objects + ((obj - 1) * O1_SIZE + 62);
62     else
63         return h_objects + ((obj - 1) * O4_SIZE + 126);
64
65 }/* object_address */
66
67 /*
68  * object_name
69  *
70  * Return the address of the given object's name.
71  *
72  */
73
74 zword object_name (zword object)
75 {
76     zword obj_addr;
77     zword name_addr;
78
79     obj_addr = object_address (object);
80
81     /* The object name address is found at the start of the properties */
82
83     if (h_version <= V3)
84         obj_addr += O1_PROPERTY_OFFSET;
85     else
86         obj_addr += O4_PROPERTY_OFFSET;
87
88     LOW_WORD (obj_addr, name_addr)
89
90     return name_addr;
91
92 }/* object_name */
93
94 /*
95  * first_property
96  *
97  * Calculate the start address of the property list associated with
98  * an object.
99  *
100  */
101
102 static zword first_property (zword obj)
103 {
104     zword prop_addr;
105     zbyte size;
106
107     /* Fetch address of object name */
108
109     prop_addr = object_name (obj);
110
111     /* Get length of object name */
112
113     LOW_BYTE (prop_addr, size)
114
115     /* Add name length to pointer */
116
117     return prop_addr + 1 + 2 * size;
118
119 }/* first_property */
120
121 /*
122  * next_property
123  *
124  * Calculate the address of the next property in a property list.
125  *
126  */
127
128 static zword next_property (zword prop_addr)
129 {
130     zbyte value;
131
132     /* Load the current property id */
133
134     LOW_BYTE (prop_addr, value)
135     prop_addr++;
136
137     /* Calculate the length of this property */
138
139     if (h_version <= V3)
140         value >>= 5;
141     else if (!(value & 0x80))
142         value >>= 6;
143     else {
144
145         LOW_BYTE (prop_addr, value)
146         value &= 0x3f;
147
148         if (value == 0) value = 64;        /* demanded by Spec 1.0 */
149
150     }
151
152     /* Add property length to current property pointer */
153
154     return prop_addr + value + 1;
155
156 }/* next_property */
157
158 /*
159  * unlink_object
160  *
161  * Unlink an object from its parent and siblings.
162  *
163  */
164
165 static void unlink_object (zword object)
166 {
167     zword obj_addr;
168     zword parent_addr;
169     zword sibling_addr;
170
171     if (object == 0) {
172         runtime_error (ERR_REMOVE_OBJECT_0);
173         return;
174     }
175
176     obj_addr = object_address (object);
177
178     if (h_version <= V3) {
179
180         zbyte parent;
181         zbyte younger_sibling;
182         zbyte older_sibling;
183         zbyte zero = 0;
184
185         /* Get parent of object, and return if no parent */
186
187         obj_addr += O1_PARENT;
188         LOW_BYTE (obj_addr, parent)
189         if (!parent)
190             return;
191
192         /* Get (older) sibling of object and set both parent and sibling
193            pointers to 0 */
194
195         SET_BYTE (obj_addr, zero)
196         obj_addr += O1_SIBLING - O1_PARENT;
197         LOW_BYTE (obj_addr, older_sibling)
198         SET_BYTE (obj_addr, zero)
199
200         /* Get first child of parent (the youngest sibling of the object) */
201
202         parent_addr = object_address (parent) + O1_CHILD;
203         LOW_BYTE (parent_addr, younger_sibling)
204
205         /* Remove object from the list of siblings */
206
207         if (younger_sibling == object)
208             SET_BYTE (parent_addr, older_sibling)
209         else {
210             do {
211                 sibling_addr = object_address (younger_sibling) + O1_SIBLING;
212                 LOW_BYTE (sibling_addr, younger_sibling)
213             } while (younger_sibling != object);
214             SET_BYTE (sibling_addr, older_sibling)
215         }
216
217     } else {
218
219         zword parent;
220         zword younger_sibling;
221         zword older_sibling;
222         zword zero = 0;
223
224         /* Get parent of object, and return if no parent */
225
226         obj_addr += O4_PARENT;
227         LOW_WORD (obj_addr, parent)
228         if (!parent)
229             return;
230
231         /* Get (older) sibling of object and set both parent and sibling
232            pointers to 0 */
233
234         SET_WORD (obj_addr, zero)
235         obj_addr += O4_SIBLING - O4_PARENT;
236         LOW_WORD (obj_addr, older_sibling)
237         SET_WORD (obj_addr, zero)
238
239         /* Get first child of parent (the youngest sibling of the object) */
240
241         parent_addr = object_address (parent) + O4_CHILD;
242         LOW_WORD (parent_addr, younger_sibling)
243
244         /* Remove object from the list of siblings */
245
246         if (younger_sibling == object)
247             SET_WORD (parent_addr, older_sibling)
248         else {
249             do {
250                 sibling_addr = object_address (younger_sibling) + O4_SIBLING;
251                 LOW_WORD (sibling_addr, younger_sibling)
252             } while (younger_sibling != object);
253             SET_WORD (sibling_addr, older_sibling)
254         }
255
256     }
257
258 }/* unlink_object */
259
260 /*
261  * z_clear_attr, clear an object attribute.
262  *
263  *        zargs[0] = object
264  *        zargs[1] = number of attribute to be cleared
265  *
266  */
267
268 void z_clear_attr (void)
269 {
270     zword obj_addr;
271     zbyte value;
272
273     if (story_id == SHERLOCK)
274         if (zargs[1] == 48)
275             return;
276
277     if (zargs[1] > ((h_version <= V3) ? 31 : 47))
278         runtime_error (ERR_ILL_ATTR);
279
280     /* If we are monitoring attribute assignment display a short note */
281
282     if (f_setup.attribute_assignment) {
283         stream_mssg_on ();
284         print_string ("@clear_attr ");
285         print_object (zargs[0]);
286         print_string (" ");
287         print_num (zargs[1]);
288         stream_mssg_off ();
289     }
290
291     if (zargs[0] == 0) {
292         runtime_error (ERR_CLEAR_ATTR_0);
293         return;
294     }
295
296     /* Get attribute address */
297
298     obj_addr = object_address (zargs[0]) + zargs[1] / 8;
299
300     /* Clear attribute bit */
301
302     LOW_BYTE (obj_addr, value)
303     value &= ~(0x80 >> (zargs[1] & 7));
304     SET_BYTE (obj_addr, value)
305
306 }/* z_clear_attr */
307
308 /*
309  * z_jin, branch if the first object is inside the second.
310  *
311  *        zargs[0] = first object
312  *        zargs[1] = second object
313  *
314  */
315
316 void z_jin (void)
317 {
318     zword obj_addr;
319
320     /* If we are monitoring object locating display a short note */
321
322     if (f_setup.object_locating) {
323         stream_mssg_on ();
324         print_string ("@jin ");
325         print_object (zargs[0]);
326         print_string (" ");
327         print_object (zargs[1]);
328         stream_mssg_off ();
329     }
330
331     if (zargs[0] == 0) {
332         runtime_error (ERR_JIN_0);
333         branch (0 == zargs[1]);
334         return;
335     }
336
337     obj_addr = object_address (zargs[0]);
338
339     if (h_version <= V3) {
340
341         zbyte parent;
342
343         /* Get parent id from object */
344
345         obj_addr += O1_PARENT;
346         LOW_BYTE (obj_addr, parent)
347
348         /* Branch if the parent is obj2 */
349
350         branch (parent == zargs[1]);
351
352     } else {
353
354         zword parent;
355
356         /* Get parent id from object */
357
358         obj_addr += O4_PARENT;
359         LOW_WORD (obj_addr, parent)
360
361         /* Branch if the parent is obj2 */
362
363         branch (parent == zargs[1]);
364
365     }
366
367 }/* z_jin */
368
369 /*
370  * z_get_child, store the child of an object.
371  *
372  *        zargs[0] = object
373  *
374  */
375
376 void z_get_child (void)
377 {
378     zword obj_addr;
379
380     /* If we are monitoring object locating display a short note */
381
382     if (f_setup.object_locating) {
383         stream_mssg_on ();
384         print_string ("@get_child ");
385         print_object (zargs[0]);
386         stream_mssg_off ();
387     }
388
389     if (zargs[0] == 0) {
390         runtime_error (ERR_GET_CHILD_0);
391         store (0);
392         branch (FALSE);
393         return;
394     }
395
396     obj_addr = object_address (zargs[0]);
397
398     if (h_version <= V3) {
399
400         zbyte child;
401
402         /* Get child id from object */
403
404         obj_addr += O1_CHILD;
405         LOW_BYTE (obj_addr, child)
406
407         /* Store child id and branch */
408
409         store (child);
410         branch (child);
411
412     } else {
413
414         zword child;
415
416         /* Get child id from object */
417
418         obj_addr += O4_CHILD;
419         LOW_WORD (obj_addr, child)
420
421         /* Store child id and branch */
422
423         store (child);
424         branch (child);
425
426     }
427
428 }/* z_get_child */
429
430 /*
431  * z_get_next_prop, store the number of the first or next property.
432  *
433  *        zargs[0] = object
434  *        zargs[1] = address of current property (0 gets the first property)
435  *
436  */
437
438 void z_get_next_prop (void)
439 {
440     zword prop_addr;
441     zbyte value;
442     zbyte mask;
443
444     if (zargs[0] == 0) {
445         runtime_error (ERR_GET_NEXT_PROP_0);
446         store (0);
447         return;
448     }
449
450     /* Property id is in bottom five (six) bits */
451
452     mask = (h_version <= V3) ? 0x1f : 0x3f;
453
454     /* Load address of first property */
455
456     prop_addr = first_property (zargs[0]);
457
458     if (zargs[1] != 0) {
459
460         /* Scan down the property list */
461
462         do {
463             LOW_BYTE (prop_addr, value)
464             prop_addr = next_property (prop_addr);
465         } while ((value & mask) > zargs[1]);
466
467         /* Exit if the property does not exist */
468
469         if ((value & mask) != zargs[1])
470             runtime_error (ERR_NO_PROP);
471
472     }
473
474     /* Return the property id */
475
476     LOW_BYTE (prop_addr, value)
477     store ((zword) (value & mask));
478
479 }/* z_get_next_prop */
480
481 /*
482  * z_get_parent, store the parent of an object.
483  *
484  *        zargs[0] = object
485  *
486  */
487
488 void z_get_parent (void)
489 {
490     zword obj_addr;
491
492     /* If we are monitoring object locating display a short note */
493
494     if (f_setup.object_locating) {
495         stream_mssg_on ();
496         print_string ("@get_parent ");
497         print_object (zargs[0]);
498         stream_mssg_off ();
499     }
500
501     if (zargs[0] == 0) {
502         runtime_error (ERR_GET_PARENT_0);
503         store (0);
504         return;
505     }
506
507     obj_addr = object_address (zargs[0]);
508
509     if (h_version <= V3) {
510
511         zbyte parent;
512
513         /* Get parent id from object */
514
515         obj_addr += O1_PARENT;
516         LOW_BYTE (obj_addr, parent)
517
518         /* Store parent */
519
520         store (parent);
521
522     } else {
523
524         zword parent;
525
526         /* Get parent id from object */
527
528         obj_addr += O4_PARENT;
529         LOW_WORD (obj_addr, parent)
530
531         /* Store parent */
532
533         store (parent);
534
535     }
536
537 }/* z_get_parent */
538
539 /*
540  * z_get_prop, store the value of an object property.
541  *
542  *        zargs[0] = object
543  *        zargs[1] = number of property to be examined
544  *
545  */
546
547 void z_get_prop (void)
548 {
549     zword prop_addr;
550     zword wprop_val;
551     zbyte bprop_val;
552     zbyte value;
553     zbyte mask;
554
555     if (zargs[0] == 0) {
556         runtime_error (ERR_GET_PROP_0);
557         store (0);
558         return;
559     }
560
561     /* Property id is in bottom five (six) bits */
562
563     mask = (h_version <= V3) ? 0x1f : 0x3f;
564
565     /* Load address of first property */
566
567     prop_addr = first_property (zargs[0]);
568
569     /* Scan down the property list */
570
571     for (;;) {
572         LOW_BYTE (prop_addr, value)
573         if ((value & mask) <= zargs[1])
574             break;
575         prop_addr = next_property (prop_addr);
576     }
577
578     if ((value & mask) == zargs[1]) {        /* property found */
579
580         /* Load property (byte or word sized) */
581
582         prop_addr++;
583
584         if ((h_version <= V3 && !(value & 0xe0)) || (h_version >= V4 && !(value & 0xc0))) {
585
586             LOW_BYTE (prop_addr, bprop_val)
587             wprop_val = bprop_val;
588
589         } else LOW_WORD (prop_addr, wprop_val)
590
591     } else {        /* property not found */
592
593         /* Load default value */
594
595         prop_addr = h_objects + 2 * (zargs[1] - 1);
596         LOW_WORD (prop_addr, wprop_val)
597
598     }
599
600     /* Store the property value */
601
602     store (wprop_val);
603
604 }/* z_get_prop */
605
606 /*
607  * z_get_prop_addr, store the address of an object property.
608  *
609  *        zargs[0] = object
610  *        zargs[1] = number of property to be examined
611  *
612  */
613
614 void z_get_prop_addr (void)
615 {
616     zword prop_addr;
617     zbyte value;
618     zbyte mask;
619
620     if (zargs[0] == 0) {
621         runtime_error (ERR_GET_PROP_ADDR_0);
622         store (0);
623         return;
624     }
625
626     if (story_id == BEYOND_ZORK)
627         if (zargs[0] > MAX_OBJECT)
628             { store (0); return; }
629
630     /* Property id is in bottom five (six) bits */
631
632     mask = (h_version <= V3) ? 0x1f : 0x3f;
633
634     /* Load address of first property */
635
636     prop_addr = first_property (zargs[0]);
637
638     /* Scan down the property list */
639
640     for (;;) {
641         LOW_BYTE (prop_addr, value)
642         if ((value & mask) <= zargs[1])
643             break;
644         prop_addr = next_property (prop_addr);
645     }
646
647     /* Calculate the property address or return zero */
648
649     if ((value & mask) == zargs[1]) {
650
651         if (h_version >= V4 && (value & 0x80))
652             prop_addr++;
653         store ((zword) (prop_addr + 1));
654
655     } else store (0);
656
657 }/* z_get_prop_addr */
658
659 /*
660  * z_get_prop_len, store the length of an object property.
661  *
662  *         zargs[0] = address of property to be examined
663  *
664  */
665
666 void z_get_prop_len (void)
667 {
668     zword addr;
669     zbyte value;
670
671     /* Back up the property pointer to the property id */
672
673     addr = zargs[0] - 1;
674     LOW_BYTE (addr, value)
675
676     /* Calculate length of property */
677
678     if (h_version <= V3)
679         value = (value >> 5) + 1;
680     else if (!(value & 0x80))
681         value = (value >> 6) + 1;
682     else {
683
684         value &= 0x3f;
685
686         if (value == 0) value = 64;        /* demanded by Spec 1.0 */
687
688     }
689
690     /* Store length of property */
691
692     store (value);
693
694 }/* z_get_prop_len */
695
696 /*
697  * z_get_sibling, store the sibling of an object.
698  *
699  *        zargs[0] = object
700  *
701  */
702
703 void z_get_sibling (void)
704 {
705     zword obj_addr;
706
707     if (zargs[0] == 0) {
708         runtime_error (ERR_GET_SIBLING_0);
709         store (0);
710         branch (FALSE);
711         return;
712     }
713
714     obj_addr = object_address (zargs[0]);
715
716     if (h_version <= V3) {
717
718         zbyte sibling;
719
720         /* Get sibling id from object */
721
722         obj_addr += O1_SIBLING;
723         LOW_BYTE (obj_addr, sibling)
724
725         /* Store sibling and branch */
726
727         store (sibling);
728         branch (sibling);
729
730     } else {
731
732         zword sibling;
733
734         /* Get sibling id from object */
735
736         obj_addr += O4_SIBLING;
737         LOW_WORD (obj_addr, sibling)
738
739         /* Store sibling and branch */
740
741         store (sibling);
742         branch (sibling);
743
744     }
745
746 }/* z_get_sibling */
747
748 /*
749  * z_insert_obj, make an object the first child of another object.
750  *
751  *        zargs[0] = object to be moved
752  *        zargs[1] = destination object
753  *
754  */
755
756 void z_insert_obj (void)
757 {
758     zword obj1 = zargs[0];
759     zword obj2 = zargs[1];
760     zword obj1_addr;
761     zword obj2_addr;
762
763     /* If we are monitoring object movements display a short note */
764
765     if (f_setup.object_movement) {
766         stream_mssg_on ();
767         print_string ("@move_obj ");
768         print_object (obj1);
769         print_string (" ");
770         print_object (obj2);
771         stream_mssg_off ();
772     }
773
774     if (obj1 == 0) {
775         runtime_error (ERR_MOVE_OBJECT_0);
776         return;
777     }
778
779     if (obj2 == 0) {
780         runtime_error (ERR_MOVE_OBJECT_TO_0);
781         return;
782     }
783
784     /* Get addresses of both objects */
785
786     obj1_addr = object_address (obj1);
787     obj2_addr = object_address (obj2);
788
789     /* Remove object 1 from current parent */
790
791     unlink_object (obj1);
792
793     /* Make object 1 first child of object 2 */
794
795     if (h_version <= V3) {
796
797         zbyte child;
798
799         obj1_addr += O1_PARENT;
800         SET_BYTE (obj1_addr, obj2)
801         obj2_addr += O1_CHILD;
802         LOW_BYTE (obj2_addr, child)
803         SET_BYTE (obj2_addr, obj1)
804         obj1_addr += O1_SIBLING - O1_PARENT;
805         SET_BYTE (obj1_addr, child)
806
807     } else {
808
809         zword child;
810
811         obj1_addr += O4_PARENT;
812         SET_WORD (obj1_addr, obj2)
813         obj2_addr += O4_CHILD;
814         LOW_WORD (obj2_addr, child)
815         SET_WORD (obj2_addr, obj1)
816         obj1_addr += O4_SIBLING - O4_PARENT;
817         SET_WORD (obj1_addr, child)
818
819     }
820
821 }/* z_insert_obj */
822
823 /*
824  * z_put_prop, set the value of an object property.
825  *
826  *        zargs[0] = object
827  *        zargs[1] = number of property to set
828  *        zargs[2] = value to set property to
829  *
830  */
831
832 void z_put_prop (void)
833 {
834     zword prop_addr;
835     zword value;
836     zbyte mask;
837
838     if (zargs[0] == 0) {
839         runtime_error (ERR_PUT_PROP_0);
840         return;
841     }
842
843     /* Property id is in bottom five or six bits */
844
845     mask = (h_version <= V3) ? 0x1f : 0x3f;
846
847     /* Load address of first property */
848
849     prop_addr = first_property (zargs[0]);
850
851     /* Scan down the property list */
852
853     for (;;) {
854         LOW_BYTE (prop_addr, value)
855         if ((value & mask) <= zargs[1])
856             break;
857         prop_addr = next_property (prop_addr);
858     }
859
860     /* Exit if the property does not exist */
861
862     if ((value & mask) != zargs[1])
863         runtime_error (ERR_NO_PROP);
864
865     /* Store the new property value (byte or word sized) */
866
867     prop_addr++;
868
869     if ((h_version <= V3 && !(value & 0xe0)) || (h_version >= V4 && !(value & 0xc0))) {
870         zbyte v = zargs[2];
871         SET_BYTE (prop_addr, v)
872     } else {
873         zword v = zargs[2];
874         SET_WORD (prop_addr, v)
875     }
876
877 }/* z_put_prop */
878
879 /*
880  * z_remove_obj, unlink an object from its parent and siblings.
881  *
882  *        zargs[0] = object
883  *
884  */
885
886 void z_remove_obj (void)
887 {
888
889     /* If we are monitoring object movements display a short note */
890
891     if (f_setup.object_movement) {
892         stream_mssg_on ();
893         print_string ("@remove_obj ");
894         print_object (zargs[0]);
895         stream_mssg_off ();
896     }
897
898     /* Call unlink_object to do the job */
899
900     unlink_object (zargs[0]);
901
902 }/* z_remove_obj */
903
904 /*
905  * z_set_attr, set an object attribute.
906  *
907  *        zargs[0] = object
908  *        zargs[1] = number of attribute to set
909  *
910  */
911
912 void z_set_attr (void)
913 {
914     zword obj_addr;
915     zbyte value;
916
917     if (story_id == SHERLOCK)
918         if (zargs[1] == 48)
919             return;
920
921     if (zargs[1] > ((h_version <= V3) ? 31 : 47))
922         runtime_error (ERR_ILL_ATTR);
923
924     /* If we are monitoring attribute assignment display a short note */
925
926     if (f_setup.attribute_assignment) {
927         stream_mssg_on ();
928         print_string ("@set_attr ");
929         print_object (zargs[0]);
930         print_string (" ");
931         print_num (zargs[1]);
932         stream_mssg_off ();
933     }
934
935     if (zargs[0] == 0) {
936         runtime_error (ERR_SET_ATTR_0);
937         return;
938     }
939
940     /* Get attribute address */
941
942     obj_addr = object_address (zargs[0]) + zargs[1] / 8;
943
944     /* Load attribute byte */
945
946     LOW_BYTE (obj_addr, value)
947
948     /* Set attribute bit */
949
950     value |= 0x80 >> (zargs[1] & 7);
951
952     /* Store attribute byte */
953
954     SET_BYTE (obj_addr, value)
955
956 }/* z_set_attr */
957
958 /*
959  * z_test_attr, branch if an object attribute is set.
960  *
961  *        zargs[0] = object
962  *        zargs[1] = number of attribute to test
963  *
964  */
965
966 void z_test_attr (void)
967 {
968     zword obj_addr;
969     zbyte value;
970
971     if (zargs[1] > ((h_version <= V3) ? 31 : 47))
972         runtime_error (ERR_ILL_ATTR);
973
974     /* If we are monitoring attribute testing display a short note */
975
976     if (f_setup.attribute_testing) {
977         stream_mssg_on ();
978         print_string ("@test_attr ");
979         print_object (zargs[0]);
980         print_string (" ");
981         print_num (zargs[1]);
982         stream_mssg_off ();
983     }
984
985     if (zargs[0] == 0) {
986         runtime_error (ERR_TEST_ATTR_0);
987         branch (FALSE);
988         return;
989     }
990
991     /* Get attribute address */
992
993     obj_addr = object_address (zargs[0]) + zargs[1] / 8;
994
995     /* Load attribute byte */
996
997     LOW_BYTE (obj_addr, value)
998
999     /* Test attribute */
1000
1001     branch (value & (0x80 >> (zargs[1] & 7)));
1002
1003 }/* z_test_attr */