verbs.zil 51.2 KB
Newer Older
1
2
"Verbs"

Tara McGrew's avatar
Tara McGrew committed
3
4
<DIRECTIONS NORTH SOUTH EAST WEST NORTHEAST NORTHWEST SOUTHEAST SOUTHWEST
            IN OUT UP DOWN>
5
6
7
8
9
10
11
12
13

<SYNONYM NORTH N>
<SYNONYM SOUTH S>
<SYNONYM EAST E>
<SYNONYM WEST W>
<SYNONYM NORTHEAST NE>
<SYNONYM NORTHWEST NW>
<SYNONYM SOUTHEAST SE>
<SYNONYM SOUTHWEST SW>
14
15
<SYNONYM IN INTO INSIDE>
<SYNONYM OUT OUTSIDE>
16
17
18
<SYNONYM UP U>
<SYNONYM DOWN D>

19
20
<SYNONYM THROUGH THRU>

21
22
;"Syntaxes for regular verbs"

23
24
25
26
<SYNTAX LOOK = V-LOOK>
<VERB-SYNONYM LOOK L>

<SYNTAX WALK OBJECT = V-WALK>
27
28
<SYNTAX WALK IN OBJECT (FIND DOORBIT) (IN-ROOM) = V-ENTER>
<SYNTAX WALK THROUGH OBJECT (FIND DOORBIT) (IN-ROOM) = V-ENTER>
29
30
<VERB-SYNONYM WALK GO>

31
32
<SYNTAX ENTER OBJECT (FIND DOORBIT) (IN-ROOM) = V-ENTER>

33
34
<SYNTAX QUIT = V-QUIT>

35
<SYNTAX TAKE OBJECT (FIND TAKEBIT) (MANY ON-GROUND IN-ROOM) = V-TAKE>
36
<VERB-SYNONYM TAKE GRAB>
37
38
39
<SYNTAX PICK UP OBJECT (FIND TAKEBIT) (MANY ON-GROUND IN-ROOM) = V-TAKE>
<SYNTAX PICK OBJECT (FIND TAKEBIT) (MANY ON-GROUND IN-ROOM) UP OBJECT (FIND KLUDGEBIT) = V-TAKE>
<SYNTAX GET OBJECT (FIND TAKEBIT) (MANY ON-GROUND IN-ROOM) = V-TAKE>
40

41
42
43
<SYNTAX DROP OBJECT (MANY HAVE HELD CARRIED) = V-DROP>
<SYNTAX PUT DOWN OBJECT (MANY HAVE HELD CARRIED) = V-DROP>
<SYNTAX PUT OBJECT (MANY HAVE HELD CARRIED) DOWN OBJECT (FIND KLUDGEBIT) = V-DROP>
44

45
46
<SYNTAX EXAMINE OBJECT = V-EXAMINE PRE-REQUIRES-LIGHT>
<SYNTAX LOOK AT OBJECT = V-EXAMINE PRE-REQUIRES-LIGHT>
47
48
49
50
51
52
53
54
55
56
<VERB-SYNONYM EXAMINE X>

<SYNTAX WEAR OBJECT (FIND WEARBIT) (HAVE TAKE) = V-WEAR>
<VERB-SYNONYM WEAR DON>
<SYNTAX PUT ON OBJECT (FIND WEARBIT) (HAVE TAKE) = V-WEAR>

<SYNTAX UNWEAR OBJECT (FIND WORNBIT) (HAVE HELD CARRIED) = V-UNWEAR>
<VERB-SYNONYM UNWEAR DOFF>
<SYNTAX TAKE OFF OBJECT (FIND WORNBIT) (HAVE HELD CARRIED) = V-UNWEAR>

57
58
<SYNTAX PUT OBJECT (MANY TAKE HELD CARRIED ON-GROUND IN-ROOM) ON OBJECT (FIND SURFACEBIT) = V-PUT-ON PRE-PUT-ON>
<SYNTAX PUT UP OBJECT (MANY TAKE HELD CARRIED ON-GROUND IN-ROOM) ON OBJECT (FIND SURFACEBIT) = V-PUT-ON PRE-PUT-ON>
59
60
<VERB-SYNONYM PUT HANG PLACE>

61
<SYNTAX PUT OBJECT (MANY TAKE HELD CARRIED ON-GROUND IN-ROOM) IN OBJECT (FIND CONTBIT) = V-PUT-IN PRE-PUT-IN>
62
63
64
65
66
67
68
69
70
<VERB-SYNONYM PUT PLACE INSERT>

<SYNTAX INVENTORY = V-INVENTORY>
<VERB-SYNONYM INVENTORY I>

<SYNTAX CONTEMPLATE OBJECT = V-THINK-ABOUT>
<VERB-SYNONYM CONTEMPLATE CONSIDER>
<SYNTAX THINK ABOUT OBJECT = V-THINK-ABOUT>

71
<SYNTAX OPEN OBJECT (FIND OPENABLEBIT) = V-OPEN>
72

73
<SYNTAX CLOSE OBJECT (FIND OPENBIT) = V-CLOSE>
74
75
76
77
78
<VERB-SYNONYM CLOSE SHUT>

<SYNTAX LOCK OBJECT WITH OBJECT (HAVE HELD CARRIED) = V-LOCK>

<SYNTAX UNLOCK OBJECT (FIND LOCKEDBIT) WITH OBJECT (HAVE HELD CARRIED) = V-UNLOCK>
79

80
<SYNTAX TURN ON OBJECT (FIND DEVICEBIT) = V-TURN-ON>
81
<SYNTAX TURN OBJECT (FIND DEVICEBIT) ON OBJECT (FIND KLUDGEBIT) = V-TURN-ON>
82

83
<SYNTAX TURN OFF OBJECT (FIND DEVICEBIT) = V-TURN-OFF>
84
<SYNTAX TURN OBJECT (FIND DEVICEBIT) OFF OBJECT (FIND KLUDGEBIT) = V-TURN-OFF>
85

86
<SYNTAX FLIP OBJECT (FIND DEVICEBIT) = V-FLIP>
87
<VERB-SYNONYM FLIP SWITCH TOGGLE>
88
89
90
91
92
93
94

<SYNTAX WAIT = V-WAIT>
<VERB-SYNONYM WAIT Z>

<SYNTAX AGAIN = V-AGAIN>
<VERB-SYNONYM AGAIN G>

95
<SYNTAX READ OBJECT (FIND READBIT) (TAKE HELD CARRIED ON-GROUND IN-ROOM) = V-READ PRE-REQUIRES-LIGHT>
96
97
<VERB-SYNONYM READ PERUSE>

98
<SYNTAX EAT OBJECT (FIND EDIBLEBIT) (TAKE HELD CARRIED ON-GROUND IN-ROOM) = V-EAT>
99
100
<VERB-SYNONYM EAT SCARF DEVOUR GULP CHEW>

101
102
103
104
<SYNTAX DRINK OBJECT = V-DRINK>

<SYNTAX SMELL OBJECT = V-SMELL>

105
106
107
<SYNTAX PUSH OBJECT = V-PUSH>
<VERB-SYNONYM PUSH SHOVE>

108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
<SYNTAX PULL OBJECT = V-PULL>
<VERB-SYNONYM PULL YANK DRAG CARRY>

<SYNTAX FILL OBJECT (FIND CONTBIT) = V-FILL>
<SYNTAX EMPTY OBJECT (FIND CONTBIT) = V-EMPTY>

<SYNTAX ATTACK OBJECT = V-ATTACK>
<VERB-SYNONYM ATTACK HIT SMASH BREAK KILL DESTROY>

<SYNTAX GIVE OBJECT (HAVE HELD CARRIED) TO OBJECT (FIND PERSONBIT) = V-GIVE>
<SYNTAX GIVE OBJECT (FIND PERSONBIT) OBJECT (HAVE HELD CARRIED) = V-SGIVE>

<SYNTAX WAVE = V-WAVE-HANDS>
<SYNTAX WAVE OBJECT (TAKE HAVE HELD CARRIED) = V-WAVE>

<SYNTAX THROW OBJECT (TAKE HAVE HELD CARRIED) AT OBJECT (ON-GROUND IN-ROOM) = V-THROW-AT>

<SYNTAX BURN OBJECT ;(FIND BURNBIT) = V-BURN>
<VERB-SYNONYM BURN ROAST TORCH>

<SYNTAX RUB OBJECT = V-RUB>

<SYNTAX LOOK UNDER OBJECT (FIND SURFACEBIT) = V-LOOK-UNDER PRE-REQUIRES-LIGHT>

<SYNTAX SEARCH OBJECT (FIND CONTBIT) = V-SEARCH PRE-REQUIRES-LIGHT>
<SYNTAX LOOK IN OBJECT (FIND CONTBIT) = V-SEARCH PRE-REQUIRES-LIGHT>

<SYNTAX WAKE OBJECT (FIND PERSONBIT) = V-WAKE>
<SYNTAX WAKE UP OBJECT (FIND PERSONBIT) = V-WAKE>
<SYNTAX WAKE OBJECT (FIND PERSONBIT) UP OBJECT (FIND KLUDGEBIT) = V-WAKE>

<SYNTAX JUMP = V-JUMP>
<SYNTAX SWIM = V-SWIM>
<SYNTAX CLIMB = V-CLIMB>
<SYNTAX CLIMB OBJECT = V-CLIMB>

<SYNTAX YES = V-YES>
<SYNTAX NO = V-NO>

;"Syntaxes for game verbs"

149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
<SYNTAX VERSION = V-VERSION>

<SYNTAX UNDO = V-UNDO>
<SYNTAX SAVE = V-SAVE>
<SYNTAX RESTORE = V-RESTORE>
<SYNTAX RESTART = V-RESTART>

<SYNTAX BRIEF = V-BRIEF>
<SYNTAX SUPERBRIEF = V-SUPERBRIEF>
<SYNTAX VERBOSE = V-VERBOSE>

;"debugging verbs - remove"
<IF-DEBUG
    <SYNTAX DROB OBJECT = V-DROB>
    <SYNTAX DSEND OBJECT TO OBJECT = V-DSEND>
    <SYNTAX DOBJL OBJECT = V-DOBJL>
    ;<SYNTAX DVIS = V-DVIS>
    ;<SYNTAX DMETALOC OBJECT = V-DMETALOC>
    ;<SYNTAX DACCESS OBJECT = V-DACCESS>
    ;<SYNTAX DHELD OBJECT IN OBJECT = V-DHELD>
    ;<SYNTAX DHELDP OBJECT = V-DHELDP>
    ;<SYNTAX DLIGHT = V-DLIGHT>
    <SYNTAX DCONT = V-DCONT>
    <SYNTAX DTURN = V-DTURN>
>

175
176
177
178
179
180
181
;"Constants"

;"TODO: these belong in parser.zil?"
;"Room action handlers may get: M-BEG, M-END, M-ENTER, M-LOOK"
;"Object DESCFCNs may get: M-OBJDESC?, no arg"
;"DARKNESS-F may get: M-LOOK, M-SCOPE?, M-LIT-TO-DARK, M-DARK-TO-LIT,
    M-DARK-TO-DARK, M-DARK-CANT-GO"
182
183
184
185
<CONSTANT M-BEG 1>
<CONSTANT M-END 2>
<CONSTANT M-ENTER 3>
<CONSTANT M-LOOK 4>
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
<CONSTANT M-OBJDESC? 5>
<CONSTANT M-SCOPE? 6>
<CONSTANT M-LIT-TO-DARK 7>
<CONSTANT M-DARK-TO-LIT 8>
<CONSTANT M-DARK-TO-DARK 9>
<CONSTANT M-DARK-CANT-GO 10>
<CONSTANT M-NOW-DARK 11>
<CONSTANT M-NOW-LIT 12>

;"Helper routines for action handlers"

<ROUTINE YOU-MASHER ("OPT" WHOM)
    <TELL "I don't think " T <OR .WHOM ,PRSO> " would appreciate that." CR>>

<ROUTINE POINTLESS (VING "OPT" PREP REV? "AUX" F S)
    <COND (.REV? <SET F ,PRSI> <SET S ,PRSO>)
          (ELSE <SET F ,PRSO> <SET S ,PRSI>)>
    <TELL .VING>
    <COND (.F
           <TELL !\  T .F>
           <COND (.PREP
                  <TELL !\  .PREP>
                  <COND (.S <TELL !\  T .S>)>)>)>
    <TELL " doesn't seem like it will help." CR>>

<ROUTINE NOT-POSSIBLE (V)
    <TELL "That's not something you can " .V "." CR>>

<ROUTINE RHETORICAL ()
    <TELL "That was a rhetorical question." CR>>

<ROUTINE BE-SPECIFIC ()
    <TELL "You'll have to be more specific." CR>>

<ROUTINE SILLY ()
    <TELL "You must be joking." CR>>

<ROUTINE TSD ()
    <TELL "Not here, not now." CR>>

<DEFMAC IF-PLURAL ('O 'IF-PL 'IF-SG)
    <FORM COND <LIST <FORM FSET? .O ',PLURALBIT> .IF-PL> <LIST ELSE .IF-SG>>>

<ROUTINE PRE-REQUIRES-LIGHT ()
    <COND (<NOT ,HERE-LIT> <TELL "It's too dark to see anything here." CR>)>>

;"Action handler routines"
233
234
235

<ROUTINE V-BRIEF ()
    <TELL "Brief descriptions." CR>
Tara McGrew's avatar
Tara McGrew committed
236
    <SETG MODE ,BRIEF>>
237
238
239
240

<ROUTINE V-VERBOSE ()
    <TELL "Verbose descriptions." CR>
    <SETG MODE ,VERBOSE>
Tara McGrew's avatar
Tara McGrew committed
241
    <V-LOOK>>
242
243
244

<ROUTINE V-SUPERBRIEF ()
    <TELL "Superbrief descriptions." CR>
Tara McGrew's avatar
Tara McGrew committed
245
    <SETG MODE ,SUPERBRIEF>>
246
247

<ROUTINE V-LOOK ()
Tara McGrew's avatar
Tara McGrew committed
248
249
    <COND (<DESCRIBE-ROOM ,HERE T>
           <DESCRIBE-OBJECTS ,HERE>)>>
250

251
252
;"Prints a room description, handling darkness and briefness.

253
254
255
256
257
258
If the room is HERE and the player doesn't have a light source, this prints
a generic room name and description.

Otherwise, the real name is printed, optionally followed by a description
(if MODE is VERBOSE, or if it's BRIEF and this is the first time describing
the room, or if LONG is true).
259
260
261
262
263
264
265
266
267
268
269

Uses:
  MODE

Args:
  RM: The room to describe.
  LONG: If true, print the room description even in BRIEF mode.

Returns:
  True if the objects in the room should also be described, otherwise
  false."
270
271
<ROUTINE DESCRIBE-ROOM (RM "OPT" LONG "AUX" P)
    <COND
272
        (<AND <==? .RM ,HERE> <NOT ,HERE-LIT>>
273
         <DARKNESS-F ,M-LOOK>
Tara McGrew's avatar
Tara McGrew committed
274
         <RFALSE>)
Tara McGrew's avatar
Tara McGrew committed
275
        (ELSE
Tara McGrew's avatar
Tara McGrew committed
276
277
         ;"print the room's real name"
         <TELL D .RM CR>
278
279
280
281
282
283
284
         ;"If this is an implicit LOOK, check briefness."
         <COND (<NOT .LONG>
                <COND (<EQUAL? ,MODE ,SUPERBRIEF>
                       <RFALSE>)
                      (<AND <FSET? .RM ,TOUCHBIT>
                            <NOT <EQUAL? ,MODE ,VERBOSE>>>
                       <RTRUE>)>)>
Tara McGrew's avatar
Tara McGrew committed
285
         <FSET .RM ,TOUCHBIT>
Tara McGrew's avatar
Tara McGrew committed
286
287
288
289
         ;"either print the room's LDESC or call its ACTION with M-LOOK"
         <COND (<SET P <GETP .RM ,P?LDESC>>
                <TELL .P CR>)
               (ELSE
290
291
                <APPLY <GETP .RM ,P?ACTION> ,M-LOOK>)>
         <RTRUE>)>>
Tara McGrew's avatar
Tara McGrew committed
292

293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
<DEFAULT-DEFINITION DARKNESS-F

    <ROUTINE DARKNESS-F (ARG)
        <COND (<=? .ARG ,M-LOOK>
               <TELL "It is pitch black. You can't see a thing." CR>)
              (<=? .ARG ,M-SCOPE?>
               <T? <SCOPE-STAGE? GENERIC INVENTORY GLOBALS>>)
              (<=? .ARG ,M-NOW-DARK>
               <TELL "You are plunged into darkness." CR>)
              (<=? .ARG ,M-NOW-LIT>
               <TELL "You can see your surroundings now." CR CR>
               <RFALSE>)
              (ELSE <RFALSE>)>>
>

308
309
310
311
312
313
314
315
316
317
318
319
320
;"Describes the objects in a room.

Objects are described in four passes:
1. All non-person objects with DESCFCNs, FDESCS, and LDESCs.
2. All non-person objects not covered by #1.
3. The visible contents of containers and surfaces.
4. All objects with PERSONBIT other than WINNER.

Uses:
  WINNER

Args:
  RM: The room."
Tara McGrew's avatar
Tara McGrew committed
321
<ROUTINE DESCRIBE-OBJECTS (RM "AUX" P F N S)
322
323
    <MAP-CONTENTS (I .RM)
        <COND
324
            ;"objects with DESCFCNs"
Tara McGrew's avatar
Tara McGrew committed
325
326
327
328
            (<SET P <GETP .I ,P?DESCFCN>>
             <CRLF>
             <APPLY .P>
             <CRLF>)
Tara McGrew's avatar
Tara McGrew committed
329
            ;"un-moved objects with FDESCs"
Tara McGrew's avatar
Tara McGrew committed
330
331
332
333
334
335
            (<AND <NOT <FSET? .I ,TOUCHBIT>>
                  <SET P <GETP .I ,P?FDESC>>>
             <TELL CR .P CR>)
            ;"objects with LDESCs"
            (<SET P <GETP .I ,P?LDESC>>
             <TELL CR .P CR>)>>
336
    ;"See if there are any non fdesc, ndescbit, personbit objects in room"
Tara McGrew's avatar
Tara McGrew committed
337
    <MAP-CONTENTS (I .RM)
338
        <COND (<GENERIC-DESC? .I>
339
340
               <SET N T>
               <RETURN>)>>
Tara McGrew's avatar
Tara McGrew committed
341
    ;"go through the N objects"
342
    <COND (.N
Tara McGrew's avatar
Tara McGrew committed
343
           <TELL CR "There ">
344
           <LIST-OBJECTS .RM GENERIC-DESC? ,L-ISMANY>
Tara McGrew's avatar
Tara McGrew committed
345
346
347
           <TELL " here." CR>)>
    ;"describe visible contents of containers and surfaces"
    <MAP-CONTENTS (I .RM)
348
        <COND (<AND <NOT <FSET? .I ,NDESCBIT>>
Tara McGrew's avatar
Tara McGrew committed
349
                    <FIRST? .I>
350
                    <SEE-INSIDE? .I>>
Tara McGrew's avatar
Tara McGrew committed
351
               <DESCRIBE-CONTENTS .I>)>>
352
353
    ;"See if there are any NPCs"
    <SET N <>>
Tara McGrew's avatar
Tara McGrew committed
354
    <MAP-CONTENTS (I .RM)
355
        <COND (<NPC-DESC? .I>
356
357
               <SET N T>
               <RETURN>)>>
Tara McGrew's avatar
Tara McGrew committed
358
    ;"go through the N NPCs"
359
    <COND (.N
360
           <LIST-OBJECTS .RM NPC-DESC? ,L-SUFFIX>
361
           <TELL " here." CR>)>>
362

363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
<ROUTINE GENERIC-DESC? (OBJ "AUX" P)
    <T? <NOT <OR <==? .OBJ ,WINNER>
                 <FSET? .OBJ ,NDESCBIT>
                 <FSET? .OBJ ,PERSONBIT>
                 <AND <NOT <FSET? .OBJ ,TOUCHBIT>>
                      <GETP .OBJ ,P?FDESC>>
                 <GETP .OBJ ,P?LDESC>
                 <AND <SET P <GETP .OBJ ,P?DESCFCN>> <APPLY .P ,M-OBJDESC?>>>>>>

<ROUTINE NPC-DESC? (OBJ "AUX" P)
    <T? <AND <FSET? .OBJ ,PERSONBIT>
             <NOT <OR <==? .OBJ ,WINNER>
                      <FSET? .OBJ ,NDESCBIT>
                      <AND <NOT <FSET? .OBJ ,TOUCHBIT>>
                           <GETP .OBJ ,P?FDESC>>
                      <GETP .OBJ ,P?LDESC>
                      <AND <SET P <GETP .OBJ ,P?DESCFCN>> <APPLY .P ,M-OBJDESC?>>>>>>>
                      

382

383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
;"Prints a (short) string with the first letter capitalized."
<ROUTINE PRINT-CAP-STR (S "AUX" MAX C)
    <DIROUT 3 ,TEMPTABLE>
    <PRINT .S>
    <DIROUT -3>
    <SET MAX <GET ,TEMPTABLE 0>>
    <COND (.MAX
           <INC MAX>
           <DO (I 2 .MAX)
               <SET C <GETB ,TEMPTABLE .I>>
               <COND (<AND <=? .I 2> <G=? .C !\a> <L=? .C !\z>>
                      <SET C <- .C %<- <ASCII !\a> <ASCII !\A>>>>)>
               <PRINTC .C>>)>>

;"Prints an object name with the first letter capitalized."
<ROUTINE PRINT-CAP-OBJ (OBJ "AUX" MAX C)
    <DIROUT 3 ,TEMPTABLE>
    <PRINTD .OBJ>
    <DIROUT -3>
    <SET MAX <GET ,TEMPTABLE 0>>
    <COND (.MAX
           <INC MAX>
           <DO (I 2 .MAX)
               <SET C <GETB ,TEMPTABLE .I>>
               <COND (<AND <=? .I 2> <G=? .C !\a> <L=? .C !\z>>
                      <SET C <- .C %<- <ASCII !\a> <ASCII !\A>>>>)>
               <PRINTC .C>>)>>
410

411
;"Implements <TELL A .OBJ>."
412
413
414
415
416
417
418
<ROUTINE PRINT-INDEF (OBJ "AUX" A)
    <COND (<FSET? .OBJ ,NARTICLEBIT>)
          (<SET A <GETP .OBJ ,P?ARTICLE>> <TELL .A> <PRINTC !\ >)
          (<FSET? .OBJ ,PLURALBIT> <TELL "some ">)
          (<FSET? .OBJ ,VOWELBIT> <TELL "an ">)
          (ELSE <TELL "a ">)>
    <PRINTD .OBJ>>
Tara McGrew's avatar
Tara McGrew committed
419

420
;"Implements <TELL T .OBJ>."
Tara McGrew's avatar
Tara McGrew committed
421
<ROUTINE PRINT-DEF (OBJ)
422
423
    <COND (<NOT <FSET? .OBJ ,NARTICLEBIT>> <TELL "the ">)>
    <PRINTD .OBJ>>
Tara McGrew's avatar
Tara McGrew committed
424

425
;"Implements <TELL CA .OBJ>."
426
427
428
429
430
431
432
433
434
<ROUTINE PRINT-CINDEF (OBJ "AUX" A)
    <COND (<FSET? .OBJ ,NARTICLEBIT>
           <PRINT-CAP-OBJ .OBJ>
           <RTRUE>)>
    <COND (<SET A <GETP .OBJ ,P?ARTICLE>> <PRINT-CAP-STR .A> <PRINTC !\ >)
          (<FSET? .OBJ ,PLURALBIT> <TELL "Some ">)
          (<FSET? .OBJ ,VOWELBIT> <TELL "An ">)
          (ELSE <TELL "A ">)>
    <PRINTD .OBJ>>
Tara McGrew's avatar
Tara McGrew committed
435

436
;"Implements <TELL CT .OBJ>."
Tara McGrew's avatar
Tara McGrew committed
437
<ROUTINE PRINT-CDEF (OBJ)
438
439
440
441
    <COND (<FSET? .OBJ ,NARTICLEBIT>
           <PRINT-CAP-OBJ .OBJ>
           <RTRUE>)
          (ELSE <TELL "The " D .OBJ>)>>
442

443
;"Prints a sentence describing the contents of a surface or container."
444
445
<ROUTINE DESCRIBE-CONTENTS (OBJ)
    <COND (<FSET? .OBJ ,SURFACEBIT> <TELL "On">)
Tara McGrew's avatar
Tara McGrew committed
446
          (ELSE <TELL "In">)>
447
    <TELL " " T .OBJ " ">
448
    <LIST-OBJECTS .OBJ ,L-ISARE>
449
    <TELL "." CR>>
Tara McGrew's avatar
Tara McGrew committed
450

451
452
;"Prints a space followed by a parenthetical describing the contents of a
surface or container, for use in inventory listings."
453
454
<ROUTINE INV-DESCRIBE-CONTENTS (OBJ "AUX" N F)
    <COND (<FSET? .OBJ ,SURFACEBIT> <TELL " (holding ">)
Tara McGrew's avatar
Tara McGrew committed
455
          (ELSE <TELL " (containing ">)>
456
457
    <SET F <FIRST? .OBJ>>
    <COND (<NOT .F>
Tara McGrew's avatar
Tara McGrew committed
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
           <TELL "nothing)">
           <RETURN>)>
    <MAP-CONTENTS (I .OBJ)
        <SET N <+ .N 1>>>
    <COND (<==? .N 1>
           <TELL A .F>)
          (<==? .N 2>
           <TELL A .F " and " A <NEXT? .F>>)
          (ELSE
           <MAP-CONTENTS (I .OBJ)
               <TELL A .I>
               <SET N <- .N 1>>
               <COND (<0? .N>)
                     (<==? .N 1> <TELL ", and ">)
                     (ELSE <TELL ", ">)>>)>
    <TELL ")">>
Tara McGrew's avatar
Tara McGrew committed
474

475
476
;"Prints a list describing a set of objects, usually the contents of a
surface or container.
477

478
479
480
481
No trailing punctuation is printed.

If the L-ISARE flag is passed, the list begins with 'is' or 'are' depending
on the count and plurality of the child objects. For example:
482
483
484
485
486
487
488
489
490
491
492
493
494
495

  If the container is empty:
    is nothing

  If the container has one singular object:
    is a shirt

  If the container has one plural object:
    are some pants

  If the container has two objects:
    are a shirt and a hat

  If the container has three objects:
496
497
498
    are a shirt, a hat, and a watch

Args:
499
500
  O: The object whose contents are to be listed, or if L-PRSTABLE is given,
    the address of a table containing the objects.
501
502
503
504
  FILTER: An optional routine to select children to list.
    If provided, the list will only include objects for which the filter
    returns true; otherwise it'll list all contents.
  FLAGS: A combination of option flags:
505
506
    L-ISARE: Print 'is' or 'are'.
    L-SUFFIX: Print the verb after the list instead of before. (Implies L-ISARE.)
507
    L-ISMANY: Use 'is' before a list of objects unless the first one has
508
509
510
511
512
      PLURALBIT. (Implies L-ISARE. Ignored if L-SUFFIX is given.)
    L-PRSTABLE: List objects from a table instead of the contents of another
      object. O is the address of the table in P-PRSOS/P-PRSIS format.
    L-THE: Print the definite article instead of indefinite.
    L-OR: Print 'or' instead of 'and'.
513
514
515

Returns:
  The number of objects listed."
516
517
518
519
520
521
522
<ROUTINE LIST-OBJECTS (O "OPT" FILTER FLAGS "AUX" N F S MAX J)
    <COND (<OR <BTST .FLAGS ,L-SUFFIX> <BTST .FLAGS ,L-ISMANY>>
           <SET FLAGS <BOR .FLAGS ,L-ISARE>>)>
    <COND (<BTST .FLAGS ,L-PRSTABLE>
           <COND (<SET MAX <GETB .O 0>>
                  <DO (I 1 .MAX)
                      <SET J <GET/B .O .I>>
523
524
525
                      <COND (<OR <NOT .FILTER> <APPLY .FILTER .J>>
                             <COND (<0? .F> <SET F .J>)
                                   (<0? .S> <SET S .J>)>
526
527
528
529
530
531
532
                             <SET N <+ .N 1>>)>>)>)
          (ELSE
           <MAP-CONTENTS (I .O)
               <COND (<OR <NOT .FILTER> <APPLY .FILTER .I>>
                      <COND (<0? .F> <SET F .I>)
                            (<0? .S> <SET S .I>)>
                      <SET N <+ .N 1>>)>>)>
533
534
535
    <COND (<==? .N 0>
           <COND (<BTST .FLAGS ,L-SUFFIX>
                  <TELL "nothing is">)
536
537
538
                 (<BTST .FLAGS ,L-ISARE>
                  <TELL "is nothing">)
                 (ELSE <TELL "nothing">)>)
539
          (<==? .N 1>
540
541
542
543
           <AND <BTST .FLAGS ,L-SUFFIX>
                <COND (<BTST .FLAGS ,L-THE> <TELL T .F>) (ELSE <TELL A .F>)>>
           <AND <BTST .FLAGS ,L-ISARE>
                <IF-PLURAL .F <TELL "are "> <TELL "is ">>>
544
           <OR <BTST .FLAGS ,L-SUFFIX>
545
546
547
548
549
550
551
552
553
554
555
                <COND (<BTST .FLAGS ,L-THE> <TELL T .F>) (ELSE <TELL A .F>)>>)
          (<==? .N 2>
           <COND (<AND <BTST .FLAGS ,L-ISARE>
                       <NOT <BTST .FLAGS ,L-SUFFIX>>>
                       <COND (<OR <NOT <BTST .FLAGS ,L-ISMANY>>
                                  <FSET? .F ,PLURALBIT>>
                              <TELL "are ">)
                             (ELSE <TELL "is ">)>)>
           <COND (<BTST .FLAGS ,L-THE> <TELL T .F>) (ELSE <TELL A .F>)>
           <COND (<BTST .FLAGS ,L-OR> <TELL " or ">) (ELSE <TELL " and ">)>
           <COND (<BTST .FLAGS ,L-THE> <TELL T .S>) (ELSE <TELL A .S>)>
556
           <AND <BTST .FLAGS ,L-SUFFIX> <TELL " are">>)
Tara McGrew's avatar
Tara McGrew committed
557
          (ELSE
558
           <COND (<AND <BTST .FLAGS ,L-ISARE>
559
                       <NOT <BTST .FLAGS ,L-SUFFIX>>>
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
                  <COND (<OR <NOT <BTST .FLAGS ,L-ISMANY>>
                             <FSET? .F ,PLURALBIT>>
                         <TELL "are ">)
                        (ELSE <TELL "is ">)>)>
           <COND (<BTST .FLAGS ,L-PRSTABLE>
                  <DO (I 1 .MAX)
                      <SET J <GET/B .O .I>>
                      <COND (<OR <NOT .FILTER> <APPLY .FILTER .J>>
                             <COND (<BTST .FLAGS ,L-THE> <TELL T .J>)
                                   (ELSE <TELL A .J>)>
                             <SET N <- .N 1>>
                             <COND (<0? .N>)
                                   (<==? .N 1>
                                    <COND (<BTST .FLAGS ,L-OR> <TELL ", or ">)
                                          (ELSE <TELL ", and ">)>)
                                   (ELSE <TELL ", ">)>)>>)
                 (ELSE
                  <MAP-CONTENTS (I .O)
                      <COND (<OR <NOT .FILTER> <APPLY .FILTER .I>>
                             <COND (<BTST .FLAGS ,L-THE> <TELL T .I>)
                                   (ELSE <TELL A .I>)>
                             <SET N <- .N 1>>
                             <COND (<0? .N>)
                                   (<==? .N 1>
                                    <COND (<BTST .FLAGS ,L-OR> <TELL ", or ">)
                                          (ELSE <TELL ", and ">)>)
                                   (ELSE <TELL ", ">)>)>>)>
587
588
589
           <AND <BTST .FLAGS ,L-SUFFIX> <TELL " are">>)>
    <RETURN .N>>

590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
;"Direction properties have a different format on V4+, where object numbers are words."
<VERSION?
    (ZIP
        <CONSTANT UEXIT 1>          ;"size of unconditional exit"
        <CONSTANT NEXIT 2>          ;"size of non-exit"
        <CONSTANT FEXIT 3>          ;"size of function exit"
        <CONSTANT CEXIT 4>          ;"size of conditional exit"
        <CONSTANT DEXIT 5>          ;"size of door exit"

        <CONSTANT EXIT-RM 0>        ;GET/B
        <CONSTANT NEXIT-MSG 0>      ;GET
        <CONSTANT FEXIT-RTN 0>      ;GET
        <CONSTANT CEXIT-VAR 1>      ;GETB
        <CONSTANT CEXIT-MSG 1>      ;GET
        <CONSTANT DEXIT-OBJ 1>      ;GET/B
        <CONSTANT DEXIT-MSG 1>      ;GET)
    (T
        <CONSTANT UEXIT 2>
        <CONSTANT NEXIT 3>
        <CONSTANT FEXIT 4>
        <CONSTANT CEXIT 5>
        <CONSTANT DEXIT 6>

        <CONSTANT EXIT-RM 0>
        <CONSTANT NEXIT-MSG 0>
        <CONSTANT FEXIT-RTN 0>
        <CONSTANT CEXIT-VAR 4>
        <CONSTANT CEXIT-MSG 1>
        <CONSTANT DEXIT-OBJ 1>
        <CONSTANT DEXIT-MSG 2>)>

621
;"Checks whether PRSA is a meta-verb that does not cause time to pass."
622
<DEFMAC GAME-VERB? ()
623
624
    <FORM VERB? QUIT VERSION WAIT SAVE RESTORE INVENTORY ;DLIGHT UNDO ;DSEND
                SUPERBRIEF BRIEF VERBOSE AGAIN !,EXTRA-GAME-VERBS>>
625

626
627
628
629
630
<COND (<NOT <GASSIGNED? EXTRA-GAME-VERBS>> <SETG EXTRA-GAME-VERBS '()>)>

<CONSTANT CANT-GO-THAT-WAY "You can't go that way.">

<ROUTINE V-WALK ("AUX" PT PTS RM THERE-LIT)
631
    <COND (<NOT ,PRSO-DIR>
Tara McGrew's avatar
Tara McGrew committed
632
633
           <PRINTR "You must give a direction to walk in.">)
          (<0? <SET PT <GETPT ,HERE ,PRSO>>>
634
635
636
           <COND (<OR ,HERE-LIT <NOT <DARKNESS-F ,M-DARK-CANT-GO>>>
                  <TELL ,CANT-GO-THAT-WAY CR>)>
           <RTRUE>)
Tara McGrew's avatar
Tara McGrew committed
637
638
639
          (<==? <SET PTS <PTSIZE .PT>> ,UEXIT>
           <SET RM <GET/B .PT ,EXIT-RM>>)
          (<==? .PTS ,NEXIT>
640
           <TELL <GET .PT ,NEXIT-MSG> CR>
Tara McGrew's avatar
Tara McGrew committed
641
642
643
644
645
646
647
648
           <RTRUE>)
          (<==? .PTS ,FEXIT>
           <OR <SET RM <APPLY <GET .PT ,FEXIT-RTN>>>
               <RTRUE>>)
          (<==? .PTS ,CEXIT>
           <COND (<VALUE <GETB .PT ,CEXIT-VAR>>
                  <SET RM <GET/B .PT ,EXIT-RM>>)
                 (<SET RM <GET .PT ,CEXIT-MSG>>
649
                  <TELL .RM CR>
Tara McGrew's avatar
Tara McGrew committed
650
                  <RTRUE>)
651
652
                 (<AND <NOT ,HERE-LIT> <DARKNESS-F ,M-DARK-CANT-GO>>
                  <RTRUE>)
Tara McGrew's avatar
Tara McGrew committed
653
                 (ELSE
654
655
                  <TELL ,CANT-GO-THAT-WAY CR>
                  <RTRUE>)>)
Tara McGrew's avatar
Tara McGrew committed
656
          (<==? .PTS ,DEXIT>
657
658
659
660
661
662
663
664
665
           <COND (<FSET? <GET/B .PT ,DEXIT-OBJ> ,OPENBIT>
                  <SET RM <GET/B .PT ,EXIT-RM>>)
                 (<SET RM <GET .PT ,DEXIT-MSG>>
                  <TELL .RM CR>
                  <RTRUE>)
                 (ELSE
                  <TELL "You'll have to open " T <GET/B .PT ,DEXIT-OBJ>
                        " first." CR>
                  <RTRUE>)>)
Tara McGrew's avatar
Tara McGrew committed
666
667
668
669
          (ELSE
           <TELL "Broken exit (" N .PTS ")." CR>
           <RTRUE>)>
    <GOTO .RM>>
670

671
672
673
674
675
<ROUTINE V-ENTER ()
    <COND (<FSET? ,PRSO ,DOORBIT>
           <PERFORM ,V?WALK <DOOR-DIR ,PRSO>>
           <RTRUE>)
          (ELSE
676
           <NOT-POSSIBLE "get inside"> <RTRUE>)>>
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697

;"Finds a direction from HERE that leads through the given door.

Returns:
  A direction property, or false if no direction leads through the door."
<ROUTINE DOOR-DIR DD (DOOR)
    <MAP-DIRECTIONS (D PT ,HERE)
        <COND (<AND <==? <PTSIZE .PT> ,DEXIT>
                    <==? <GET/B .PT ,DEXIT-OBJ> .DOOR>>
               <RETURN .D .DD>)>>
    <RFALSE>>

;"Finds the room on the other side of a given door from HERE.

Returns:
  A room, or false if no direction leads through the door."
<ROUTINE OTHER-SIDE (DOOR "AUX" D)
    <COND (<SET D <DOOR-DIR .DOOR>>
           <GET/B <GETPT ,HERE .D> ,EXIT-RM>)
          (ELSE <>)>>

698
699
700
<ROUTINE V-QUIT ()
    <TELL "Are you sure you want to quit?">
    <COND (<YES?>
Tara McGrew's avatar
Tara McGrew committed
701
702
           <TELL CR "Thanks for playing." CR>
           <QUIT>)
703
          (ELSE
Tara McGrew's avatar
Tara McGrew committed
704
           <TELL CR "OK - not quitting." CR>)>>
705

Tara McGrew's avatar
Tara McGrew committed
706
<ROUTINE V-EXAMINE ("AUX" P (N <>))
707
    <COND (<SET P <GETP ,PRSO P?LDESC>>
Tara McGrew's avatar
Tara McGrew committed
708
709
           <TELL .P CR>
           <SET N T>)>
710
    <COND (<SET P <GETP ,PRSO P?TEXT>>
Tara McGrew's avatar
Tara McGrew committed
711
712
           <TELL .P CR>
           <SET N T>)>
Tara McGrew's avatar
Tara McGrew committed
713
714
715
716
717
718
719
    <COND (<FSET? ,PRSO ,OPENABLEBIT>
           <TELL CT ,PRSO " is ">
           <COND (<FSET? ,PRSO ,OPENBIT> <TELL "open.">)
                 (ELSE <TELL "closed.">)>
           <CRLF>
           <SET N T>)>
    <COND (<AND <FIRST? ,PRSO> <SEE-INSIDE? ,PRSO>>
Tara McGrew's avatar
Tara McGrew committed
720
721
           <DESCRIBE-CONTENTS ,PRSO>
           <SET N T>)>
Tara McGrew's avatar
Tara McGrew committed
722
723
    <COND (<NOT .N>
           <TELL "You see nothing special about " T ,PRSO "." CR>)>>
724

725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
<ROUTINE V-LOOK-UNDER ()
    <COND (<AND <N=? ,PRSO ,WINNER> <FSET? ,PRSO ,PERSONBIT>>
           <YOU-MASHER>
           <RTRUE>)
          (<NOT ,HERE-LIT> <TELL "It's too dark." CR>)
          (ELSE <TELL "You can't see anything of interest." CR>)>>

<ROUTINE V-SEARCH ()
    <COND (<PRSO? ,WINNER> <PERFORM ,V?INVENTORY>)
          (<FSET? ,PRSO ,PERSONBIT> <YOU-MASHER>)
          (<NOT <FSET? ,PRSO ,CONTBIT>> <NOT-POSSIBLE "look inside">)
          (<AND <FSET? ,PRSO ,OPENABLEBIT> <NOT <SEE-INSIDE? ,PRSO>>>
           <TELL CT ,PRSO <IF-PLURAL ,PRSO " are" " is"> " closed." CR>)
          (<NOT <FIRST? ,PRSO>>
           <TELL CT ,PRSO <IF-PLURAL ,PRSO " are" " is"> " empty." CR>)
          (ELSE <DESCRIBE-CONTENTS ,PRSO>)>>

742
<ROUTINE V-INVENTORY ()
Tara McGrew's avatar
Tara McGrew committed
743
    ;"check for light first"
744
    <COND (,HERE-LIT
Tara McGrew's avatar
Tara McGrew committed
745
746
747
748
749
750
751
           <COND (<FIRST? ,WINNER>
                  <TELL "You are carrying:" CR>
                  <MAP-CONTENTS (I ,WINNER)
                      <TELL "   " A .I>
                      <AND <FSET? .I ,WORNBIT> <TELL " (worn)">>
                      <AND <FSET? .I ,LIGHTBIT> <TELL " (providing light)">>
                      <COND (<FSET? .I ,CONTBIT>
Tara McGrew's avatar
Tara McGrew committed
752
753
754
755
                             <COND (<FSET? .I ,OPENABLEBIT>
                                    <COND (<FSET? .I ,OPENBIT> <TELL " (open)">)
                                          (ELSE <TELL " (closed)">)>)>
                             <COND (<SEE-INSIDE? .I> <INV-DESCRIBE-CONTENTS .I>)>)>
Tara McGrew's avatar
Tara McGrew committed
756
757
758
759
                      <CRLF>>)
                 (ELSE
                  <TELL "You are empty-handed." CR>)>)
          (ELSE
760
           <TELL "It's too dark to see what you're carrying." CR>)>>
761
762

<ROUTINE V-TAKE ("AUX" HOLDER S X)
763
764
765
766
767
    <COND (<PRSO? ,WINNER>
           <COND (<=? ,P-V-WORD ,W?GET> <TELL "Not quite." CR>)
                 (<=? ,P-V-WORD ,W?TAKE ,W?GRAB> <TSD>)
                 (<=? ,P-V-WORD ,W?PICK> <TELL "You aren't my type." CR>)
                 (ELSE <SILLY>)>
768
           <RTRUE>)
769
770
          (<FSET? ,PRSO ,PERSONBIT> <YOU-MASHER> <RTRUE>)
          (<NOT <FSET? ,PRSO ,TAKEBIT>> <NOT-POSSIBLE "pick up"> <RTRUE>)
Tara McGrew's avatar
Tara McGrew committed
771
          (<IN? ,PRSO ,WINNER>
772
773
774
775
776
777
778
779
780
           <PRINTR "You already have that.">)>
    ;"See if picked up object is being taken from a container"
    <COND (<SET HOLDER <TAKE-HOLDER ,PRSO ,WINNER>>
           <COND (<FSET? .HOLDER ,PERSONBIT>
                  <TELL "That seems to belong to " T .HOLDER "." CR>
                  <RTRUE>)
                 (<BLOCKS-TAKE? .HOLDER>
                  <TELL CT .HOLDER " is in the way." CR>
                  <RTRUE>)
781
                 (<NOT <TAKE-CAPACITY-CHECK ,PRSO>>)
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
                 (<AND <FSET? .HOLDER ,CONTBIT>
                       <HELD? ,PRSO .HOLDER>
                       <NOT <HELD? ,WINNER .HOLDER>>>
                  <TELL "You reach ">
                  <COND (<HELD? ,WINNER .HOLDER>
                         <TELL "out of ">)
                        (ELSE <TELL "in ">)>
                  <TELL T .HOLDER " and ">
                  <COND (<FSET? ,PRSO ,WEARBIT>
                         <TELL "wear ">
                         <FSET ,PRSO ,WORNBIT>)
                        (ELSE <TELL "take ">)>
                  <TELL T ,PRSO "." CR>
                  <FSET ,PRSO ,TOUCHBIT>
                  <MOVE ,PRSO ,WINNER>
                  <RTRUE>)>)>
798
799
    <COND (<NOT <TAKE-CAPACITY-CHECK ,PRSO>>)
          (<FSET? ,PRSO ,WEARBIT>
Tara McGrew's avatar
Tara McGrew committed
800
801
802
803
804
805
806
807
           <TELL "You wear " T ,PRSO "." CR>
           <FSET ,PRSO ,WORNBIT>
           <MOVE ,PRSO ,WINNER>
           <FSET ,PRSO ,TOUCHBIT>)
          (ELSE
           <TELL "You pick up " T ,PRSO "." CR>
           <FSET ,PRSO ,TOUCHBIT>
           <MOVE ,PRSO ,WINNER>)>>
Tara McGrew's avatar
Tara McGrew committed
808

809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
;"Locates the container, person, or room that restricts the ability to take a
given object.

If at least one thing between the taker and the object is a closed container
or a person, the closest one to the taker will be returned. Otherwise, the
innermost non-surface container or room that encloses the object will be
returned.

Args:
  OBJ: The object being taken.
  TAKER: The object doing the taking.

Returns:
  The closed container or person blocking the take, or the open container
  or room allowing the take, or ROOMS if the objects have no common parent."
<ROUTINE TAKE-HOLDER (OBJ TAKER "AUX" CEIL BLOCKER ALLOWER HAD-ALLOWER?)
    <SET CEIL <COMMON-PARENT? .OBJ .TAKER>>
    <COND (<0? .CEIL> <RETURN ,ROOMS>)>
    ;"Walk up the tree from OBJ to CEIL"
    <DO (L <LOC .OBJ> <0? .L> <SET L <LOC .L>>)
        <COND (<==? .L .CEIL>
               <RETURN>)
              (<BLOCKS-TAKE? .L>
               ;"Keep the furthest blocker from OBJ"
               <SET BLOCKER .L>)
              (<OR <AND <FSET? .L ,CONTBIT>
                        <NOT <FSET? .L ,SURFACEBIT>>>
                   <IN? .L ,ROOMS>>
               ;"Keep the closest allower to OBJ"
               <OR .ALLOWER <SET ALLOWER .L>>)>>
    ;"Walk up the tree from TAKER to CEIL, setting variables in reverse"
    <SET HAD-ALLOWER? .ALLOWER>
    <DO (L <LOC .TAKER> <0? .L> <SET L <LOC .L>>)
        <COND (<==? .L .CEIL>
               <RETURN>)
              (<BLOCKS-TAKE? .L>
               ;"Keep the closest blocker to TAKER"
               <OR .BLOCKER <SET BLOCKER .L>>)
              (<OR <AND <FSET? .L ,CONTBIT>
                        <NOT <FSET? .L ,SURFACEBIT>>>
                   <IN? .L ,ROOMS>>
               ;"Keep the furthest blocker from TAKER unless we already found
                 one on the first walk."
               <OR .HAD-ALLOWER? <SET ALLOWER .L>>)>>
    <OR .BLOCKER .ALLOWER>>

<ROUTINE BLOCKS-TAKE? (OBJ)
    <T? <OR <FSET? .OBJ ,PERSONBIT>
            <AND <FSET? .OBJ ,CONTBIT>
                 <FSET? .OBJ ,OPENABLEBIT>
                 <NOT <FSET? .OBJ ,OPENBIT>>>>>>

<DEFMAC COMMON-PARENT? ('A 'B)
    <FORM COMMON-PARENT-R .A .B ',HERE>>

<ROUTINE COMMON-PARENT-R CPR (A B ROOT "AUX" N F R)
    <OR .ROOT <RFALSE>>
    ;"If ROOT is equal to A or B, it's the common parent"
    <COND (<EQUAL? .ROOT .A .B> <RETURN .ROOT>)>
    ;"If ROOT directly contains either A or B, it's the common parent"
    <COND (<OR <IN? .A .ROOT> <IN? .B .ROOT>> <RETURN .ROOT>)>
    ;"Look for common parent in each subtree, keeping any matching
      tree and counting the number found."
    <MAP-CONTENTS (I .ROOT)
        <COND (<SET R <COMMON-PARENT-R .A .B .I>>
               <SET F .R>
               <SET N <+ .N 1>>
               ;"If we found matching parents in two children,
                ROOT is the common parent."
878
               <COND (<G? .N 1> <RETURN .ROOT .CPR>)>)>>
879
880
881
    ;"One child contained both objects, so the common parent is whatever
      COMMON-PARENT-R returned for it."
    .F>
Tara McGrew's avatar
Tara McGrew committed
882

883
884
885
886
887
888
889
890
891
892
893
894
<DEFAULT-DEFINITION TAKE-CAPACITY-CHECK

    <ROUTINE TAKE-CAPACITY-CHECK (O "AUX" (CAP <GETP ,WINNER ,P?CAPACITY>) CWT NWT)
        <COND (<L? .CAP 0> <RTRUE>)>
        <SET CWT <- <WEIGHT ,WINNER> <GETP ,WINNER ,P?SIZE>>>
        <SET NWT <WEIGHT .O>>
        <COND (<G? <+ .CWT .NWT> .CAP>
               <TELL "You're carrying too much to pick up " T .O "." CR>
               <RFALSE>)>
        <RTRUE>>
>

895
896
897
<ROUTINE V-DROP ()
    <COND
        (<NOT <IN? ,PRSO ,WINNER>>
Tara McGrew's avatar
Tara McGrew committed
898
         <PRINTR "You don't have that.">)
899
        (ELSE
Tara McGrew's avatar
Tara McGrew committed
900
901
902
903
         <MOVE ,PRSO ,HERE>
         <FSET ,PRSO ,TOUCHBIT>
         <FCLEAR ,PRSO ,WORNBIT>
         <TELL "You drop " T ,PRSO "." CR>)>>
904

905
906
907
908
909
<ROUTINE PRE-PUT-ON ()
    <COND (<PRSI? ,WINNER> <PERFORM ,V?WEAR ,PRSO> <RTRUE>)
          (<PRSO? ,WINNER> <PERFORM ,V?ENTER ,PRSI> <RTRUE>)
          (<NOT <HAVE-TAKE-CHECK ,PRSO ,SF-HAVE>> <RTRUE>)>>

910
<ROUTINE V-PUT-ON ("AUX" S CCAP CSIZE X W B)
911
    <COND (<FSET? ,PRSI ,PERSONBIT> <YOU-MASHER ,PRSI> <RTRUE>)
Tara McGrew's avatar
Tara McGrew committed
912
913
          (<NOT <AND <FSET? ,PRSI ,CONTBIT>
                     <FSET? ,PRSI ,SURFACEBIT>>>
914
915
           <NOT-POSSIBLE "put things on">
           <RTRUE>)
Tara McGrew's avatar
Tara McGrew committed
916
917
          (<NOT <IN? ,PRSO ,WINNER>>
           <PRINTR "You don't have that.">)
918
          (<OR <EQUAL? ,PRSO ,PRSI> <HELD? ,PRSI ,PRSO>>
Tara McGrew's avatar
Tara McGrew committed
919
920
           <PRINTR "You can't put something on itself.">)
          (ELSE
Tara McGrew's avatar
Tara McGrew committed
921
           <SET S <GETP ,PRSO ,P?SIZE>>
922
           <COND (<G=? <SET CCAP <GETP ,PRSI ,P?CAPACITY>> 0>
Tara McGrew's avatar
Tara McGrew committed
923
                  ;<TELL D ,PRSI " has a capacity prop of " N .CCAP CR>)
Tara McGrew's avatar
Tara McGrew committed
924
                 (ELSE
Tara McGrew's avatar
Tara McGrew committed
925
926
927
928
                  ;<TELL D ,PRSI " has no capacity prop.  Will take endless amount of objects as long as each object is size 5 or under" CR>
                  <SET CCAP 5>
                  ;"set bottomless flag"
                  <SET B 1>)>
Tara McGrew's avatar
Tara McGrew committed
929
           <SET CSIZE <GETP ,PRSI ,P?SIZE>>
Tara McGrew's avatar
Tara McGrew committed
930
931
           ;<TELL D ,PRSO "size is " N .S ", " D ,PRSI " size is " N .CSIZE ", capacity ">
                 ;<COND (<0? .B>
932
933
                            ;<TELL N .CCAP CR>)
                        ;(ELSE <TELL "infinite" CR>)>
Tara McGrew's avatar
Tara McGrew committed
934
935
936
937
938
939
940
941
           <COND (<OR <G? .S .CCAP> <G? .S .CSIZE>>
                  <TELL "That won't fit on " T ,PRSI "." CR>
                  <RETURN>)>
           <COND (<0? .B>
                  ;"Determine weight of contents of IO"
                  <SET W <CONTENTS-WEIGHT ,PRSI>>
                  ;<TELL "Back from Contents-weight loop" CR>
                  <SET X <+ .W .S>>
Tara McGrew's avatar
Tara McGrew committed
942
                  <COND (<G? .X .CCAP>
Tara McGrew's avatar
Tara McGrew committed
943
944
945
946
                         <TELL "There's not enough room on " T ,PRSI "." CR>
                         ;<TELL D ,PRSO " of size " N .S " can't fit, since current weight of " D ,PRSI "'s contents is " N .W " and " D ,PRSI "'s capacity is " N .CCAP CR>
                         <RETURN>)>
                  ; <TELL D ,PRSO " of size " N .S " can fit, since current weight of of " D ,PRSI "'s contents is " N .W " and " D ,PRSI "'s capacity is " N .CCAP CR>
947
                  )>
Tara McGrew's avatar
Tara McGrew committed
948
949
950
951
           <MOVE ,PRSO ,PRSI>
           <FSET ,PRSO ,TOUCHBIT>
           <FCLEAR ,PRSO ,WORNBIT>
           <TELL "You put " T ,PRSO " on " T ,PRSI "." CR>)>>
Tara McGrew's avatar
Tara McGrew committed
952

953
954
955
956
957
<ROUTINE PRE-PUT-IN ()
    <COND (<PRSI? ,WINNER> <TSD> <RTRUE>)
          (<PRSO? ,WINNER> <PERFORM ,V?ENTER ,PRSI> <RTRUE>)
          (<NOT <HAVE-TAKE-CHECK ,PRSO ,SF-HAVE>> <RTRUE>)>>

958
959
<ROUTINE V-PUT-IN ("AUX" S CCAP CSIZE X W B)
    ;<TELL "In the PUT-IN routine" CR>
960
    <COND (<FSET? ,PRSI ,PERSONBIT> <YOU-MASHER ,PRSI> <RTRUE>)
Tara McGrew's avatar
Tara McGrew committed
961
962
          (<OR <NOT <FSET? ,PRSI ,CONTBIT>>
               <FSET? ,PRSI ,SURFACEBIT>>
963
964
           <NOT-POSSIBLE "put things in">
           <RTRUE>)
Tara McGrew's avatar
Tara McGrew committed
965
966
967
968
969
970
971
972
973
          (<AND <NOT <FSET? ,PRSI ,OPENBIT>>
                <FSET? ,PRSI ,OPENABLEBIT>>
           <TELL CT ,PRSI " is closed." CR>)
          ;"always closed case"
          (<AND <NOT <FSET? ,PRSI ,OPENBIT>>
                <FSET? ,PRSI ,CONTBIT>>
           <TELL "You see no way to put things into " T ,PRSI  "." CR>)
          (<NOT <IN? ,PRSO ,WINNER>>
           <PRINTR "You aren't holding that.">)
974
          (<OR <EQUAL? ,PRSO ,PRSI> <HELD? ,PRSI ,PRSO>>
Tara McGrew's avatar
Tara McGrew committed
975
           <PRINTR "You can't put something in itself.">)
Tara McGrew's avatar
Tara McGrew committed
976
          (ELSE
Tara McGrew's avatar
Tara McGrew committed
977
           <SET S <GETP ,PRSO ,P?SIZE>>
978
           <COND (<G=? <SET CCAP <GETP ,PRSI ,P?CAPACITY>> 0>
Tara McGrew's avatar
Tara McGrew committed
979
980
                  <IF-DEBUG <COND (,DBCONT
                                   <TELL D ,PRSI " has a capacity prop of " N .CCAP CR>)>>)
Tara McGrew's avatar
Tara McGrew committed
981
                 (ELSE
Tara McGrew's avatar
Tara McGrew committed
982
983
                  <IF-DEBUG <COND (,DBCONT
                                   <TELL D ,PRSI " has no capacity prop.  Will take endless amount of objects as long as each object is size 5 or under" CR>)>>
Tara McGrew's avatar
Tara McGrew committed
984
985
986
987
988
                  <SET CCAP 5>
                  ;"set bottomless flag"
                  <SET B 1>)>
           <SET CSIZE <GETP ,PRSI ,P?SIZE>>
           ;<COND (<AND ,DBCONT> <TELL D ,PRSI " has a size of " N .CSIZE CR>)>
Tara McGrew's avatar
Tara McGrew committed
989
990
        <IF-DEBUG <COND (,DBCONT
               <TELL D ,PRSO "size is " N .S ", " D ,PRSI " size is " N .CSIZE CR>)>>
Tara McGrew's avatar
Tara McGrew committed
991
992
993
994
995
996
997
998
999
1000
        ;<COND (<0? .B>
        ;<TELL N .CCAP CR>)
        ;(ELSE <TELL "infinite" CR>)>
        <COND (<OR <G? .S .CCAP>
                   <G? .S .CSIZE>>
               <TELL "That won't fit in " T ,PRSI "." CR>
               <RETURN>)>
        <COND (<0? .B>
               ;"Determine weight of contents of IO"
               <SET W <CONTENTS-WEIGHT ,PRSI>>