1 {//-------------------------------------------------------------------------}
\r
3 {Copyright (C) 1990, 2009 - Apogee Software, Ltd. }
\r
5 {This file is part of Supernova. Supernova is free software; you can }
\r
6 {redistribute it and/or modify it under the terms of the GNU General Public }
\r
7 {License as published by the Free Software Foundation; either version 2 }
\r
8 {of the License, or (at your option) any later version. }
\r
10 {This program is distributed in the hope that it will be useful, }
\r
11 {but WITHOUT ANY WARRANTY; without even the implied warranty of }
\r
12 {MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. }
\r
14 {See the GNU General Public License for more details. }
\r
16 {You should have received a copy of the GNU General Public License }
\r
17 {along with this program; if not, write to the Free Software }
\r
18 {Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.}
\r
20 {Original Source: 1990 Scott Miller }
\r
21 {Prepared for public release: 03/19/09 - Joe Siegler, Apogee Software, Ltd. }
\r
23 {//-------------------------------------------------------------------------}
\r
24 {*****************************************************************************}
\r
26 {* by Scott Miller *}
\r
27 {* This include file to Adgame contains the word parser commands. *}
\r
28 {* Copyright 1984 Pending *}
\r
29 {*****************************************************************************}
\r
32 procedure RR(RoomNum : integer);
\r
34 seek(rooms1,RoomNum);seek(rooms2,RoomNum);
\r
35 READ(rooms1,text1);READ(rooms2,text2);
\r
36 writeln(text1,text2);
\r
40 procedure RS(RoomNum : integer);
\r
43 seek(Special1,RoomNum);seek(Special2,RoomNum);
\r
44 READ(Special1,text1);READ(Special2,text2);
\r
45 writeln(text1,text2);
\r
46 end; {of SpecialRead}
\r
48 procedure RL(RoomNum : integer);
\r
52 seek(Line1,RoomNum);
\r
58 procedure Format(var input : Str80);
\r
59 procedure D(A:str14; B: Byte);
\r
60 begin while pos(A,input)<>0 do delete(input,pos(A,input),B) end;
\r
61 begin input:=input+' '; insert(' ',input,1);
\r
62 d(' of ',3); d(' go ',3); d('''',1); d('"',1); d(',',1);
\r
63 d(' a ',2); d('?',1); d('!',1); d(';',1); d('#',1);
\r
64 d(' the ',4); d('fly ',4); d('drive ',6); d('run ',4);
\r
65 d('walk ',5); d('travel ',7); d('please ',7); d('room ',5);
\r
66 d('crawl se',6); d('crawl nw',6); d('steer ',6); d('crawl n ',6);
\r
67 d('crawl s ',6); d('crawl e',6); d('crawl w',6); d('that ',5);
\r
68 d('first ',6); d('second ',7); d('number ',7);
\r
69 d('this ',5); d('game ',5); d('i want to ',10); d(' my ',3); d('big ',4);
\r
70 d('those ',6); d('them ',5); d('broken ',7); d('large ',6);
\r
71 d('huge ',5); d('small ',6); d('tiny ',5);d('little ',7); d('within ',4);
\r
72 d('yes ',3); d('no ',2); d('wade ',4); d('swim ',4);
\r
73 while pos('examine ',input)>0 do delete(input,pos('examine ',input)+2,5);
\r
74 while pos('into ',input)>0 do delete(input,pos('into ',input)+2,2);
\r
75 while pos('. ',input)>0 do delete(input,pos('. ',input)+1,1);
\r
76 while pos('inside ',input)>0 do delete(input,pos('inside ',input)+2,4);
\r
77 d(' .',1); d(' ',1); d('..',1);
\r
78 if(input[1]='.')then delete(input,1,1);
\r
79 while(length(input)>0)and(input[1]=' ')do delete(input,1,1);
\r
80 while(length(input)>0)and(input[length(input)]=' ')do
\r
81 delete(input,length(input),1);
\r
82 if(input='')or(input[1]='.')then writeln('Whoops!')
\r
86 procedure Chop(var input : Str80);
\r
90 if length(input) >0 then
\r
96 while(input[j]<>' ')and(input[j]<>'.')do begin
\r
97 Word:=Word+input[j];
\r
100 if length(Word) >7 then
\r
102 l:=pos(Word,input);
\r
103 j:=j+(7-length(Word));
\r
104 delete(input,l,length(Word));
\r
105 delete(Word,8,120);
\r
106 insert(Word,input,l)
\r
109 until (j-1)=length(input);
\r
110 delete(input,length(input),1)
\r
115 procedure LowerCase(var input : Str80);
\r
118 if length(input) > 0 then
\r
119 for j:=1 to length(input) do
\r
120 if(input[j] in ['A'..'Z'])then
\r
121 input[j]:=chr(ord(input[j])+32)
\r
122 end; {of LowerCase}
\r
125 procedure FindVerb (var input:Str80;var Word:Str14;var Verb:integer);
\r
126 var j, k, r : integer;
\r
131 while input[j]<>' ' do begin
\r
132 Word:=Word+input[j];
\r
135 if length(Word+' ')<length(input)then begin
\r
136 Word:=Word+' '; j:=j+1;
\r
137 while input[j]<>' ' do begin
\r
138 Word:=Word+input[j];
\r
144 for r:= 0 to VMax do
\r
149 if v[r,k]=Word then
\r
151 until (v[r,k]=Q)or(k=5)
\r
154 if(pos(' ',Word)<>0)and(Verb=Null)then
\r
156 delete(Word,pos(' ',Word),8);
\r
157 for r:=0 to VMax do
\r
162 if v[r,k]=Word then
\r
164 until (v[r,k]=Q)or(k=5)
\r
167 delete(input,length(input),1);
\r
168 if Verb<>Null then delete(input,1,length(Word));
\r
169 if input[1]=' 'then delete(input,1,1)
\r
173 procedure FindNoun(var input:Str80;var Word:Str14;var Noun:integer);
\r
174 var j, k, t : integer;
\r
179 while input[j]<>' ' do begin
\r
180 Word:=Word+input[j];
\r
183 if length(Word+' ')<length(input)then begin
\r
184 Word:=Word+' ';j:=j+1;
\r
185 while input[j]<>' ' do begin
\r
186 Word:=Word+input[j];
\r
192 for t:=0 to NMax do
\r
197 if n[t,k]=Word then
\r
199 until (n[t,k]=Q)or(k=5)
\r
202 if(pos(' ',Word)<>0)and(Noun=Null)then
\r
204 delete(Word,pos(' ',Word),8);
\r
205 for t:=0 to NMax do
\r
210 if n[t,k]=Word then
\r
212 until (n[t,k]=Q)or(k=5)
\r
215 delete(input,length(input),1);
\r
216 if Noun<>Null then delete(input,1,length(Word));
\r
217 if input[1]=' 'then delete(input,1,1)
\r
221 procedure FindSep(var input : Str80; var h : Str14);
\r
227 while input[j]<>' ' do begin
\r
231 if pos(' '+h+' ',' crawl on at to in off with within into '+
\r
232 ' above against through beside behind around across '+
\r
233 ' inside from by under using near over onto down ') >0 then
\r
235 delete(input,length(input),1);
\r
236 delete(input,1,length(h));
\r
237 if input[1]=' ' then delete(input,1,1);
\r
238 if(h='on')or(h='around')or(h='above')or(h='over')or(h='onto')
\r
240 if(h='inside')or(h='within')or(h='through')or(h='into')or(h='down')
\r
242 if(h='using')then h:='with';
\r
243 if(h='beside')or(h='by')then h:='near';
\r
244 if(h='against')then h:='at';
\r
245 if(h='across')then h:='over'
\r
250 delete(input,length(input),1)
\r
255 procedure Check(var SepWord : Str14);
\r
258 Verb:=Null; Noun:=Null; Noun2:=Null; DialNum:=Null; Flag:='?';
\r
260 if length(input)>0then
\r
262 FindVerb(input,Word,Verb);
\r
264 if(length(input)>0)and not(Verb in [31,53,63])then
\r
266 FindNoun(input,Word,Noun);
\r
267 If(Noun<>Null)then LastNoun:=n[noun,1];
\r
269 if(Verb in[0,8,9,21,36,6,7,15,17,32,26])and(length(input)=0)then
\r
272 if(Verb in[36,15])then Verb:=9
\r
275 if(Verb in[0,8,21,36,37,29,9,39,6,15,7,17,32,26,40])then
\r
276 if length(input)>0 then
\r
278 if(Verb=9)then Verb:=29 else ;
\r
279 FindSep(input,SepWord);
\r
280 if SepWord<>'s' then
\r
281 if length(input)>0 then
\r
284 val(input,DialNum,j);
\r
289 FindNoun(input,Word,Noun2);
\r
290 if Noun2<>Null then
\r
291 if length(input)>0 then
\r
297 FindVerb(input,Word,Verb);
\r
298 if Verb=Null then Flag:='n'
\r
303 if(Verb=39)and((SepWord='to')or(SepWord='off'))then
\r
304 Flag:='g' else Flag:='e'
\r
311 if length(input)>0 then
\r
312 begin FindVerb(input,Word,j);if j<>Null then Flag:='b' else
\r
313 begin FindSep(input,SepWord);if SepWord<>'s' then Flag:='b' else
\r
314 begin FindNoun(input,Word,j);if j<>Null then Flag:='h' end end;
\r
315 if Flag='?' then Flag:='v'
\r
321 FindVerb(input,Word,Verb);
\r
322 if Verb=Null then Flag:='n'
\r
327 if Verb in OneWordCommands then Flag:='g'
\r
331 FindNoun(input,Word,Noun2);
\r
332 If Noun2=Null then Flag:='v'
\r
337 'v','n':if pos(' '+Word+' ',' crawl on at to in off with within into '+
\r
338 ' above against through beside behind around down '+
\r
339 ' inside by under using near over onto top below '+
\r
340 ' from away want across ')>0 then begin
\r
341 write('The word ''',Word);RL(393)end
\r
342 else writeln('I don''t understand the word ''',Word,'.''');
\r
344 if pos(' ',Word)>0 then delete(Word,pos(' ',Word),9);
\r
345 writeln('You can''t use the word ''',Word,''' here.')
\r
352 'h' :begin write(Word);RL(392)end
\r
355 if flag<>'g' then begin Attack:=False;Line:='';Skip:=False end
\r
358 {***************************** END OF ADPARSER ******************************}
\r