hadeishi@husc4.harvard.edu (mitsuharu hadeishi) (10/14/86)
Here's the program, in ASCII format. Run AmigaBasic,
type "clear,170000" or so, and load the program. When you save it,
save it with 'save "AmigaVenture",b'. The ",b" saves it in binary
encoded format which loads much more quickly than the ASCII version.
Do NOT use the Save command from the menu, because it will save it
in the same format in which it was loaded (i.e., ASCII). After you save
it once in binary form, it will always load and save in binary form.
A few hints: reposition the LIST window so it takes up the
full width of the screen and leaves about 4 lines or so of the RUN
window underneath. You can use the RUN window to get to various
sections of the program with the "list label-" command. The Quick
Reference Guide contains a list of important program labels; with
this method you can navigate around the program rapidly.
Also: NEVER use Trace (it crashes). NEVER close the AmigaBasic
window in the middle of a save (it stops the save halfway through.)
ALWAYS make backup copies of your work. AmigaBasic is fairly reliable
if you avoid these pitfalls. Enjoy! (Note: AmigaBasic runs under
V1.1 or V1.2 beta 7 and above. AmigaBasic will NOT run under V1.2
beta 1-6.)
This is NOT a shell archive. Just cut and run.
-------[ cut cut cut cut cut cut cut cut cut cut cut cut here ]---------
DEFINT a-z
game$ = "AmigaVenture 1.17" ' Version number of game
dataformat$ = "AmigaVenture 1.1X" ' Version number for load/save only
'
' AmigaVenture Kernal 1.17
'
' Core routines for writing an Adventure of your own
' In Microsoft AmigaBasic
'
' by Mitsu Hadeishi 7/15/86
' 1460 W. 182nd Street
' Gardena CA 90248
'
' Written for the Winner's Circle Amiga User's Group
'
'---------------------------------------------------------------------------
' Permission is given to freely distribute this code in full or in part
' provided this notice is copied IN FULL.
'
' AmigaVenture Kernal Copyright (c) 1986 by Mitsu Hadeishi
' This code may not be used in part or in full in any commercial
' product, nor may this code in part or in full be sold intentionally
' to make a profit, without an explicit written agreement with the author.
'---------------------------------------------------------------------------
'
' Please write to me if you have plans to distribute a significantly
' modified version of the *kernal*.
' Feel free to distribute *adventures* written with this kernal without
' contacting me, but please! give credit where credit is due.
'
' Updates and enhancements may be obtained from:
'
' Mitsu Hadeishi
' hadeishi@husc4.UUCP
' or hadeishi%husc4.harvard.edu
' 3 Sacramento Street
' Cambridge, MA 02138
'
' All variables are, unless otherwise indicated, short integers.
'
GOTO Initialize
Messages:
' Message subroutines/subprograms
Cannot:
IF n$(1) = "" THEN
PRINT"You can't "v$" "nn$(0)"!
ELSE
PRINT"You can't "v$" "nn$(0)" "p$" "nn$(1)"!
END IF
RETURN
SUB CantSee(nn$) STATIC
PRINT"I don't see what you're referring to.
END SUB
SUB DontHave(nn$) STATIC
PRINT"You don't have "nn$"!
END SUB
SUB CantGetAt(nn$) STATIC
PRINT"You can't get at "nn$"!"
END SUB
Absurd:
ON RND(1)*2+1 GOTO Absurd1,Absurd2
Absurd1:
PRINT"Don't be absurd.":RETURN
Absurd2:
PRINT"Don't talk nonsense.":RETURN
Mystery:
PRINT"I can't see what you're referring to.
RETURN
' Prints a list of alternatives for the player to select from
' If all the choices are positionally referenced, then "that" is
' returned as 1
SUB AskAmbig(choice(2),num,that) STATIC
SHARED adj$(),par(),rel(),prepn$()
PRINT"Which do you mean:"
num = ABS(num)
FOR i = 1 TO num
IF i = num THEN PRINT"or ";
c=choice(i,0)
CALL NameNoun(c,n$,nn$)
IF c > 0 AND adj$(c) <> "" THEN
PRINT"the "adj$(c)" "n$;
that=-1
ELSE
PRINT nn$;
END IF
IF c > 0 AND adj$(c) = "" AND par(c) <> 0 THEN
PRINT" that's "prepn$(rel(c)+1)" ";
IF that <> -1 THEN that=1
CALL NameNoun(par(c),n$,nn$)
PRINT nn$;
END IF
IF i = num THEN PRINT"?" ELSE PRINT", ";
NEXT i
IF that = -1 THEN that=0
END SUB
Calc:
'
' Calculation subprograms follow
'
' Visible() determines whether noun code 'code' is visible or not.
' If type is 1, then only checks to see if visible on the player,
' if 2, then only checks to see if visible in room (but not on player).
' Returns truth value in vis
SUB Visible(code,vis,type) STATIC
SHARED par(),rel(),opaque(),closed(),lo(),l
a = type
obj = code
IF obj < 0 THEN vis=1:EXIT SUB
vis = 0
IF a = 1 THEN IF lo(obj) <> 1 THEN EXIT SUB
IF a = 2 THEN IF lo(obj) <> l THEN EXIT SUB
IF a = 0 THEN IF lo(obj) <> 1 AND lo(obj) <> l THEN EXIT SUB
vis = -1
WHILE (vis = -1)
IF par(obj) < 2 THEN
vis = 1
ELSEIF (opaque(rel(obj),par(obj)) = 1) AND (rel(obj) = 0 AND closed(par(obj)) <> 0) THEN
vis = 0
ELSE
obj = par(obj)
END IF
WEND
END SUB
' Avail() determines whether noun code 'code' is available or not.
' If the object is available, but you couldn't get it out from where
' it is, returns -1
' See Visible, above, for explanation of 'type'
' Returns truth value in ava
SUB Avail(code,ava,type) STATIC
SHARED par(),rel(),closed(),lo(),l,opening(),size(),holdwater()
a = type
IF a = 0 THEN a = 3
obj = code
IF obj < 0 THEN ava=1:EXIT SUB
ava = 0
IF a = 1 THEN IF lo(obj) <> 1 THEN EXIT SUB
IF a = 2 THEN IF lo(obj) <> l THEN EXIT SUB
IF a = 0 THEN IF lo(obj) <> 1 AND lo(obj) <> l THEN EXIT SUB
siz = size(code):IF holdwater(code) = 2 THEN siz = 0
WHILE (1)
IF par(obj)<2 THEN
IF ava <> -1 THEN ava = 1
EXIT SUB
ELSEIF closed(par(obj)) <> 0 AND (rel(obj) < 2) THEN
ava = 0
EXIT SUB
ELSEIF opening(rel(obj),par(obj)) < siz THEN
ava = -1
END IF
obj = par(obj)
WEND
END SUB
'*** CheckLight() should be modified for your own program's way
'*** of casting light and shadow on the situation. Returns 0
'*** for total darkness, 1 for lamp light, 2 for moonlight/nighttime,
'*** 3 for twilight, 4 for daylight
SUB CheckLight(light) STATIC
SHARED l,lamp,lampon,day,flag(),Llight(),Lon()
light = 0
IF Lon(l) THEN light = Lon(l):EXIT SUB
IF Llight(l) = 1 AND flag(day) <> 0 THEN light = flag(day):EXIT SUB
CALL Visible(lamp,vis,0)
IF (flag(lampon) = 1) AND (vis = 1) THEN light = 1
END SUB
' NameNoun() returns appropriate strings in n$ and nn$, where
' n$ is the class word for the noun code, and nn$ is "the " + n$,
' unless the noun is abstract (negative code) in which case nn$ = n$
SUB NameNoun(n,n$,nn$) STATIC
SHARED word$(),abstract$()
IF n > 0 THEN
n$ = word$(n)
nn$ = "the " + n$
ELSE
n$ = abstract$(-n)
nn$ = n$
END IF
END SUB
Calc2:
' Places in array() siblings starting with object obj and children
' which are underneath all objects in the list.
' Starts the list at array(count + 1) (this allows you to call this
' routine multiple times and list several lists) This routine
' is used by the interpreter to list objects
SUB ListSib(obj,array(2),count(1),nn) STATIC
SHARED cc(),opaque(),right(),first()
ll = 1
cc(1) = obj
cc(0) = 0
ListSib1:
WHILE (ll > 0)
WHILE (cc(ll))
count(nn) = count(nn) + 1
array(nn,count(nn)) = cc(ll)
IF first(3,cc(ll)) <> 0 AND opaque(3,cc(ll)) = 0 THEN
ll = ll + 1
cc(ll) = first(3,cc(ll-1))
GOTO ListSib1
END IF
cc(ll) = right(cc(ll))
WEND
ll = ll - 1
cc(ll) = right(cc(ll))
WEND
END SUB
' Determines if c1 is a descendant of c2 (inside, on, etc.)
' Returns truth value in ins
SUB Inside(c1,c2,ins,rel) STATIC
SHARED par()
ins = 0
c = c1
WHILE (c)
IF par(c) = c2 THEN ins = 1:rel = rel(c):EXIT SUB
c = par(c)
WEND
END SUB
' EvalCond evaluates a condition on the flag() array; ret is the truth
' value returned. The condition tested depends on the value of b;
' it is whether or not flag(a) < c, flag(a) = c, or flag(a) > c,
' depending on whether b = -1, 0, or 1, respectively. This function
' is used to evaluate the conditionals in the map and the descriptions.
' (see Go:, Look:, and map:).
SUB EvalCond(a,b,c,ret) STATIC
SHARED flag(),random
IF a = random THEN CALL RollDice
IF b = 0 THEN
ret = (flag(a) = c)
ELSEIF b = 1 THEN
ret = (flag(a) > c)
ELSE
ret = (flag(a) < c)
END IF
END SUB
SUB RollDice STATIC
SHARED flag(),random
flag(random) = RND(1) * 100
END SUB
' List all bottles in the player's possession
' Starts at array(0), returns count in a
SUB ListBottles(array(1),a) STATIC
SHARED bottles(),lo(),nbot
a = 0
FOR i = 0 TO nbot
IF lo(bottles(i)) = 1 THEN
CALL Avail(bottles(i),ava,1)
IF ava THEN
array(a) = bottles(i)
a = a + 1
END IF
END IF
NEXT
END SUB
Lists:
' The following subprograms handle the linked lists of objects,
' parents, children, siblings
' Contents() prints a list of obj and all siblings and children
' If sing = 1, then just prints what's in it,
' not siblings
SUB Contents(obj,indent,sing) STATIC
SHARED cc(),mc(),mrel,pre$(),word$(),closed(),opaque(),right(),worn()
SHARED folded(),fold$(),first()
ll = 1
mc(1) = 0
cc(1) = obj
WHILE (ll > 0)
WHILE (cc(ll) <> 0)
Contents1:
c = cc(ll)
mode = mc(ll)
IF mode = 0 AND (sing = 0 OR ll > 1) AND c > 1 THEN
PRINT TAB(indent);pre$(c)" "word$(c);
IF folded(c) THEN
PRINT" ("fold$(folded(c))")"
ELSE
PRINT
END IF
END IF
IF first(mode,c) <> 0 AND (opaque(mode,c) = 0 OR (mode = 0 AND closed(c) = 0)) THEN
nn$ = "the " + word$(c)
PRINT TAB(indent);
IF sing = 2 THEN
' *** Don't print anything
ELSEIF mode = 0 THEN
IF c = 1 THEN
PRINT"You are wearing:"
ELSE
IF sing THEN PRINT FNcap$(nn$); ELSE PRINT nn$;
PRINT" contains:"
END IF
ELSEIF mode = 1 THEN
IF c = 1 THEN
PRINT"You are carrying:"
ELSE
IF sing THEN PRINT"W"; ELSE PRINT"w";
PRINT"rapped by "nn$", you see:"
END IF
ELSEIF mode = 2 THEN
IF sing THEN PRINT"L"; ELSE PRINT"l";
PRINT"ying on "nn$", you see:"
ELSEIF mode = 3 THEN
IF sing THEN PRINT"U"; ELSE PRINT"u";
PRINT"nder "nn$", you see:"
END IF
ll = ll + 1
cc(ll) = first(mode,c)
mc(ll) = 0
indent = indent + 3
GOTO Contents1
END IF
mc(ll) = mc(ll) + 1
IF mc(ll) > mrel THEN
IF sing THEN IF ll = 1 THEN EXIT SUB
cc(ll) = right(c)
mc(ll) = 0
END IF
WEND
ll = ll - 1
indent = indent - 3
mc(ll) = mc(ll) + 1
IF mc(ll) > mrel THEN
IF sing THEN IF ll = 1 THEN EXIT SUB
cc(ll) = right(cc(ll))
mc(ll) = 0
END IF
WEND
END SUB
' Removes object from list and places it in limbo
SUB Remove(obj) STATIC
SHARED par(),right(),left(),rel(),first(),last()
SHARED Lfirst(),Llast(),lo(),totw(),totb(),bulk(),size()
ri = right(obj)
le = left(obj)
right(le) = ri
left(ri) = le
IF par(obj) = 0 THEN
lc = lo(obj)
IF Llast(lc) = obj THEN Llast(lc) = le
IF Lfirst(lc) = obj THEN Lfirst(lc) = ri
ELSE
pa = par(obj)
IF last(rel(obj),pa) = obj THEN last(rel(obj),pa) = le
IF first(rel(obj),pa) = obj THEN first(rel(obj),pa) = ri
c = obj
w = totw(c):b = totb(c)
IF rel(c) = 2 THEN bulk(rel(c),pa) = bulk(rel(c),pa) - size(c)
WHILE (pa)
IF rel(c) < 3 THEN totw(pa) = totw(pa) - w ELSE w = 0
IF rel(c) <> 2 THEN bulk(rel(c),pa) = bulk(rel(c),pa) - b
IF rel(c) = 1 OR rel(c) = 2 THEN totb(pa) = totb(pa) - b ELSE b = 0
c = par(c)
pa = par(c)
WEND
END IF
par(obj) = 0
left(obj) = 0
right(obj) = 0
lo(obj) = 0
rel(obj) = 0
END SUB
' Inserts object into relation to object "into". If into is negative
' or zero, the routine will insert it into the room number -into.
' The relation is determined by "mode". This is 0 for in, 1 for wrapped,
' 2 for on top of, and 3 for underneath (like under a table, NOT like
' under something stacked on top of the object.)
' NOTE: this routine assumes that the object has already been "Removed"
' (see above.) The routine does not do any checking for weight, capacity,
' or mode violations. This must be done by the calling routine, using the
' totw() and totb() arrays, which are updated by this routine.
SUB Insert(obj,into,mode) STATIC
SHARED par(),rel(),mrel,right(),left(),first(),last()
SHARED Lfirst(),Llast(),lo(),totw(),totb(),bulk(),size()
IF mode < 0 OR mode > mrel THEN EXIT SUB
right(obj) = 0
IF into > 0 THEN
par(obj) = into
IF first(mode,into) = 0 THEN first(mode,into) = obj
left(obj) = last(mode,into)
right(last(mode,into)) = obj
last(mode,into) = obj
rel(obj) = mode
pa = into
c = obj
w = totw(c):b = totb(c)
IF rel(c) = 2 THEN bulk(rel(c),pa) = bulk(rel(c),pa) + size(c)
WHILE (pa)
IF rel(c) < 3 THEN totw(pa) = totw(pa) + w ELSE w = 0
IF rel(c) <> 2 THEN bulk(rel(c),pa) = bulk(rel(c),pa) + b
IF rel(c) = 1 OR rel(c) = 2 THEN totb(pa) = totb(pa) + b ELSE b = 0
c = par(c)
pa = par(c)
WEND
CALL Setloc(obj,lo(into),1)
ELSE
into = -into
par(obj) = 0
rel(obj) = 0
IF Lfirst(into) = 0 THEN Lfirst(into) = obj
left(obj) = Llast(into)
right(Llast(into)) = obj
Llast(into) = obj
CALL Setloc(obj,into,1)
END IF
END SUB
' Sets the location of obj and all its descendants recursively
' If sing is 0, then all siblings are set to location l as well,
' otherwise, only obj is set
SUB Setloc(obj,l,sing) STATIC
SHARED mrel,cc(),mc(),first(),right(),lo()
lo(obj) = l
ll = 1
mc(1) = 0
cc(1) = obj
WHILE (ll > 0)
WHILE (cc(ll) <> 0)
Setloc1:
c = cc(ll)
mode = mc(ll)
lo(c) = l
IF (first(mode,c) <> 0) THEN
ll = ll + 1
cc(ll) = first(mode,c)
GOTO Setloc1
END IF
mc(ll) = mc(ll) + 1
IF mc(ll) > mrel THEN
IF sing THEN IF ll = 1 THEN EXIT SUB
cc(ll) = right(cc(ll))
mc(ll) = 0
END IF
WEND
ll = ll - 1
mc(ll) = mc(ll) + 1
IF mc(ll) > mrel THEN
IF sing THEN IF ll = 1 THEN EXIT SUB
cc(ll) = right(cc(ll))
mc(ll) = 0
END IF
WEND
END SUB
' Removes the list of objects related to "code" in the relationship
' "mode" (0 - in, 1 - wrapped, 2 - on, 3 - underneath).
' Returns the first object in the list in "head".
' ***WARNING***:
' This routine DOES NOT set the location pointers, to speed up routines
' that set the location pointers themselves. Therefore the list is
' unlinked (it won't show up in a "look" or "examine", etc.) but if you
' ask whether or not the objects are visible or accessibile (with
' Visible() and Avail()) they will still be "there" in the room.
' To send them to limbo, call Setloc(head,0,0) after RemList.
SUB RemList(code,mode,head) STATIC
SHARED par(),rel(),right(),first(),last(),Lfirst(),Llast()
SHARED totw(),totb(),bulk(),size()
IF code > 0 THEN
head = first(mode,code)
first(mode,code) = 0
last(mode,code) = 0
ELSE
code = -code
head = Lfirst(code)
Lfirst(code) = 0
Llast(code) = 0
END IF
c = head
WHILE (c)
pa = par(c)
d = c
w = totw(c):b = totb(c)
IF rel(c) = 2 THEN bulk(rel(c),pa) = bulk(rel(c),pa) - size(c)
WHILE (pa)
IF rel(c) < 3 THEN totw(pa) = totw(pa) - w ELSE w = 0
IF rel(c) <> 2 THEN bulk(rel(c),pa) = bulk(rel(c),pa) - b
IF rel(d) = 1 OR rel(d) = 2 THEN totb(pa) = totb(pa) - b ELSE b = 0
d = par(d)
pa = par(d)
WEND
par(c) = 0
rel(c) = 0
c = right(c)
WEND
END SUB
' Concat concatenates the list of objects beginning with "head" into
' relationship with "code" in the manner "mode". If code is
' positive, it is an object, if negative, it is a location.
' This routine typically called after RemList.
SUB Concat(head,code,mode) STATIC
SHARED lo(),par(),rel(),left(),right(),first(),last(),Lfirst(),Llast()
SHARED totw(),totb(),bulk(),size()
IF head = 0 THEN EXIT SUB
into = code
IF code <= 0 THEN mode = 0:into = 0
totw = 0:totb = 0
c = head
WHILE (c)
rel(c) = mode
par(c) = into
pa = into
d = c
w = totw(c):b = totb(c)
IF rel(c) = 2 THEN bulk(rel(c),pa) = bulk(rel(c),pa) + size(c)
WHILE (pa)
IF rel(c) < 3 THEN totw(pa) = totw(pa) + w ELSE w = 0
IF rel(c) <> 2 THEN bulk(rel(c),pa) = bulk(rel(c),pa) + b
IF rel(d) = 1 OR rel(d) = 2 THEN totb(pa) = totb(pa) + b ELSE b = 0
d = par(d)
pa = par(d)
WEND
tail = c
c = right(c)
WEND
IF code > 0 THEN
left(head) = last(mode,code)
right(last(mode,code)) = head
IF first(mode,code) = 0 THEN first(mode,code) = head
last(mode,code) = tail
lc = lo(code)
ELSE
code = -code
left(head) = Llast(code)
right(Llast(code)) = head
IF Lfirst(code) = 0 THEN Lfirst(code) = head
Llast(code) = tail
lc = code
END IF
CALL Setloc(head,lc,0)
END SUB
WaterLists:
' Fill() fills the obj with the specified about of water. Returns
' the actual amount filled in wat.
SUB Fill(obj,wat) STATIC
SHARED totw(),totb(),bulk(),par(),rel(),cap(),size()
IF obj < 0 THEN EXIT SUB
IF wat = 0 THEN EXIT SUB
c=obj
IF cap(0,c)=-1 THEN RETURN 'Infinite capacity (river, lake, etc.)
' Check for overflow/underflow
IF wat + bulk(0,c) > cap(0,c) THEN
wat = cap(0,c) - bulk(0,c)
IF wat < 0 THEN wat = 0:EXIT SUB
ELSEIF wat + bulk(0,c) <= 0 THEN
wat = -bulk(0,c)
CALL Empty(obj)
EXIT SUB
END IF
c = obj
IF par(c+1) = 0 THEN ' No current water object inside c
totw(c+1) = wat
totb(c+1) = wat
size(c+1) = wat
CALL Insert(c+1,c,0)
EXIT SUB
ELSE ' Must modify bulk, weight in c
totw(c+1) = totw(c+1) + wat
totb(c+1) = totw(c+1) + wat
size(c+1) = size(c+1) + wat
bulk(0,c) = bulk(0,c) + wat
WHILE (c)
totw(c) = totw(c) + wat
IF rel(c) < 3 THEN c = par(c) ELSE c = 0
WEND
END IF
END SUB
' Empties the water from object "obj". This routine DOES
' check to make sure the object IS a container
SUB Empty(obj) STATIC
SHARED holdwater(),par(),cap(),size(),totw(),totb()
IF obj < 0 THEN EXIT SUB
IF cap(0,obj)=-1 THEN RETURN 'Infinite capacity (river, lake, etc.)
IF holdwater(obj) <> 1 THEN EXIT SUB
IF par(obj+1) = 0 THEN EXIT SUB
CALL Remove(obj+1)
size(obj+1) = 0
totw(obj+1) = 0
totb(obj+1) = 0
END SUB
' The Tumble routine takes all objects that are stacked on top of
' the object obj and makes them siblings of obj
SUB Tumble(obj) STATIC
SHARED cc(),c1(),c2(),lo(),par(),first(),right()
ll = 1
cc(1) = first(2,obj)
IF cc(1) = 0 THEN EXIT SUB
tum = 0
c1(tum) = obj
PRINT c1(tum)
WHILE (ll > 0)
WHILE (cc(ll) <> 0)
Tumble1:
c = cc(ll)
IF (first(2,c) <> 0) THEN
tum = tum + 1
c1(tum) = c
ll = ll + 1
cc(ll) = first(2,c)
GOTO Tumble1
END IF
cc(ll) = right(cc(ll))
WEND
ll = ll - 1
cc(ll) = right(cc(ll))
WEND
FOR i = 0 TO tum
CALL RemList(c1(i),2,c2(i))
NEXT i
lc = par(obj)
IF lc = 0 THEN lc = -lo(obj)
FOR i = 0 TO tum
CALL Concat(c2(i),lc,0)
NEXT i
END SUB
'
' Interpreter subprograms follow
'
Interpreter:
' GetVerb() returns a verb code in v and a verb string in v$,
' and returns cmd$ starting with the first word following the verb phrase
SUB GetVerb(cmd$,v,v$) STATIC
SHARED verb$()
IF cmd$ = "" THEN EXIT SUB
cc(3) = -1
FOR i = 2 TO 0 STEP -1
cc(i) = INSTR(cc(i+1)+2,cmd$," ") - 1
NEXT i
FOR i = 0 TO 2 '*** Search 3-word, 2-word, then 1-word verb lists
IF cc(i) < 0 THEN GetVerb1
c$ = "," + LEFT$(cmd$,cc(i)) + ","
c = INSTR(verb$(i),c$)
IF c <> 0 THEN vl = i:i = 2
GetVerb1:
NEXT i
IF c = 0 THEN
EXIT SUB
ELSE
v$ = MID$(c$,2,LEN(c$) - 2)
lv = LEN(v$)
v = VAL(MID$(verb$(vl),c + lv + 2))
cmd$ = MID$(cmd$,lv + 2)
WHILE (MID$(cmd$,1,1) = " ")
cmd$ = MID$(cmd$,2)
WEND
END IF
END SUB
' ExNoun() returns an array of noun code choices and a count
' Returns 0 in nch if no noun is found
' Returns -1 if inconsistent nouns are found (like "diamond sandwich", etc.)
' Returns 1 in "that" if a "that" clause is identified
' Note: this routine exits immediately after ambiguity is resolved.
' This routine truncates cmd$
SUB ExNoun(cmd$,choice(2),nch,that) STATIC
SHARED mhom,nnoun,noun$,nindex(),nhom(),ncode()
ll = 0
ExNoun1:
IF cmd$ = "" THEN ExNoun2
c$ = ","+LEFT$(cmd$,INSTR(cmd$," ")-1)+","
c = INSTR(noun$,c$)
IF c = 0 THEN ExNoun2
ln = LEN(c$) - 2
i = VAL(MID$(noun$,c + ln + 2))
cmd$ = MID$(cmd$,ln + 2)
WHILE (MID$(cmd$,1,1) = " ")
cmd$ = MID$(cmd$,2)
WEND
IF ncode(nindex(i)) = -14 THEN that = 1:GOTO ExNoun2 ' Found "that"
IF ncode(nindex(i)) = -15 THEN ' "what's" == "everything that"
IF nch THEN nch = -1:EXIT SUB
choice(1,0) = -11:nch = 1:that = 1
CALL SkipNoun(cmd$)
EXIT SUB
END IF
IF (nhom(i) = 0) THEN ExNoun1 '*** Null word, get next word
IF (nch = 0) THEN '*** Empty context
FOR j = 1 TO nhom(i) '*** Ambiguous
code = ncode(nindex(i) + j - 1)
nch = nch + 1
choice(nch,ll) = ncode(nindex(i) + nch -1)
NEXT j
ll = 1 - ll
GOTO ExNoun1
ELSE '*** Try to resolve ambiguity within old context
newnch = 0
FOR j = 1 TO nch
FOR k = 1 TO nhom(i)
code = ncode(nindex(i)+k-1)
IF choice(j,1-ll) = code THEN
newnch = newnch + 1
choice(newnch,ll) = code
k = mhom
END IF
NEXT k
NEXT j
IF newnch = 0 THEN
nch = -1:REM inconsistent nouns
EXIT SUB
END IF
nch = newnch
ll = 1 - ll
GOTO ExNoun1
END IF
ExNoun2:
IF ll = 0 THEN
FOR i = 1 TO nch
choice(i,0) = choice(i,1)
NEXT i
END IF
END SUB
' Skip noun (skips nouns without looking at meaning)
SUB SkipNoun(cmd$) STATIC
SHARED noun$
ll = 0
SkipNoun1:
IF cmd$ = "" THEN EXIT SUB
c$ = ","+LEFT$(cmd$,INSTR(cmd$," ")-1)+","
c = INSTR(noun$,c$)
IF c = 0 THEN EXIT SUB
cmd$ = MID$(cmd$,LEN(c$))
WHILE (MID$(cmd$,1,1) = " ")
cmd$ = MID$(cmd$,2)
WEND
GOTO SkipNoun1
END SUB
' GetNoun() uses ExNoun to return all possible noun code choices,
' and tries to resolve the ambiguity by calling ChooseVisible to
' see if the object is in the room or on the player. If this
' fails, then tries using the vtype1 flag, and then the vtype2
' flag (see ChooseVisible for explanation of vtype.) (vtype1 is
' nounat(verb) and vtype2 is noundef(verb) (see Commands for
' explanation of nounat and noundef.))
' Returns ch = -1 for inconsistent nouns
' Returns ch = -2 for ambiguity not resolved by visual check
' Returns that = 1 if a "that" clause follows
' See ExNoun() and ChooseVisible()
SUB GetNoun(cmd$,choice(2),ch,n,vtype1,vtype2,that) STATIC
SHARED c1()
z = 0
c1(0) = 0:c1(1) = vtype1:c1(2) = vtype2
IF vtype1 <> c1(z) THEN z = z + 1:c1(z) = vtype1
IF vtype2 <> c1(z) THEN z = z + 1:c1(z) = vtype2
och = ch
CALL ExNoun(cmd$,choice(),ch,that)
IF that THEN IF ch = och THEN EXIT SUB
IF ch = 1 THEN
n = choice(1,0)
ELSEIF ch = -1 THEN
EXIT SUB
ELSE '*** Try to resolve ambiguity
FOR i = 0 TO z
CALL ChooseVisible(choice(),ch,c1(i))
IF ch = 1 THEN 'Found it
n = choice(1,0)
EXIT SUB
ELSEIF ch < -1 AND i = 0 THEN 'Can't see anywhere
ch = -2
EXIT SUB
ELSEIF ch <= 0 THEN 'Return last step's ambiguity
ch = -ch
EXIT SUB
END IF
NEXT i
END IF
END SUB
' Get preposition
SUB GetPrep(cmd$,p) STATIC
SHARED prep$,prepn$()
WHILE (1)
IF cmd$ = "" THEN EXIT SUB
c$ = ","+LEFT$(cmd$,INSTR(cmd$," ")-1)+","
c = INSTR(prep$,c$)
IF c = 0 THEN EXIT SUB
lp = LEN(c$) - 2
p = VAL(MID$(prep$,c + lp + 2))
cmd$ = MID$(cmd$,lp + 2)
WHILE (MID$(cmd$,1,1) = " ")
cmd$ = MID$(cmd$,2)
WEND
WEND
END SUB
' Routine scans the choice array and returns an array with only
' visible items. Returns the same array with a negative
' nchoice if none of the items are visible.
' If vtype is 1, then only checks to see if object is visible on the
' player, and if 2, then only checks if objects is visible in room,
' but not carried by player. If 0, checks both places.
SUB ChooseVisible(choice(2),nchoice,vtype) STATIC
SHARED mhom
IF nchoice < 2 THEN EXIT SUB
newnchoice = 0
FOR i = 1 TO nchoice
CALL Visible(choice(i,0),vis,vtype)
IF (vis) THEN
newnchoice = newnchoice + 1
choice(newnchoice,1) = choice(i,0)
END IF
NEXT i
IF newnchoice = 0 THEN
nchoice = -nchoice
EXIT SUB
ELSE
nchoice = newnchoice
FOR i = 1 TO nchoice
choice(i,0) = choice(i,1)
NEXT i
END IF
END SUB
' Parses the cmd$ string and returns the next preposition and
' noun (used in a sentence like "get the water that's *in the bottle*")
' Returns -1 in tp if player overrided command in an AskAmbig process
' Returns -2 in tp if player makes a fatal grammatical error
SUB GetThatClause(cmd$,tp,tn) STATIC
SHARED nchoice2()
IF tp THEN GetThatClause1
tn = 0:tp = 0
CALL SkipNoun(cmd$)
CALL GetPrep(cmd$,tp)
GetThatClause1:
IF tp < 1 OR tp > 4 THEN EXIT SUB
nch = 0:ambig = 0:that = 0
GetThatClause2:
CALL GetNoun(cmd$,nchoice2(),nch,tn,0,0,that)
IF that THEN
PRINT"Your language is too complex for me. Please restate."
tp = -2
EXIT SUB
END IF
IF ambig = 1 AND nch = 0 THEN ' AskAmbig (see below) failed, so
cmd$ = amb$ ' assume that the player overrided the old command, and
tp = -1 ' return a -1 error flag
EXIT SUB
ELSE
ambig = 0 ' Clear AskAmbig flag
END IF
IF nch = -1 THEN GOSUB Absurd:tp = -2:EXIT SUB
IF nch = -2 THEN GOSUB Mystery:tp = -2:EXIT SUB
IF nch > 1 THEN ' Ask player to resolve ambiguity
CALL AskAmbig(nchoice2(),nch,that)
IF that THEN PRINT"Wait a sec---I'm getting confused. Let's start over from the beginning.":EXIT SUB
PRINT:LINE INPUT"> ";amb$:amb$ = amb$ + " ":PRINT
cmd$ = amb$ + cmd$:ambig = 1 ' (see above)
GOTO GetThatClause2 ' Try to resolve ambiguity
END IF
END SUB
' Skips a clause of the form preposition-noun
SUB SkipThatClause(cmd$) STATIC
CALL SkipNoun(cmd$)
CALL GetPrep(cmd$,a)
CALL SkipNoun(cmd$)
END SUB
' Attempts to resolve ambiguity by choosing only those
' items in array(,0) that are related to tn by mode tr
' (i.e., only objects that are "in" the "bottle", "on" the "table", etc.)
SUB ResolveThat(array(2),nch,n,tr,tn) STATIC
SHARED par(),rel(),mrel
IF tn<0 THEN EXIT SUB
IF tr<0 OR tr>mrel THEN EXIT SUB
nnch = 0
FOR i = 1 TO nch
IF array(i,0) < 0 THEN
nnch = nnch + 1
array(nnch,1) = array(i,0)
ELSEIF par(array(i,0)) = tn AND rel(array(i,0)) = tr THEN
nnch = nnch + 1
array(nnch,1) = array(i,0)
END IF
NEXT
nch = nnch
FOR i = 1 TO nch
array(i,0) = array(i,1) ' Copy array to position zero
NEXT
IF nch = 1 THEN n = array(1,0)
END SUB
Initialize:
CLS
PRINT"Welcome to "game$"!
PRINT"One moment please . . ."
DEF FNcap$(a$) = CHR$(ASC(a$) AND 223) + MID$(a$,2)
z$ = CHR$(8)
' Stack for routines which recursively search object lists
' (Maximum stack depth 30)
mdepth = 30
DIM cc(mdepth),mc(mdepth)
' General storage arrays for subroutines
mlist = 50
DIM c1(mlist),c2(mlist)
' Read abstract descriptions
RESTORE abstract
READ mabs 'Maximum # of abstract nouns
DIM abstract$(mabs),abstract(mabs)
READ a
WHILE (a <> 0)
READ abstract$(a)
READ a
IF a > nabs THEN nabs = a
WEND
' Read "folded" state
RESTORE fold
READ mfold
DIM fold$(mfold)
nfold = 0
READ f$
WHILE (f$ <> "")
nfold = nfold + 1
fold$(nfold) = f$
READ f$
WEND
' Read verbs
RESTORE Verbs
DIM verb$(2)
nverb = 0
FOR i = 0 TO 2
v = 1
WHILE (v <> 0)
READ v$,v
verb$(i) = verb$(i) + "," + v$ + "," + STR$(v)
IF v > nverb THEN nverb = v
WEND
NEXT i
' Read verb attributes (verbs must be in order!)
RESTORE Commands
DIM reqnoun(1,nverb),defprep(nverb),nounat(1,nverb)
DIM noundef(1,nverb),nounpl(1,nverb)
FOR i = 1 TO nverb
READ reqnoun(0,i),reqnoun(1,i),defprep(i),nounat(0,i),nounat(1,i)
READ noundef(0,i),noundef(1,i),nounpl(0,i),nounpl(1,i)
NEXT i
'*** Set the null verb's "attributes"
nounpl(0,0) = 2:nounpl(1,0) = 2
' Read nouns
RESTORE Nouns
READ mnouns,mcode
DIM nindex(mnouns),nhom(mnouns),ncode(mcode)
noun$ = ""
nnoun = 0
mhom = 0:REM maximum number of homonyms for any noun
nbase = 0:REM start at base of ncode table
code = 0
READ n$
WHILE (n$ <> "")
noun$ = noun$ + "," + n$ + "," + STR$(nnoun)
hom = 0
nindex(nnoun) = nbase
READ code
WHILE (code <> 0)
ncode(nbase) = code
nbase = nbase + 1
hom = hom + 1
READ code
WEND
nhom(nnoun) = hom
IF hom > mhom THEN mhom = hom
nnoun = nnoun + 1
READ n$
WEND
' Read prepositions
RESTORE Prepositions
prep$ = ""
nprep = 0
READ p$
WHILE (p$ <> "")
READ p
nprep = nprep + 1
prep$ = prep$ + "," + p$ + "," + STR$(p)
READ p$
WEND
' Read preposition names
RESTORE Prepnames
DIM prepn$(nprep)
READ p$
nprepn = -1
WHILE (p$ <> "")
nprepn = nprepn + 1
prepn$(nprepn) = p$
READ p$
WEND
imap:
' Read map (see Locations: for details)
PRINT"I am reading the map . . ."
RESTORE map
READ mloc,avdes,mmcond,mfcond,avfcond
DIM map(mloc,9),Llight(mloc),Lon(mloc)
DIM dindex(mloc),des$(mloc * avdes)
DIM mcond(4,mloc),mmes$(mloc)
DIM findex(mloc),fcond(5,mfcond),fdes$(mfcond * avfcond)
REM N,NE,E,SE,S,SW,W,NW,U,D, water, light, lighton?
nloc = 1:ndes = 0:nmcond = 0:nfcond = 0:nfcdes = 0
READ l
WHILE (l <> 0)
nloc = nloc + 1
IF nloc <> l THEN PRINT"MAP IS IN BAD FORMAT AT LOC"nloc:STOP
cmcond = 0 ' Count the number of map cond. in this location
FOR i = 0 TO 9
READ n
IF (n < 0) AND (n > -99) THEN
n = -n
IF n > cmcond THEN cmcond = n
map(l,i) = -nmcond - n
ELSE
map(l,i) = n
END IF
NEXT i
READ Llight(l),Lon(l)
FOR j = 1 TO cmcond ' Read map conditionals (if there are any)
nmcond = nmcond + 1
FOR k = 0 TO 4
READ mcond(k,nmcond)
NEXT k
READ mmes$(nmcond)
NEXT j
dindex(l) = ndes
READ des$(ndes) ' First line is short description (can be NULL)
WHILE (des$(ndes) <> "") ' Succeeding lines are long descriptions
ndes = ndes + 1
READ des$(ndes)
WEND
READ a,b,c,d
findex(l) = nfcond + 1
WHILE (a <> -1) ' Read a flag conditional
nfcond = nfcond + 1
fcond(0,nfcond) = a:fcond(1,nfcond) = b:fcond(2,nfcond) = c
fcond(3,nfcond) = d:fcond(4,nfcond) = nfcdes
READ fdes$(nfcdes)
WHILE (fdes$(nfcdes) <> "")
nfcdes = nfcdes + 1
READ fdes$(nfcdes)
WEND
READ a,b,c,d
WEND
READ l
WEND
dindex(nloc+1) = ndes:fcond(4,nfcond+1) = nfcdes ' Mark end of description lists
findex(nloc+1) = nfcond + 1 ' and mark end of flag lists
' Read flags
' Flag 1 is lamp on/off, flag 2 is daytime/nighttime
RESTORE Flags
READ mflag
nflag = 0
DIM flag(mflag)
READ f
WHILE (f)
IF f>nflag THEN nflag = f
READ flag(f),f
WEND
iobj:
' Read objects
DIM Lfirst(nloc),Llast(nloc),seen(nloc)
RESTORE Objects
READ mobj,mrel,mbot
DIM pre$(mobj),word$(mobj),adj$(mobj),long$(mobj)
DIM lo(mobj),par(mobj),rel(mobj)
DIM first(mrel,mobj),last(mrel,mobj),left(mobj),right(mobj)
DIM size(mobj),opening(mrel,mobj),cap(mrel,mobj),opaque(mrel,mobj)
DIM closed(mobj),openable(mobj)
DIM folded(mobj),foldable(mobj),locked(mobj),holdwater(mobj)
DIM worn(mobj),wearable(mobj),soft(mobj),food(mobj),immobile(mobj)
DIM totw(mobj),totb(mobj),bulk(mrel,mobj)
DIM bottles(mbot)
nbot = -1 ' Keep a list of bottles
' Read objects
nobj = 0
READ n
WHILE (n <> 0)
IF (n > nobj) THEN nobj = n
READ pre$(n),word$(n),adj$(n),long$(n)
READ lo(n),par(n),rel(n)
READ size(n),wei
FOR i = 0 TO mrel
READ opening(i,n)
NEXT i
anycap = 0
FOR i = 0 TO mrel
READ cap(i,n)
anycap = anycap OR cap(i,n)
NEXT i
FOR i = 0 TO mrel
READ opaque(i,n)
NEXT i
READ closed(n),openable(n),folded(n),foldable(n),locked(n)
READ holdwater(n),worn(n),wearable(n),soft(n),food(n),immobile(n)
IF holdwater(n) THEN nbot = nbot + 1:bottles(nbot) = n
totw(n) = wei
totb(n) = size(n)
IF par(n) <> 0 OR immobile(n) = 0 OR anycap <> 0 THEN
IF par(n) THEN
CALL Insert(n,par(n),rel(n))
ELSE
CALL Insert(n,-lo(n),0)
END IF
END IF
READ n: REM next object
WEND
Arrays:
' Arrays hold homonyms for ambiguity resolution
DIM nchoice(mhom + 2,1),nchoice2(mhom + 2,1)
' Arrays hold lists of nouns and objects
DIM lnoun(1,mlist),nlnoun(1),ncount(1),olnoun(mlist)
DIM mnoun(1,mlist),mlnoun(1),mcount(1)
' Commands can be superseded temporarily by other commands (e.g.,
' if you say "wear hat" you must first "take" it; the program will
' automatically do this) But for the sake of the multiple-noun
' sequences, etc., the command must be restored to its original
' form, even if it has been superseded. Thus, you use RecordCommand
' and RestoreCommand to store this activity on a "command stack".
' The Alias() subprogram does this automatically for you.
mrlev = 10 ' Maximum ten (!) levels of command stack
DIM vo(mrlev),po(mrlev),no(mrlev,1)
DIM vo$(mrlev),po$(mrlev),no$(mrlev,1),nno$(mrlev,1)
' Arrays hold the direct object and indirect object
DIM n(1),n$(1),nn$(1)
Initvals:
GOSUB Flags ' Set mnemonic variables
fdindex = 4 ' internal use constant (see Look:)
fseen = 5 ' internal use constant (see SaveGame: and Look:)
' Setup starting values
l = 2:ol = 2:REM You start in room 2
t = flag(tim):REM time is kept by flag variable "tim"
GOSUB ClearCommand:FOR z = 0 TO 1:ncount(z) = 0:nlnoun(z) = 0:NEXT
v = 1:REM "Look" is the first command
v$ = "look"
Player:
maxcap = 15:maxweight = 50:REM Player's capacity, total weight capacity
maxgrab = 20:maxlift = 40:REM Maximum size, weight, player can lift (see Take:)
fat = 20:REM Size of player while sitting (3*fat is size when lying down)
GOTO PreProcess
NewCommand:
rlev = 0 ' Clear command stack
GOSUB RecordCommand
GOSUB ClearCommand
GOSUB ClearList
ncmd$ = "":GOTO InCommand
ContCommand:
rlev = 0 ' Clear command stack
GOSUB RecordCommand
ncmd$ = "":GOTO InCommand
GetCommand:
rlev = 0 ' Clear command stack
IF nlnoun(1) THEN '*** take care of multiple indirect objects
ncount(1) = ncount(1) + 1
IF ncount(1) <= nlnoun(1) THEN
n(1) = lnoun(1,ncount(1))
CALL NameNoun(n(1),n$(1),nn$(1))
PRINT p$" "nn$(1)": ";
GOTO Filter
END IF
END IF
IF nlnoun(0) THEN '*** take care of multiple direct objects
ncount(0) = ncount(0) + 1
IF ncount(0) <= nlnoun(0) THEN
ncount(1) = 1
IF nlnoun(1) THEN n(0) = lnoun(1,1)
n(0) = lnoun(0,ncount(0))
CALL NameNoun(n(0),n$(0),nn$(0))
PRINT nn$(0)": ";
GOTO Filter
END IF
END IF
GOSUB RecordCommand
GOSUB ClearCommand
GOSUB ClearList
InCommand:
PRINT
IF ncmd$ = "" THEN
LINE INPUT"> ";cmd$:PRINT:cmd$ = cmd$ + " "
ELSE
GOSUB waitforesc:IF a$ = CHR$(27) THEN NewCommand
cmd$ = ncmd$
END IF
Parse: ' Take care of grammatical quirks
a = INSTR(cmd$,".") ' Periods
IF (a) THEN
ncmd$ = MID$(cmd$,a+1)
WHILE (MID$(ncmd$,1,1) = " ")
ncmd$ = MID$(ncmd$,2)
WEND
cmd$ = LEFT$(cmd$,a-1) + " "
ELSE
ncmd$ = ""
END IF
a = INSTR(cmd$,",and ") ' Replace commas
WHILE (a)
cmd$ = LEFT$(cmd$,a-1)+" and "+MID$(cmd$,a+5)
a = INSTR(cmd$,",and ")
WEND
a = INSTR(cmd$,", and ")
WHILE (a)
cmd$ = LEFT$(cmd$,a-1)+" and "+MID$(cmd$,a+6)
a = INSTR(cmd$,", and ")
WEND
a = INSTR(cmd$,",")
WHILE (a)
cmd$ = LEFT$(cmd$,a-1)+" and "+MID$(cmd$,a+1)
a = INSTR(cmd$,",")
WEND
WHILE (MID$(cmd$,1,1) = " ") ' Get rid of excess spaces
cmd$ = MID$(cmd$,2)
WEND
Interpret: ' nn is the noun number (0 = direct obj, 1 = indirect obj)
IF cmd$ = "" THEN PRINT"Say what?":GOTO ContCommand
nlnoun(0) = 0:nlnoun(1) = 0 '*** stop multiple noun loops
ocmd$ = cmd$:locmd=LEN(ocmd$)
IF noobj THEN v = 0 '*** See Filter: for origin of noobj flag
CALL GetVerb(cmd$,v,v$)
IF noobj THEN
IF v <> 0 AND v <> vo THEN
vo=v:vo$=v$
GOSUB ClearCommand '*** User can override old verb
v=vo:v$=vo$
ELSE
v=vo
END IF
END IF
IF cmd$ = "" THEN PreProcess
IF noobj THEN InPrep
ambig=0:but=0:cand=0:nch=0:that=0:nn=0
InNoun:
CALL GetNoun(cmd$,nchoice(),nch,n(nn),nounat(nn,v),noundef(nn,v),that)
IF nch = -1 THEN PRINT"I don't understand what you're talking about.":GOTO NewCommand
IF nch = -2 THEN GOSUB Mystery:GOTO NewCommand
IF nn = 0 THEN
IF cmd$<>"" AND nounpl(1,v) = 0 THEN ' default "that" clause?
tn=0:c=0:CALL GetPrep(cmd$,c)
IF c > 0 AND c < 8 THEN
tp=c:that=1:GOTO InThatClause
ELSE ' Message for InPrep not to scan again for a preposition
trp=c
END IF
END IF
END IF
IF that THEN ' "that" clause
tp=0:tn=0
InThatClause:
IF nch = 0 THEN
CALL SkipThatClause(cmd$)
ELSE
CALL GetThatClause(cmd$,tp,tn)
IF tp = -1 THEN Parse
IF tp = -2 THEN NewCommand
IF ambig = 1 AND tn = 0 THEN 'Ambig resolution failed, so
GOTO Parse ' assume player overrided old command and start over
END IF
IF tp < 0 OR tp > 4 OR tn = 0 THEN
IF cmd$ <> "" THEN
PRINT"I don't know what you mean by '"cmd$"'.
GOTO NewCommand
ELSE
PRINT"That's . . . what?" ' Try to resolve ambiguity
PRINT:LINE INPUT"> ";cmd$:cmd$=cmd$+" ":PRINT
ambig=1:GOTO InThatClause
END IF
END IF
CALL ResolveThat(nchoice(),nch,n(nn),tp-1,tn)
IF nch = 0 THEN GOSUB Mystery:GOTO NewCommand
END IF
END IF
IF ambig = 1 AND nch = 0 THEN ' AskAmbig (see below) failed, so
cmd$=amb$ ' assume that the player overrided the old command, and
GOTO Parse ' start over
ELSE
ambig = 0 ' Clear AskAmbig flag
END IF
IF nch > 1 THEN ' Ask player to resolve ambiguity
that = 0:CALL AskAmbig(nchoice(),nch,that)
PRINT:LINE INPUT"> ";amb$:amb$ = amb$ + " ":PRINT
cmd$ = amb$ + cmd$:ambig = 1 ' (see above)
GOTO InNoun ' Try to resolve ambiguity
END IF
IF nch THEN
IF n(nn) = -12 THEN ' Resolve pronoun ambiguity
IF no(0,1) > 0 THEN ' Choose last noun referenced
n(nn)=no(0,1)
ELSEIF no(0,0) > 0 THEN
n(nn)=no(0,0)
ELSE
n(nn)=0
END IF
IF n(nn) <> 0 THEN
CALL NameNoun(n(nn),n$,nn$)
IF nn = 0 THEN
PRINT"("nn$")
ELSE
PRINT"("p$" "nn$")
END IF
END IF
END IF
IF but = 0 THEN ' "and" clause
IF n(nn) = -11 THEN ' this is the "all" noun
na = noundef(nn,v):IF na = 0 THEN na = 3
IF that = 1 AND tp > 0 AND tn > 0 THEN ' everything that's in ...
that = 0
CALL Visible(tn,vis,0)
IF vis = 0 THEN GOSUB Mystery:GOTO NewCommand
' Place test particle in tn, relation tp-1, to see if
' stuff in there is visible or not
lo(0)=lo(tn):par(0)=tn:rel(0)=tp-1
CALL Visible(0,vis,0)
IF vis THEN
ThatAgain:
CALL ListSib(first(tp-1,tn),lnoun(),nlnoun(),nn)
ELSE
IF closed(tn) THEN
PRINT"(opening the "word$(tn)" first): ";
CALL Alias("open",8,(tn),0,0):GOSUB OpenIt
GOSUB RestoreCommand
lo(0)=lo(tn):par(0)=tn:rel(0)=tp-1
CALL Visible(0,vis,0)
IF vis=0 THEN NewCommand ELSE GOTO ThatAgain
ELSE
GOSUB Mystery:GOTO NewCommand
END IF
END IF
ELSE
IF na AND 1 THEN CALL ListSib(first(1,1),lnoun(),nlnoun(),nn)
IF na AND 2 THEN CALL ListSib(Lfirst(l),lnoun(),nlnoun(),nn)
END IF
IF nlnoun(nn) = 0 THEN n(nn) = 0 ELSE n(nn) = lnoun(nn,1)
ELSEIF n(nn) = -13 THEN ' plural pronoun
IF ncount(nn) = 0 THEN
FOR i = 1 TO onlnoun
nlnoun(nn) = nlnoun(nn) + 1
lnoun(nn,nlnoun(nn)) = olnoun(i)
NEXT
IF nlnoun(nn) = 0 THEN n(nn) = 0 ELSE n(nn) = lnoun(nn,1)
END IF
ELSEIF n(nn) <> 0 THEN
nlnoun(nn) = nlnoun(nn) + 1
lnoun(nn,nlnoun(nn)) = n(nn)
END IF
ELSE '"but" clause
IF n(nn) = -11 THEN PRINT"You humans have a strange way of speaking.":GOTO NewCommand
IF n(nn) = -13 THEN ' plural pronoun
FOR i = 1 TO onlnoun
a = 0
FOR j = 1 TO nlnoun(nn)
IF lnoun(nn,j) = olnoun(i) THEN a=1:nlnoun(nn)=nlnoun(nn)-1
IF a THEN lnoun(nn,i) = lnoun(nn,i+1)
NEXT
NEXT
ELSE ' single word
a = 0
FOR i = 1 TO nlnoun(nn)
IF lnoun(nn,i) = n(nn) THEN a = 1:nlnoun(nn) = nlnoun(nn) - 1
IF a THEN lnoun(nn,i) = lnoun(nn,i+1)
NEXT
END IF
IF nlnoun(nn) THEN n(nn) = lnoun(nn,1) ELSE n(nn) = 0
END IF
ELSE
IF cand = 1 THEN ncmd$ = cmd$+"."+ncmd$:cmd$ = "":GOTO PreProcess
END IF
IF cmd$ = "" THEN PreProcess
InPrep:
lcmd = LEN(cmd$)
c = 0:IF trp THEN c=trp:trp=0 ELSE CALL GetPrep(cmd$,c)
IF c = 0 THEN PreProcess
IF c < 8 AND nn = 0 THEN p = c:ploc = locmd-lcmd ' Record prep location
IF cmd$ = "" THEN PreProcess
IF (c = 8 AND nn = 0 AND n(0) = 0) THEN
ncmd$ = cmd$ + "." + ncmd$
cmd$ = ""
GOTO PreProcess
END IF
IF c = 8 THEN cand = 1:nch = 0:that = 0:GOTO InNoun ' and ...
IF c = 9 THEN but = 1:nch = 0:that = 0:GOTO InNoun ' but ...
IF nn = 1 THEN ' What!? Insert a "that's" and start over
IF warnthat < 3 THEN
warnthat = warnthat + 1
PRINT"(Please use more specific language in the future, e.g.,
PRINT CHR$(34)LEFT$(ocmd$,ploc)"THAT'S "MID$(ocmd$,ploc+1)CHR$(8)CHR$(34)"-Ed.)
END IF
GOSUB ClearCommand:GOSUB ClearList
cmd$ = LEFT$(ocmd$,ploc)+"that's "+MID$(ocmd$,ploc+1)
ocmd$ = cmd$:locmd = LEN(ocmd$)
GOTO Parse
END IF
nn = 1:but = 0:cand = 0:nch = 0:that = 0:GOTO InNoun 'Get indirect object
PreProcess:
nn = 0:p$ = prepn$(p)
FOR i = 0 TO 1
IF n(i) <> 0 THEN CALL NameNoun(n(i),n$(i),nn$(i))
NEXT
IF cmd$ <> "" THEN
cmd$ = LEFT$(cmd$,LEN(cmd$) - 1)
PRINT"I don't know what you mean by '"cmd$CHR$(8)"'.
GOTO NewCommand
END IF
FOR i = 0 TO 1
IF nlnoun(i) = 1 THEN nlnoun(i) = 0
NEXT
FOR i = 0 TO 1
IF nlnoun(i) THEN
IF nounpl(i,v) < 2 THEN
PRINT"You can't use multiple ";
IF i = 1 THEN PRINT"indirect ";
PRINT"objects with '"v$"'!
GOTO NewCommand
END IF
END IF
NEXT
IF nlnoun(0) > 0 OR nlnoun(1) > 0 THEN GetCommand
Filter:
'*** grammatical replacements
IF (n(0)<0) AND (n(0)>=-10) AND (v = 0) THEN v = 6: v$="go"
IF v = 3 THEN IF n(1) <> 0 THEN v = 7 ' "drop xxx on yyy" == "put xxx on yyy"
IF v = 0 AND n(0) = 0 AND n(1) = 0 THEN PRINT"I don't understand.":GOTO NewCommand
FOR i = 0 TO 1
IF n(i) <> 0 AND nounpl(i,v) = 0 THEN
PRINT"You can't use ";
IF i = 1 THEN PRINT"indirect ";
PRINT"objects with '"v$"'!
GOTO NewCommand
END IF
NEXT
IF v = 0 AND n(0) <> 0 THEN
PRINT"What do you want to do with "nn$(0)"?
GOTO ContCommand
END IF
IF v = 0 AND n(1) <> 0 THEN
PRINT". . . "prepn$(p)" "nn$(1)"?
GOTO ContCommand
END IF
FOR i = 0 TO 1
IF reqnoun(i,v) THEN
na = noundef(i,v):IF na = 0 THEN na = 3
IF n(i) = 0 THEN
IF na AND 1 THEN CALL ListSib(first(1,1),lnoun(),nlnoun(),i)
IF na AND 2 THEN CALL Li