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 3 }
\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 (* >> Contains the Parser, Initialization, Time and Misc. Routines << *)
\r
27 (* Programmer: Scott Miller *)
\r
28 (* << Began February 2, 1985 >> *)
\r
29 (* Copyright 1985 Scott Miller *)
\r
30 (*****************************************************************************)
\r
32 procedure RL(Pointer:integer);forward;
\r
33 procedure RS(Pointer:integer);forward;
\r
34 procedure RR(Pointer:integer);forward;
\r
35 procedure RB(Pointer,Colour:byte);forward;
\r
36 procedure RB2(Pointer,Colour:byte);forward;
\r
37 procedure MC(WhichChar,WatchRoom,ToRoom:byte;MessageNum:Integer);forward;
\r
38 procedure Move(New:byte);forward;
\r
39 procedure DEAD;forward;
\r
40 procedure Call13;forward;
\r
41 procedure Van(o:byte);forward;
\r
42 function FN(VNP:byte):Str29;forward;
\r
43 function Here(Obj:byte):Boolean;forward;
\r
44 function Up(Word:Str130):Str1;forward;
\r
46 procedure SF; begin SFlag:=True end;
\r
48 procedure Cur(Num:byte);
\r
54 1:CX:=$707; { Underline }
\r
55 2:CX:=$8; { Solid block }
\r
56 3:CX:=$800; { Invisible }
\r
62 procedure Col(Num1,Num2:byte);
\r
63 begin if Color then textcolor(Num1) else textcolor(Num2) end;
\r
65 procedure Bak(Num1,Num2:byte);
\r
66 begin if Color then textbackground(Num1) else textbackground(Num2) end;
\r
68 procedure Bor(Num1,Num2:byte);
\r
71 begin AX:=$B00;if Color then BX:=Num1 else BX:=Num2 end;intr($10,Result)
\r
74 function En(Num:byte):boolean;
\r
75 begin if Num in Events then En:=true else En:=false end;
\r
77 procedure Add(Num:byte);
\r
78 begin Events:=Events+[Num] end;
\r
80 procedure Min(Num:byte);
\r
81 begin Events:=Events-[Num] end;
\r
83 procedure Score(Num,pointer:integer);
\r
84 begin if not en(pointer)then begin Sc:=Sc+Num;Add(Pointer)end end;
\r
86 procedure Cn(s:str78);
\r
87 begin gotoxy(40-(length(s)div 2),wherey);writeln(s)end;
\r
90 begin col(15,15);write('Press any key to continue...');
\r
91 read(kbd,CFlag);col(11,7);writeln;
\r
94 procedure Tune(Octave,Note,Duration:integer);
\r
99 for i:=1 to Octave do
\r
100 Frequency:=Frequency*2;
\r
101 for i:=1 to Note-1 do
\r
102 Frequency:=Frequency*1.059463094;
\r
103 if Duration <> 0 then
\r
105 sound(round(Frequency));
\r
109 else sound(round(Frequency));
\r
112 procedure Play(Start,Stop,Speed:integer);
\r
115 if Start<=Stop then
\r
116 for x:=Start to Stop do begin sound(x);delay(Speed)end
\r
118 for x:= Start downto Stop do begin sound(x);delay(Speed)end;
\r
119 nosound;if Region=4 then sound(20);if Region=5 then sound(60);
\r
122 procedure Explode(Duration:byte);
\r
124 begin for x:=Duration*999 downto 20 do sound(random(x));nosound end;
\r
126 procedure Walls(Duration:byte);
\r
128 begin for x:=1 to Duration*999 do sound(random(35)+20);nosound end;
\r
135 0:for y:=1 to random(70)+10 do sound(random(4000)+3000);
\r
136 1:begin nosound;delay(random(29))end
\r
137 end;nosound;if Region=5 then sound(60)
\r
144 begin play(550-x*6,600+x*6,0);play(600+x*6,550-x*6,0)end;explode(2)
\r
147 procedure Dopen(Num:byte);
\r
148 begin writeln('The door slides open...');
\r
149 if Num<>0 then play(50,125-Num,Num)
\r
150 else begin for i:=3500 to 5000 do sound(random(4500)+i);nosound;end;
\r
151 if Region=5 then sound(60)
\r
154 procedure Dclose(Num:byte);
\r
155 begin writeln('The sliding door closes.');
\r
156 if Num<>0 then play(125-Num,50,Num)
\r
157 else begin for i:=5000 downto 3500 do sound(random(4500)+i);nosound;end;
\r
158 if Region=5 then sound(60)
\r
161 procedure Door(New,Num:byte);
\r
163 if en(7)then RL(22)else
\r
164 if en(8)then RL(23)else begin DOpen(Num);Move(New);DClose(Num)end
\r
168 begin Tic:=Tic+1; Min(128); { <--Negates DEAD } col(13,15);
\r
169 for x:=1 to TMax do T[x]:=T[x]-1;
\r
170 if T[2]=1 then begin PStat:=PStat-[5];RL(1)end;
\r
171 case T[3] of { Hunger }
\r
172 25:begin PStat:=PStat+[2];RL(2)end;
\r
174 4:begin Bor(4,7);RL(4)end;
\r
175 1:begin RL(124);DEAD;end
\r
177 case T[4] of { Thirst }
\r
178 22:begin PStat:=PStat+[6];RL(5)end;
\r
180 4:begin Bor(4,7);RL(7)end;
\r
181 1:begin RL(125);DEAD;end
\r
183 case T[5] of { Sleep }
\r
184 32:begin PStat:=PStat+[5];RL(8)end;
\r
186 5:begin Bor(4,7);RL(10)end;
\r
187 1:begin RL(126);DEAD;end;
\r
188 2..13:begin x:=random(29)+1;
\r
189 if(x in Inv)and not(x in Wear)then
\r
190 begin Van(x);R[x]:=Prm;
\r
191 writeln('A bout of weariness causes you to loose your grip on',
\r
196 case T[29] of { Laser Injury }
\r
198 4:begin RL(507);Bor(4,7)end;
\r
199 2..11:begin repeat x:=random(27)+1 until x in[1..12,16..20,22..26,28];
\r
200 if(x in Inv)and not(x in Wear)then
\r
201 begin Van(x);R[x]:=Prm;
\r
202 if random(2)=0 then
\r
203 writeln('A sudden stab of pain shoots up your side, you drop the ',
\r
204 FN(x),'.') else begin
\r
205 writeln('The ',FN(x),' falls from your grip as you almost collapse ',
\r
206 'from the');writeln('extreme pain.')end
\r
209 1:begin RS(215);DEAD;end
\r
211 case T[12] of { Sickness }
\r
212 120,99,83,55:RL(207);
\r
213 65:begin PStat:=PStat+[3];RL(208)end;
\r
214 47:RL(209); 30:RS(73); 15:RS(74); 4:begin Bor(4,7);RS(75)end;
\r
215 1:begin RS(76);DEAD end;
\r
216 2..29:if(random(25)=0)and(Inv<>[])and not(en(125))then
\r
218 for x:=1 to 29 do if(x in Inv)and not(x in Wear)then
\r
219 begin Van(x);R[x]:=Prm end
\r
223 if(Prm in[81..88])and(T[30]<1)and(random(4)=0)then
\r
225 begin T[30]:=9;RS(153+Prm);
\r
226 for i:=999 to 2300 do sound(random(i*3)+i);
\r
227 for i:=3000 downto 20 do sound(random(i*4)+i*2);nosound
\r
231 write('A small droid appears from the ');
\r
233 81:write('south'); 82:write('southwest'); 83:write('west');
\r
234 84:write('northwest'); 85:write('north'); 86:write('northeast');
\r
235 87:write('east'); 88:write('southeast')
\r
236 end; writeln(' section of the corridor and flies');
\r
237 RS(242);RS(243);for i:=20 to 3000 do sound(random(i*3)+i);nosound;
\r
242 overlay procedure Time2A;
\r
243 begin col(10,7); { Pre-Jungle Planet }
\r
246 18:begin MC(1,8,8,1);MC(1,13,8,2)end;
\r
247 17:if en(19) then begin RS(9);T[1]:=11;end;
\r
248 11..17:if not(en(19))and(Prm=8)and(random(2)=1)then RL(0);
\r
250 9:begin MC(1,9,0,4);T[1]:=Null;end;
\r
251 5..7:if(en(2))and(en(3))then begin RB2(5-(T[1]-3),10);col(10,7)end;
\r
252 4:if Prm=8 then begin T[1]:=11;RS(5)end;
\r
254 if(T[7]=1)then begin RS(35);DEAD;end;
\r
255 if(T[6]=2)and(en(7))then RL(140);
\r
256 if(T[6]=1)and(en(7))then begin RS(20);DEAD;end;
\r
257 case T[8] of { Lift-off countdown }
\r
258 5:RL(181); 4:RL(182); 3:RL(191); 2:RL(192);
\r
260 begin Min(10);Min(26);Min(27);Explode(32);
\r
261 sound(20);Bor(0,0);Score(10,122);
\r
262 n[84]:='reactor regulat\';
\r
263 RB(7,10);delay(9999);Pause;col(10,7);RS(43);PStat:=PStat-[2,5,6];
\r
264 Region:=4;T[3]:=150;T[4]:=125;T[5]:=230;T[8]:=0;T[9]:=1;T[10]:=5;end
\r
265 else begin RS(44);Explode(32);DEAD;end;
\r
267 if T[9]<1 then T[9]:=15;
\r
268 if(Region=4)and(Prm=1)and(T[9]=12)then RS(62);
\r
269 if T[10] in[1..4]then RL(194);
\r
270 if(Tic>3)and(Prm=8)and not(en(9))and not(en(7))then
\r
271 begin RS(6);Add(9)end else
\r
272 if(Tic>5)and(Prm=8)and(en(9))and not(en(16))and not(en(7))then
\r
273 begin RS(7);Add(16)end;
\r
275 1:if(random(2)=0)and(T[9]>12)and(T[9]<15)and(Region=4)and not en(129)then
\r
276 begin RL(593);RL(594);Add(129)end
\r
277 else if(random(20)=0)and(Region=4)then RL(592);
\r
278 7:if random(5)=0 then RL(595);
\r
279 8:if random(3)=1 then RL(24)else if random(3)=1 then RL(178);
\r
280 15,17,19:case random(60) of
\r
283 3,4:if RC>40 then begin if T[4]>10 then T[4]:=10;RL(598)end;
\r
285 20:if random(4)=1 then RL(25);
\r
287 if Prm=SinkRm then begin RL(85);L[Prm]:=L[Prm]+[79];end;
\r
290 overlay procedure Time2B;
\r
291 begin col(10,7); { Jungle Planet }
\r
293 if Prm in[42..49]then
\r
294 begin writeln('Some of the walls shift positions.');Walls(4);end;
\r
296 7:if random(5)=0 then RL(595);
\r
297 26..29,32..34,59,60:case random(40) of
\r
298 0,1:RL(210); 2,3:RL(211); 4:RS(77); 5,6:RS(78); 7,8:RL(212);
\r
299 9:RL(213); 10:RL(214); 11:begin RL(215);play(6000,6001,20)end
\r
301 42..50:if random(7)=0 then RL(280);
\r
303 if(Prm=28)and(random(2)=0)then RL(233);
\r
304 if Prm=SinkRm then begin RL(85);L[Prm]:=L[Prm]+[79];end;
\r
305 if T[11]=2 then RL(205);
\r
306 if T[11]=1 then begin RS(70);DEAD;end;
\r
307 if T[13]=1 then begin RB(11,10);for x:=1 to 3 do begin tune(4,2,200);
\r
308 delay(99);tune(4,5,200);delay(99)end;Pause end;
\r
309 if(T[14]=2)and(Prm in[40,41])then RL(251);
\r
311 case Prm of 40:begin RL(249);Walls(8);end;41:begin RL(250);Walls(8);end end;
\r
312 if(T[15]=1)and(Prm=39)then begin RS(94);DEAD;end;
\r
313 if T[17]=4 then begin RS(109);DEAD;end;
\r
314 if T[17]=1 then begin Add(36);if Prm=56 then begin RS(110);Walls(8);end end;
\r
315 if T[18]=2 then begin RS(123);Walls(12)end;
\r
316 if(T[18]=1)and(Prm=53)then begin RS(124);Walls(12);DEAD;end;
\r
317 if T[19]=1 then begin RS(128);Walls(12);DEAD;end;
\r
320 overlay procedure Time2C;
\r
321 begin col(11,7); { Inner Planet }
\r
323 case Prm of 73:DClose(20);66:begin RL(337);play(105,50,20)end end;
\r
325 if(Prm=74)and not(en(47))then
\r
326 writeln('There is something flashing on the computer''s screen.');
\r
327 if(Prm=73)and(CodeSet<>4)then begin
\r
328 writeln('There''s an alarm sound coming over the radio.');
\r
331 for i:=450 to 999 do sound(i);
\r
332 for i:=999 downto 450 do sound(i);
\r
336 1..3:if here(38)then RL(588);
\r
337 4,5:begin RL(589);Explode(3)end;
\r
338 6:begin RS(244);for x:=1 to 7 do Static;end
\r
339 else if(Prm in[64,73])and(random(9)=0)then begin RL(590);RL(591)end
\r
343 overlay procedure Time2D; { Planetship }
\r
344 function Warn(Message,IfTime,Said:integer):boolean;
\r
346 if not en(Said)and(IfTime>=T[26])then
\r
347 begin if Said<>59 then begin Static;RS(Message);Static end
\r
348 else if Prm>99 then begin Static;RS(Message);Static end;
\r
349 if(Said=59)and(Prm<100)then begin end
\r
350 else begin Warn:=True;Add(Said)end
\r
354 for x:=0 to 2 do if T[23+x]>2 then Score(20,118+x); { 60 total points }
\r
355 if en(64)then Score(10,121);
\r
357 case Prm of 91:DClose(20);86:begin RL(337);play(110,50,15)end end;
\r
359 if(Prm=95)and not(en(48))then begin
\r
360 writeln('A loud siren is sounding off...');
\r
361 play(300,530,6);delay(200);play(300,530,6)end;
\r
362 if(Prm=91)and not en(53)then begin writeln('An alarm is ringing...');
\r
363 for x:=1 to 23 do begin sound(400);delay(99);sound(940);delay(60);nosound;
\r
366 begin write('The door slides open...');play(50,60,65);
\r
367 writeln('then closes.');play(60,50,60);
\r
368 if en(50)then RS(153)else
\r
369 if Inv=[] then begin RS(247);RS(248)end
\r
370 else begin RS(154);RS(155);Inv:=[];end;
\r
371 delay(2500);write('The door slides open...');play(50,60,65);
\r
372 writeln('then closes.');play(60,50,65);
\r
375 13:begin if Prm=91 then RL(438);MC(2,91,91,161);Add(53)end;
\r
376 12:MC(2,91,91,162);
\r
377 11:begin if Prm in[86,91]then DOpen(15);MC(2,91,86,163);MC(2,86,86,164);
\r
378 if Prm in[86,91]then DClose(15)end;
\r
379 10:begin MC(2,86,87,165);MC(2,87,87,166)end;
\r
380 9:begin if Prm in[87,89]then DOpen(65);MC(2,87,89,167);MC(2,89,89,168);
\r
381 if Prm in[87,89]then DClose(65)end;
\r
382 7,8:if Prm=89 then begin ScrnSet:=4;RL(417)end;
\r
383 6:begin if Prm in[87,89]then DOpen(65);MC(2,89,87,169);MC(2,87,87,170);
\r
384 if Prm in[87,89]then DClose(65)end;
\r
385 5:begin MC(2,87,86,171);MC(2,86,86,172)end;
\r
386 4:if T[21]<2 then begin MC(2,86,91,173);if Prm in[86,91]then DOpen(15);
\r
387 if Prm=86 then RL(418);MC(2,91,91,174);if Prm in[86,91]then DClose(15)end
\r
388 else if Prm=86 then begin RL(418);MC(2,0,91,0)end;
\r
389 1:if Prm=91 then begin RL(419);Van(123);DClose(55)end else Van(123)
\r
391 if(T[23]>1)and(T[23]<4)and(Prm=91)then begin T[24]:=7;T[23]:=NULL;end;
\r
393 7:if Prm=91 then RS(175);
\r
394 6:if Prm=91 then begin RS(176);RS(177)end;
\r
395 5:if Prm=91 then begin RS(178);RS(179)end;
\r
396 4:begin if Prm=91 then RL(420);if not(1 in Inv)then T[24]:=2;end;
\r
397 2,3:if(Prm=91)and(1 in Inv)then RL(419+T[24]);
\r
398 1:begin Van(123);if Prm=91 then begin RS(180);DOpen(55);RL(418);
\r
403 2..5:if Prm=91 then RS(188-T[25]);
\r
404 1:begin if Prm=91 then RS(187);T[24]:=2;T[26]:=40;Add(64)end;
\r
407 if not Warn(198,38,54)then
\r
408 if not Warn(199,33,55)then
\r
409 if not Warn(203,30,59)then
\r
410 if not Warn(200,25,57)then
\r
411 if not Warn(201,20,58)then
\r
412 if not Warn(202,15,56)then
\r
413 if not Warn(204,10,60)then
\r
414 if not Warn(205,6,61)then
\r
415 if not Warn(206,3,62)then
\r
416 if not Warn(207,2,63)then begin end;
\r
417 if T[26]=1 then begin RS(197);DEAD;end;
\r
418 if(T[27]=1998)and(Prm=99)then begin RS(213);Blast;DEAD;end;
\r
419 if(T[28]=1998)and(Prm=101)then begin RS(213);Blast;DEAD;end;
\r
422 overlay procedure Directory;
\r
424 Char12arr = array [ 1..12 ] of Char;
\r
425 String20 = string[ 20 ];
\r
428 DTA : array [ 1..43 ] of Byte;
\r
431 Error, I : Integer;
\r
432 SM1Found : boolean;
\r
436 FillChar(DTA,SizeOf(DTA),0);
\r
437 FillChar(Mask,SizeOf(Mask),0);
\r
438 FillChar(NamR,SizeOf(NamR),0);
\r
441 Regs.DS := Seg(DTA);
\r
442 Regs.DX := Ofs(DTA);
\r
445 Mask := '????????.???';
\r
447 Regs.DS := Seg(Mask);
\r
448 Regs.DX := Ofs(Mask);
\r
451 Error := Regs.AX and $FF;
\r
455 NamR[I] := Chr(Mem[Seg(DTA):Ofs(DTA)+29+I]);
\r
457 until not (NamR[I-1] in [' '..'~']) or (I>20);
\r
458 NamR[0] := Chr(I-1);
\r
459 while Error=0 do begin
\r
464 Error := Regs.AX and $FF;
\r
467 NamR[I] := Chr(Mem[Seg(DTA):Ofs(DTA)+29+I]);
\r
469 until not (NamR[I-1] in [' '..'~'] ) or (I > 20);
\r
470 NamR[0] := Chr(I-1);
\r
471 delete(NamR,length(NamR),2);
\r
472 if (Error = 0) then
\r
473 if length(NamR)>4 then
\r
474 if copy(NamR,length(NamR)-2,3)='SM1' then
\r
476 if not SM1Found then
\r
477 writeln('Here is a list of the SAVE/RESTORE files on the ',
\r
478 'disk in drive ',up(Drive),':');
\r
480 writeln(' * ',copy(NamR,1,length(NamR)-4));
\r
483 if not SM1Found then
\r
485 writeln('There are not any SAVE/RESTORE files on the disk in drive ',
\r
486 up(Drive),':');writeln;
\r
488 Pause;ChDir(Log+':');
\r
491 function Up;{Word:Str130):Str1}
\r
492 begin word:=word+' ';
\r
493 if(Word[1]='l')and(Word[2]=' ')then insert('ook',Word,2);
\r
494 if(Word[1]='e')and(Word[2]='x')and(Word[3]=' ')then insert('amine',Word,3);
\r
495 delete(Word,length(word),2);Up:='';
\r
496 for x:=1 to length(Word) do Word[x]:=upcase(Word[x]);
\r
497 col(12,15); write(Word); col(11,7)
\r
500 procedure Spaces(var I:Str130);
\r
501 begin I:=concat(' ',I,' ')end;
\r
503 procedure QFormat(var I:Str130);
\r
505 if(I[1]='.')or(I[1]=' ')then delete(I,1,1);
\r
506 if(I[length(I)]='.')or(I[length(I)]=' ')then delete(I,length(I),1);
\r
509 procedure PreFormat(var I:Str130);
\r
510 procedure D(A:Str29;B:byte);
\r
511 begin while pos(A,I)<>0 do delete(I,pos(A,I),B)end;
\r
512 begin D(' ',1);QFormat(I);
\r
513 FFlag:=0; if(length(I)>0)then FFlag:=1;
\r
515 Crawl:=false;if pos(' crawl ',I)>0 then Crawl:=true;D(' crawl ',6);
\r
516 D(' walk ',5);D(' run ',4);D(' go ',3);D(' travel ',7);
\r
517 QFormat(I); if(length(I)=0)and(FFlag=1)then FFlag:=2; Spaces(I);
\r
518 D(' of ',3);D(' the ',4);D(' very ',5);D(' more ',5);D(' and ',4);
\r
519 D(' large ',6);D(' big ',4);D(' huge ',5);D(' please ',7);
\r
520 D(' small ',6);D(' little ',7);D(' tiny ',5);
\r
521 D('''',1);D('#',1);D('!',1);D('?',1);D(' number ',7);
\r
522 QFormat(I); if(length(I)=0)and(FFlag=1)then FFlag:=3; Spaces(I);
\r
523 while pos('examine ',I)>0 do delete(I,pos('examine ',I)+2,5);
\r
524 while pos(' into ',I)>0 do delete(I,pos(' into ',I)+3,2);
\r
525 while pos(' onto ',I)>0 do delete(I,pos(' onto ',I)+3,2);
\r
526 while pos(' inside ',I)>0 do delete(I,pos(' inside ',I)+3,4);
\r
527 while pos(' within ',I)>0 do delete(I,pos(' within ',I)+1,4);
\r
528 while pos('look ',I)>0 do delete(I,pos('look ',I)+1,3);
\r
529 while pos('. ',I)>0 do delete(I,pos('. ',I)+1,1);
\r
530 while pos(',',I)>0 do
\r
531 begin insert(' ',I,pos(',',I));delete(I,pos(',',I),1)end;
\r
532 D('..',1);D(' .',1);D(' ',1);
\r
534 if(length(I)=0)then
\r
539 else writeln('Pardon me?')
\r
544 procedure LowerCase(var I:Str130);
\r
546 if(length(I)>0)then
\r
547 for x:=1 to length(I) do
\r
548 if(I[x] in['A'..'Z'])then
\r
549 I[x]:=chr(ord(I[x])+32);
\r
552 procedure ChopSeven(var I:Str130);
\r
555 if(length(I)>0)then
\r
560 while(I[x]<>' ')and(I[x]<>'.')and(I[x]<>',')do
\r
561 begin Word:=Word+I[x]; x:=x+1 end;
\r
562 if(length(Word)>7)then
\r
564 y:=pos(Word,I); x:=x+(7-length(Word));
\r
565 delete(I,y,length(Word)); delete(Word,8,130);
\r
569 until(x-1)=length(I);
\r
570 delete(I,length(I),1)
\r
574 procedure FindMood(var input:Str130;var Word:Str29;var Md:byte);
\r
579 Spaces(input);x:=0;
\r
584 while pos(Counter,Temp1)>0 do
\r
586 Temp2:=copy(Temp1,1,pos(Counter,Temp1)-1);
\r
587 if(pos(' '+Temp2+' ',input)>0)then
\r
590 Md:=x;if Md=2 then Md:=1;
\r
591 x:=AMax;Counter:='8';
\r
592 delete(input,pos(Temp2,input),length(Temp2)+1);
\r
594 delete(Temp1,1,pos(Counter,Temp1));
\r
595 Counter:=succ(Counter);
\r
601 function FN;{(VNP:byte) : Str29; ( Finds first Noun ) }
\r
605 FN:=copy(Temp,1,pos('\',Temp)-1);
\r
608 function Here;{Obj:byte) : Boolean;}
\r
610 if Obj in L[Prm] then Here:=true;
\r
611 if(Obj=79)and(MugCon=79)and(29 in Inv)then Here:=true;
\r
612 if Obj<=MMax then if(R[Obj]=Prm)or(Obj in Inv)then Here:=true;
\r
613 if(Obj=58)and((3 in Inv)or(4 in Inv)or(R[4]=Prm)or(R[3]=Prm))then Here:=true;
\r
616 function Present : Boolean;
\r
618 begin Present:=false; x:=0;
\r
619 if not(Vb in [17,18,37,39]) then
\r
623 if Here(N2) then Present:=true
\r
624 else writeln('You can''t see any ',FN(N2),' here.')
\r
626 else writeln('You can''t see any ',FN(N1),' here.')
\r
629 begin JUMP: x:=x+1;
\r
631 if x in NounSet then
\r
632 if Here(x) then goto JUMP
\r
633 else begin writeln('You can''t see any ',FN(x),' here.');end
\r
639 procedure Convert(var n:byte;Max:byte);
\r
642 1:case n of { Verbs }
\r
643 12:n:=11; 14:n:=13; 23:n:=22; 27:n:=26;
\r
644 29:n:=28; 34:n:=33; 36:n:=35; 38:n:=37; 40:n:=39; 43:n:=42; 45:n:=44;
\r
645 52:n:=51; 55:n:=54; 57,58:n:=56; 60,61:n:=59; 63:n:=62;
\r
647 2:case n of { Nouns }
\r
648 13..15:n:=12; 21:n:=20; 33:n:=32; 36:n:=35; 39:n:=38; 45:n:=44;
\r
649 50:n:=49; 53:n:=52; 65:n:=64; 67:n:=66; 70:n:=69; 76,77:n:=75;
\r
650 97:n:=96; 101,102:n:=100; 114:n:=113; 117:n:=116; 63:n:=62;
\r
651 27:n:=26; 57:n:=56; 61:n:=60; 91:n:=90; 105..108:n:=109; 31:n:=28;
\r
652 133:n:=46; 84:if Prm>21 then n:=128; 115:if Prm=28 then n:=112;
\r
653 58:if Prm=52 then n:=64;
\r
655 3:case n of { Prepositions }
\r
656 2:n:=1; 4:n:=3; 8:n:=7 ;
\r
661 procedure FindWord( var I : Str130; { input string }
\r
662 var VNP : byte; { flags which # word found }
\r
663 var Word : Str29; { stores last word found }
\r
664 Max : byte); { check which list? }
\r
669 QFormat(I); Spaces(I); J:=0;
\r
670 while (j<m[Max]) do
\r
673 case Max of 1:Temp1:=v[j]; 2:Temp1:=n[j]; 3:Temp1:=p[j] end;
\r
674 ps:=pos(Slash,Temp1);
\r
677 Temp2:=copy(Temp1,1,ps-1);
\r
678 if(copy(I,1,length(Temp2)+2)=' '+Temp2+' ')then
\r
679 begin { Match Found }
\r
683 delete(I,1,length(Temp2)+1);
\r
684 case Max of 1:VStr:=Word; 2:NStr:=Word end;
\r
688 delete(Temp1,1,ps);
\r
689 ps:=pos(Slash,Temp1);
\r
695 procedure Dictionary(IfFound,SkipList:byte);
\r
696 var StopLoopFlag:byte;
\r
697 begin VNP:=Null; list:=1; StopLoopFlag:=1;
\r
698 while(list<4)and(StopLoopFlag=1)do
\r
700 if list=SkipList then list:=list+1
\r
703 FindWord(input,VNP,Word,list);
\r
705 begin EFlag:=IfFound;list:=list-1;StopLoopFlag:=0;end;
\r
709 if(EFlag<>IfFound)then
\r
711 EFlag:=5;input:=input+' ';
\r
712 Word:=copy(input,1,pos(' ',input)-1);
\r
713 if(pos(' '+Word+' ',' top directi next some from is under underne '+
\r
714 'leaning but speak pay ')>0)then
\r
716 else If Word[1] in['0','1','2','3','4','5','6','7','8','9'] then EFlag:=17;
\r
717 if IfFound=14 then EFlag:=14;
\r
720 end; { Dictionary }
\r
724 if(pointer<>StoreL)then
\r
725 begin StoreL:=pointer;
\r
734 if(pointer<>StoreS)then
\r
735 begin StoreS:=pointer;
\r
740 end; { Read Special }
\r
744 if(pointer<>StoreR)then
\r
745 begin StoreR:=pointer;
\r
751 writeln(Text1,Text2);
\r
756 Tstart,TStop:Str19;
\r
757 begin SF; Col(Colour,7);
\r
758 str(Pointer-1,TStart);
\r
759 str(Pointer,TStop);
\r
760 TStart:='('+TStart+')';
\r
761 TStop:='('+TStop+')';
\r
762 if old>=Pointer then reset(T1);
\r
764 repeat readln(T1,Block) until Block=TStart;
\r
767 if(Block<>TStop)then writeln(Block)
\r
768 until Block=TStop; col(11,7);
\r
773 Tstart,TStop:Str19;
\r
774 begin SF; Col(Colour,7);
\r
775 str(Pointer-1,TStart);
\r
776 str(Pointer,TStop);
\r
777 TStart:='('+TStart+')';
\r
778 TStop:='('+TStop+')';
\r
779 if old2>=Pointer then reset(T2);
\r
781 repeat readln(T2,Block) until Block=TStart;
\r
784 if(Block<>TStop)then writeln(Block)
\r
785 until Block=TStop; col(11,7);
\r
788 overlay procedure Won;
\r
789 const W=800;H=400;Q=200;T=131;
\r
792 gotoxy(1,20);for x:=1 to 5 do
\r
793 begin writeln;delay(99);sound(x*50);Bor(x,7)end;
\r
794 gotoxy(1,15);col(4,15);bak(1,7);
\r
795 writeln('#######################################',
\r
796 '#######################################');
\r
797 delay(99);sound(300);Bor(6,0);
\r
798 gotoxy(1,16);for x:=1 to 3 do begin
\r
801 delay(99);sound(300+(x*50));Bor(x+8,15)end;gotoxy(1,19);
\r
802 write('#######################################',
\r
803 '#######################################');
\r
804 delay(99);sound(500);Bor(14,0);
\r
805 gotoxy(26,17);col(31,31);
\r
806 write('Y O U H A V E W O N ! !');delay(99);sound(550);
\r
807 gotoxy(1,20);bak(0,0);Bor(2,7);writeln;delay(99);nosound;
\r
808 for x:=1 to 12 do begin writeln;delay(80)end;
\r
809 gotoxy(1,9);Col(9,9);
\r
810 writeln(' S U P E R N O V A');writeln;Col(11,7);
\r
811 writeln(' Programmed by . . . . . . . . . . . . . . . . . . . . . Scott Miller');
\r
812 writeln(' Story by . . . . . . . . . . . . . . . . . . . . . . . Scott Miller');
\r
813 writeln(' Additional story development. . . . . . . . . . . . . . . Terry Nagy');
\r
815 Vb:=78;Call13;writeln;writeln;Col(3,7);
\r
816 write('Press any hey to quit...');
\r
817 tune(2,8,q);tune(2,8,q);tune(3,1,w);
\r
819 tune(2,8,q);tune(2,8,q);
\r
820 tune(3,1,h);tune(2,12,h);tune(2,10,h);tune(2,8,q);tune(2,8,q);
\r
821 tune(3,1,w);tune(2,8,t);tune(2,8,t);tune(2,8,t);
\r
822 if keypressed then goto JUMP;
\r
823 tune(3,1,h);tune(2,12,h);tune(2,10,h);tune(2,8,t);tune(2,8,t);tune(2,8,t);
\r
825 if keypressed then goto JUMP;
\r
826 tune(2,10,q);tune(2,10,q);
\r
827 tune(3,3,h);tune(3,1,h);tune(2,12,h);tune(2,10,q);tune(2,10,q);
\r
828 if keypressed then goto JUMP;
\r
829 tune(3,3,w);tune(2,10,t);tune(2,10,t);tune(2,10,t);
\r
830 tune(3,3,h);tune(3,1,h);tune(2,12,h);tune(2,10,t);tune(2,10,t);tune(2,10,t);
\r
833 JUMP: read(kbd,CFlag);
\r
834 window(1,1,80,25);clrscr;gotoxy(2,2);Col(31,31);Bor(0,0);Cur(1);Bak(2,0);
\r
835 writeln('Congratulations!');
\r
839 overlay procedure PlayerInput(var LINE:Str130);
\r
841 procedure Key(k:Str19); begin Line:=Line+k;QFlag:=true;write(k)end;
\r
843 with Result do begin
\r
844 WRITELN; { Main Space In Game }
\r
845 if(length(Line)=0)then
\r
847 bak(4,7);col(14,0);
\r
849 gotoxy(8,2);write(Tic,' ');
\r
850 gotoxy(35-(length(RN[Prm])div 2),2);
\r
851 write(' ',RN[Prm],' ');
\r
852 gotoxy(75,2);write(' ');gotoxy(75,2);write(Sc,' ');
\r
854 col(1,0);gotoxy(22,3);
\r
855 if PStat=[] then write('Healthy') else write(' * ');
\r
856 col(15,0);gotoxy(33,3);
\r
857 if 2 in PStat then begin col(31,16);write('Hungry')end
\r
859 col(4,0);gotoxy(43,3);
\r
860 if 3 in PStat then begin col(20,16);write('Sick')end
\r
862 col(0,0);gotoxy(51,3);
\r
863 if 4 in PStat then begin col(16,16);write('Injured')end
\r
865 col(6,0);gotoxy(62,3);
\r
866 if 5 in PStat then begin col(22,16);write('Tired')end
\r
868 col(5,0);gotoxy(71,3);
\r
869 if 6 in PStat then begin col(21,16);write('Thirsty')end
\r
871 bak(0,0);window(2,5,79,24);
\r
872 if en(66)then begin gotoxy(1,20);goto JUMP;end;
\r
873 gotoxy(1,20);col(28,31);writeln(chr(175));
\r
875 col(14,7);gotoxy(3,19);
\r
880 sound(99);nosound;case Region of 4:sound(20);5:sound(60)end;
\r
881 case chr(Lo(ax)) of
\r
883 if(wherex=1)and(wherey=20)then
\r
884 begin window(1,1,80,25);gotoxy(80,23)end;
\r
885 if length(Line)>0 then write(^h,' ',^h);
\r
886 delete(Line,length(Line),2);
\r
892 if(Lo(ax)>0)and(length(Line)<110)then
\r
893 begin write(chr(Lo(ax)));Line:=Line+chr(Lo(ax));end
\r
897 59:key('Save'); 71:key('Northwest');
\r
898 60:key('Restore'); 73:key('Northeast');
\r
899 61:key('R D'); 79:key('Southwest');
\r
900 62:key('Look'); 81:key('Southeast');
\r
901 63:key('Get all'); 82:key('Down');
\r
902 64:key('Drop all'); 83:key('Up');
\r
903 65:key('Score'); 104:begin QFlag:=true;RR(0)end;
\r
904 66:key('Inventory');
\r
906 68:begin Line:='';key('Repeat')end;
\r
907 94,30:key('by Scott Miller');
\r
908 95,47:key('Version A Dec 9, 85');
\r
910 if Prm in[1..7] then
\r
912 72:key('Fore'); 75:key('Port'); 77:key('Starboard'); 80:key('Aft')
\r
916 72:key('North'); 75:key('West'); 77:key('East'); 80:key('South')
\r
923 gotoxy(1,19);col(5,7);write(chr(175));col(11,7);gotoxy(1,20);
\r
924 if length(Line)>76 then writeln;
\r
925 LowerCase(Line);Spaces(Line);
\r
926 if(pos(' r ',Line)>0)or(pos(' repeat ',Line)>0)then PreFormat(Line);
\r
927 if(Line='r')or(Line='repeat')then Line:=Again else Again:=Line;
\r
929 while pos(' then ',Line)>0 do
\r
931 x:=pos(' then ',Line);delete(Line,x,5);insert('.',Line,x)
\r
936 if(pos('.',Line)>0)then
\r
937 begin { SEPERATES LINE INTO SINGLE INPUTS }
\r
938 input:=copy(Line,1,pos('.',Line));
\r
939 delete(Line,1,pos('.',Line));
\r
940 delete(input,pos('.',input),1);
\r
945 input:=Line; Line:='';
\r
946 end; { END OF LINE SEPERATION }
\r
948 while pos(' it ',input)>0 do
\r
949 begin x:=pos(' it ',input)+1;delete(input,x,2);insert(LastNoun,input,x);
\r
950 PreFormat(input);ChopSeven(input);
\r
952 while pos(' them ',input)>0 do
\r
953 begin x:=pos(' them ',input)+1;delete(input,x,4);insert(LastNoun,input,x);
\r
954 PreFormat(input);ChopSeven(input);
\r
959 end; { of with statement }
\r
960 end; { PlayerInput }
\r
962 overlay procedure Title;
\r
964 clrscr;textcolor(7);Color:=true;
\r
965 if ParamCount=0 then begin
\r
966 write('Do you want ');textcolor(15);write('C');textcolor(7);
\r
967 write('olor or ');textcolor(15);write('B');textcolor(7);
\r
968 write('lack and white? ');textcolor(15);read(kbd,CFlag);
\r
969 if(upcase(CFlag)='B')or(upcase(CFlag)='M')then
\r
970 begin Color:=false;write('Monochrome')end
\r
971 else write('Color');delay(300);
\r
974 begin input:=ParamStr(1);CFlag:=input[1];
\r
975 if(CFlag='/')and(length(input)>1)then CFlag:=input[2];
\r
976 if(upcase(CFlag)='B')or(upcase(CFlag)='M')then
\r
977 begin Color:=false;writeln('Monochrome screen option...')end
\r
978 else writeln('Color screen option...');delay(999)
\r
980 clrscr;textmode(BW80);
\r
983 {**** Public Domain title screen ****}
\r
984 Col(9,9);gotoxy(1,1);
\r
985 cn('S U P E R N O V A');
\r
986 Col(9,7);gotoxy(1,3);
\r
987 cn('Published by');
\r
989 cn('APOGEE SOFTWARE PRODUCTIONS');
\r
992 cn('This game is placed in the public domain for your enjoyment. Please do');
\r
993 cn('not abuse this product or the author''s rights.');
\r
995 cn('If you enjoy this game the author asks that you contribute $10 (by check).');
\r
996 cn('This payment will encourage the author to create similar games and will');
\r
997 cn('help compensate him for the several years work that went into Supernova.');
\r
998 cn('This fee will also register the payer for telephone support and clues.');
\r
1001 writeln('Please make checks payable to: Scott Miller');
\r
1003 writeln('Scott Miller (214) 240-0614');
\r
1004 writeln('4206 Mayflower Drive');
\r
1005 writeln('Garland, TX 75043');
\r
1007 writeln('Also call for help: Terry Nagy (214) 271-3065');
\r
1009 Col(11,7);delay(7000);
\r
1010 cn('Thanks, enjoy the game...');
\r
1012 Col(7,7);gotoxy(27,25);delay(999);
\r
1013 write('Press any key to continue.');repeat;begin;end;until keypressed;
\r
1014 read(kbd,CFlag);bak(1,0);clrscr;
\r
1015 {**** Main SUPERNOVA title screen ****}
\r
1017 Bor(1,0);Col(15,15);Bak(4,0);
\r
1019 begin gotoxy(x,1);write(chr(205));gotoxy(x,24);write(chr(205))end;
\r
1021 begin gotoxy(1,y);write(chr(186));gotoxy(80,y);write(chr(186))end;
\r
1022 gotoxy(1,1);write(chr(201)); gotoxy(80,1);write(chr(187));
\r
1023 gotoxy(1,24);write(chr(200)); gotoxy(80,24);write(chr(188));
\r
1025 Col(2,7);gotoxy(1,10);cn('Copyright 1987 Scott Miller');
\r
1026 Col(14,7);gotoxy(1,12);cn('Version B');
\r
1027 Col(7,7);gotoxy(1,15);
\r
1028 cn('Programmed by Scott Miller');
\r
1029 cn('Story by Scott Miller and Terry Nagy');
\r
1030 gotoxy(1,23);Col(3,7);
\r
1031 cn('Press any key to continue.');
\r
1034 if Color then textcolor(random(16))
\r
1035 else case random(3) of 0:textcolor(0); 1:textcolor(7); 2:textcolor(15)end;
\r
1036 write('S U P E R N O V A');
\r
1039 if Color then textmode(C80)else textmode(BW80);
\r
1042 overlay procedure Init1;
\r
1045 Bor(0,0);bak(0,0);clrscr;nosound;
\r
1047 GetDir(0,Word);Log:=Word[1];
\r
1048 for x:=1 to 20 do begin sound(x*9);delay(x*2)end;nosound;
\r
1049 gotoxy(1,9);y:=0;col(14,7);Identity:='';
\r
1050 Cn('Please enter your identity code name:');col(12,15);
\r
1051 repeat i:=random(maxint) until keypressed;
\r
1052 repeat read(kbd,CFlag);
\r
1053 if(CFlag<>chr(13))then
\r
1054 if(CFlag<>^h)then Identity:=Identity+upcase(CFlag)
\r
1055 else delete(Identity,length(Identity),2);
\r
1056 gotoxy(1,11);Cn(' '+Identity+' ');sound(50);delay(50);nosound;
\r
1057 until CFlag=chr(13);
\r
1058 col(10,7);gotoxy(1,7);
\r
1059 if identity<>'' then
\r
1060 Cn(' IDENTITY CODE ACCEPTED--YOU MAY PROCEED '+Identity)
\r
1062 col(25,31);Bor(4,7);Cn('IDENTITY CODE REJECTED--ABORTING SEQUENCE')end;
\r
1063 LowerCase(Identity);ChopSeven(Identity);
\r
1065 if Identity='' then goto ABORT;
\r
1069 assign(R1,'R1');assign(R2,'R2');
\r
1070 assign(T1,'SM');assign(T2,'B1');
\r
1071 reset(R1);reset(R2);
\r
1072 reset(S1);reset(L1);reset(C1);
\r
1075 overlay procedure Init2;
\r
1077 col(7,15);bak(1,7);
\r
1079 begin gotoxy(x,1);write(chr(205));gotoxy(x,24);write(chr(205))end;
\r
1080 gotoxy(80,24);write(chr(190));gotoxy(1,24);write(chr(212));
\r
1081 gotoxy(1,4);InsLine;
\r
1083 begin gotoxy(1,x);write(chr(179));gotoxy(80,x);write(chr(179))end;
\r
1084 gotoxy(1,4);write(chr(198));for x:=2 to 79 do
\r
1085 begin gotoxy(x,4);write(chr(205))end;write(chr(181));
\r
1086 gotoxy(1,1);write(chr(213));gotoxy(80,1);write(chr(184));
\r
1087 bak(4,7);col(14,0);gotoxy(2,2);
\r
1088 for x:=1 to 78 do write(' ');
\r
1089 gotoxy(2,2);write('Move');
\r
1090 gotoxy(68,2);write('Score');
\r
1091 bak(7,7);gotoxy(2,3);
\r
1092 for x:=1 to 78 do write(' ');
\r
1093 bak(5,7);col(15,0);
\r
1094 gotoxy(2,3);write('Player Condition:');
\r
1096 gotoxy(1,14);col(14,7);
\r
1097 cn('Working 14 hours a day in the core of some dusty, smelly mine');
\r
1098 cn('is not your idea of the perfect lifestyle.');
\r
1099 cn('Barre-An is a dust ball in space, its only salvation being that it is');
\r
1100 cn('rich in precious barre-an metal. Or used to be. Nowadays the mines');
\r
1101 cn('don''t seem so generous, which is why you''re looking for a more');
\r
1102 cn('profitable venture.');
\r
1103 cn('A break, that''s all you ask for, maybe today you figure...');
\r
1107 overlay procedure Init3;
\r
1118 for o :=1 to MMax do r[o]:=Null;
\r
1136 Socket :=[22..25];
\r
1146 StoreR:=-1;StoreS:=-1;StoreL:=-1;StoreC:=-1;{ Stores Last Read File Number }
\r
1147 Dir[1]:='NORTH';Dir[2]:='SOUTH';Dir[3]:='EAST';Dir[4]:='WEST';
\r
1148 Dir[5]:='NORTHEAST';Dir[6]:='NORTHWEST';
\r
1149 Dir[7]:='SOUTHEAST';Dir[8]:='SOUTHWEST';
\r
1150 m[1]:=VMax;m[2]:=NMax;m[3]:=PMax;
\r
1151 for x :=1 to TMax do T[x]:=Null;
\r
1153 T[3] :=70; { Hunger }
\r
1154 T[4] :=26; { Thirst }
\r
1155 T[5] :=85; { Sleep (No relation to the T[2] sleep timer!) }
\r
1156 NoNounOnly :=[1..8,15,16,30,77..79,82,85..87,95];
\r
1157 OneNounMaybe:=[9..14,25,32,46,59..60,66..71,80,81,90,91];
\r
1158 ToNounOnly :=[33,49,64,88,93];
\r
1159 ToNounMaybe :=[19,41..44,48,50,53,54,74..76,89,90,92,94];
\r
1160 { NOTE: All other verbs would be OneNounOnly! }
\r
1161 window(2,5,79,24);gotoxy(1,19);
\r
1164 overlay procedure Save;
\r
1165 label JUMPABORT,JUMPBACK;
\r
1166 var DiskTest:file;
\r
1167 begin SF; JUMPBACK: nosound; for x:=1 to 20 do writeln;
\r
1168 Bor(2,7);CFlag:=Drive;Cur(2);
\r
1170 write('Which disk drive (default ',Up(Drive),':)? ');
\r
1171 col(14,15);buflen:=1;readln(Drive);col(11,7);
\r
1172 Drive:=upcase(Drive);if not(Drive in['A','B'])then Drive:=CFlag;
\r
1174 writeln('Make sure your SAVE/RESTORE disk is in disk drive ',up(Drive),':');
\r
1176 write('SAVE under what file name (''',up('/'),''' aborts SAVE)? ');
\r
1177 buflen:=8;col(14,15);readln(input);col(11,7);
\r
1179 while pos(' ',input)>0 do delete(input,pos(' ',input),1);
\r
1180 while pos('.',input)>0 do delete(input,pos('.',input),1);
\r
1181 while pos(':',input)>0 do delete(input,pos(':',input),1);
\r
1182 if pos('/',input)>0 then
\r
1183 begin writeln;writeln(up('SAVE ABORTED'));goto JUMPABORT;end;
\r
1185 if(pos('list',input)>0)or(pos('dir',input)>0)or(pos('file',input)>0)then
\r
1186 begin Directory;goto JUMPBACK;end;
\r
1187 if length(input)=0 then input:='LASTSAVE';writeln;writeln;
\r
1188 writeln('The game file ',Up(Input),' is now being saved on disk drive ',
\r
1189 up(Drive),':...');
\r
1190 input:=Drive+':'+input;
\r
1191 assign(Objects,input+'.sm1');
\r
1193 for x:=0 to RMax do write(Objects,L[x]);
\r
1195 assign(Things,input+'.sm2');
\r
1197 write(Things,Prm,Region,MugCon,FoodCon,SatchCon,NicheCon,PyraCon,
\r
1198 HingeCon,PodumCon,AlienRm,FriendRm,SinkRm,Serum,TFlag,
\r
1199 RobotCon,CodeSet,ScrnSet,HolstCon);
\r
1200 for x:=1 to MMax do write(Things,R[x]);
\r
1202 assign(Timers,input+'.sm3');
\r
1204 write(Timers,Tic,Sc,RC,Floor);
\r
1205 for x:=1 to TMax do write(Timers,T[x]);
\r
1208 begin aInv:=Inv;aPStat:=PStat;aEvents:=Events;
\r
1209 aSocket:=Socket;aWear:=Wear;end;
\r
1210 assign(Sets,input+'.sm4');
\r
1212 write(Sets,SetSave);
\r
1214 writeln;writeln;delete(input,1,2);
\r
1215 writeln('Your present game location is now SAVED under the name ',
\r
1217 writeln; JUMPABORT: writeln;
\r
1218 writeln('Please make sure the SUPERNOVA disk is in drive ',up(Log),':');
\r
1219 writeln;writeln;Pause;
\r
1220 assign(DiskTest,'Nova.com');
\r
1224 if IOResult<>0 then
\r
1225 begin Col(15,15);close(DiskTest);write(^g);goto JUMPABORT;end;
\r
1226 close(DiskTest);Col(11,7);
\r
1227 Bor(0,0);Line:='l';
\r
1228 case Region of 4:sound(20);5:sound(60)end
\r
1231 overlay procedure Restore;
\r
1232 label JUMP,JUMPBACK;
\r
1233 var DiskTest:file;
\r
1234 begin SF; JUMPBACK: nosound; for x:=1 to 25 do writeln;
\r
1235 Bor(6,7);CFlag:=Drive;Cur(2);
\r
1237 write('Which disk drive (default ',Up(Drive),':)? ');
\r
1238 col(14,15);buflen:=1;readln(Drive);col(11,7);
\r
1239 Drive:=upcase(Drive);if not(Drive in['A','B'])then Drive:=CFlag;
\r
1241 writeln('Make sure your SAVE/RESTORE disk is in disk drive ',up(Drive),':');
\r
1243 write('RESTORE from what file name (''',up('/'),''' aborts RESTORE)? ');
\r
1244 buflen:=8;col(14,15);readln(input);col(11,7);
\r
1246 while pos(' ',input)>0 do delete(input,pos(' ',input),1);
\r
1247 while pos('.',input)>0 do delete(input,pos('.',input),1);
\r
1248 while pos(':',input)>0 do delete(input,pos(':',input),1);
\r
1249 if pos('/',input)>0 then
\r
1250 begin writeln;writeln(up('RESTORE ABORTED'));goto JUMP;end;
\r
1252 if(pos('list',input)>0)or(pos('dir',input)>0)or(pos('file',input)>0)then
\r
1253 begin Directory;goto JUMPBACK;end;
\r
1254 if length(input)=0 then input:='LASTSAVE';writeln;writeln;
\r
1255 writeln('The game file ',Up(Input),' is now being restored from drive ',
\r
1256 up(Drive),':...');
\r
1257 input:=Drive+':'+input;
\r
1258 assign(Objects,input+'.sm1');
\r
1262 if IOResult<>0 then
\r
1263 begin close(Objects);col(12,15);writeln;writeln;delete(input,1,2);
\r
1264 for x:=1 to length(input) do input[x]:=upcase(input[x]);
\r
1265 Cn('The file '+input+' does not exist on your SAVE/RESTORE disk!');
\r
1266 writeln(^g);delay(2000);col(11,7);goto JUMPBACK;
\r
1269 for x:=0 to RMax do read(Objects,L[x]);
\r
1271 assign(Things,input+'.sm2');
\r
1273 read(Things,Prm,Region,MugCon,FoodCon,SatchCon,NicheCon,PyraCon,
\r
1274 HingeCon,PodumCon,AlienRm,FriendRm,SinkRm,Serum,TFlag,
\r
1275 RobotCon,CodeSet,ScrnSet,HolstCon);
\r
1276 for x:=1 to MMax do read(Things,R[x]);
\r
1278 assign(Timers,input+'.sm3');
\r
1280 read(Timers,Tic,Sc,RC,Floor);
\r
1281 for x:=1 to TMax do read(Timers,T[x]);
\r
1283 assign(Sets,input+'.sm4');
\r
1285 read(Sets,SetSave);
\r
1288 begin Inv:=aInv;PStat:=aPStat;Events:=aEvents;
\r
1289 Socket:=aSocket;Wear:=aWear;end;
\r
1291 writeln;writeln;delete(input,1,2);
\r
1292 writeln('Your present game location is now RESTORED from the name ',
\r
1294 writeln; JUMP: writeln;
\r
1295 writeln('Please make sure the SUPERNOVA disk is in drive ',up(Log),':');
\r
1296 writeln;writeln;Pause;
\r
1297 assign(DiskTest,'Nova.com');
\r
1301 if IOResult<>0 then
\r
1302 begin Col(15,15);close(DiskTest);write(^g);goto JUMP;end;
\r
1303 close(DiskTest);Col(11,7);
\r
1305 case Region of 4:sound(20);5:sound(60)end;
\r
1308 n[84]:='reactor regulat\';
\r
1309 n[126]:='hinged mouth\mouth\hinge\';
\r
1313 n[84]:='middle table\middle\';
\r
1316 if en(34)then n[18]:='glass ball\ball\glass\'
\r
1317 else n[18]:='dusty ball\ball\dusty\';
\r
1320 n[40]:='sockets\socket\';
\r
1321 n[82]:='laser beam\beam\laser\';
\r
1322 n[110]:='speaker\';
\r
1325 n[40]:='cyan button\cyan\';
\r
1326 n[82]:='solar map\map\solar\drawing\';
\r
1327 n[110]:='keyhole\';
\r
1329 Min(128);Line:='l';
\r
1332 procedure MoreThanOne;
\r
1334 if((N1=58)or(58 in NounSet)or(N2=58))and Here(3) and Here(4) then
\r
1336 repeat write('Which one, the R)usty or S)hiney key? ');
\r
1337 read(kbd,CFlag);writeln(CFlag);writeln until upcase(CFlag) in ['R','S'];
\r
1338 case upcase(CFlag) of 'R':x:=3; 'S':x:=4 end;
\r
1339 if N1=58 then N1:=x;
\r
1340 if N2=58 then N2:=x;
\r
1341 if 58 in NounSet then begin NounSet:=NounSet-[58];NounSet:=NounSet+[x] end;
\r
1343 if((N1=86)or(86 in NounSet)or(N2=86))and(Prm=8)then
\r
1345 repeat write('Which one, the W)estern, M)iddle or E)astern table? ');
\r
1346 read(kbd,CFlag);writeln(CFlag);
\r
1347 writeln until upcase(CFlag) in ['W','M','E'];
\r
1348 case upcase(CFlag) of 'W':x:=83; 'M':x:=84; 'E':x:=85 end;
\r
1349 if N1=86 then N1:=x;
\r
1350 if N2=86 then N2:=x;
\r
1351 if 86 in NounSet then begin NounSet:=NounSet-[86];NounSet:=NounSet+[x] end;
\r
1353 if((N1=44)or(44 in NounSet)or(N2=44))and(Prm in[1,70])and(Vb<>28)then
\r
1355 repeat write('Which one, the T)an, P)urple or C)yan button? ');
\r
1356 read(kbd,CFlag);writeln(CFlag);
\r
1357 writeln until upcase(CFlag) in ['T','P','C'];
\r
1358 case upcase(CFlag) of 'T':x:=41; 'P':x:=43; 'C':x:=40 end;
\r
1359 if N1=44 then N1:=x;
\r
1360 if N2=44 then N2:=x;
\r
1361 if 44 in NounSet then begin NounSet:=NounSet-[44];NounSet:=NounSet+[x] end;
\r
1363 if(N1=58)and Here(3)and not(Here(4))then N1:=3;
\r
1364 if(N2=58)and Here(3)and not(Here(4))then N2:=3;
\r
1365 if(58 in NounSet)and Here(3)and not(Here(4))then
\r
1366 begin NounSet:=NounSet-[58];NounSet:=NounSet+[3] end;
\r
1367 if(N1=58)and Here(4)and not(Here(3))then N1:=4;
\r
1368 if(N2=58)and Here(4)and not(Here(3))then N2:=4;
\r
1369 if(58 in NounSet)and Here(4)and not(Here(3))then
\r
1370 begin NounSet:=NounSet-[58];NounSet:=NounSet+[4] end;
\r
1371 end; { MoreThanOne }
\r
1374 function Print(Word:Str29):Str1;
\r
1375 begin Print:='';writeln('--you can''t use the word ',Up(Word),' here.')end;
\r
1377 procedure Parser_Syntax(var Input:Str130);
\r
1378 label JUMP1, JUMP2;
\r
1380 Word:=''; Md:=Null; Num:=Null; Code:=Null;
\r
1381 Vb:=Null; N1:=Null; N2:=Null; NounSet:=[];
\r
1382 JUMP1: { Used if the player forgets the first noun. }
\r
1383 FFlag:=Null; Pr:=Null;
\r
1384 JUMP2: { Used if the player forgets the second noun or preposition. }
\r
1386 FindMood(input,Word,Md);
\r
1387 if(length(input)>0)then
\r
1389 FindMood(input,Word,Num);
\r
1392 FindWord(input,Vb,Word,1);
\r
1394 if(length(input)=0)then
\r
1396 if(Vb in NoNounOnly)or(Vb in OneNounMaybe)then EFlag:=Legal;
\r
1397 if EFlag<>Legal then
\r
1399 if(Vb=35)and here(35)then begin EFlag:=Legal;N1:=35;NStr:='seat';end;
\r
1400 if(Vb=47)and here(6)then begin EFlag:=Legal;N1:=6;end;
\r
1401 if(Vb=62)and here(80)then begin EFlag:=Legal;N1:=80;end;
\r
1402 if(Vb=65)and here(124)then begin EFlag:=Legal;N1:=124;end;
\r
1403 if EFlag<>Legal then EFlag:=4
\r
1407 if(Vb in NoNounOnly)then Dictionary(3,9)
\r
1409 if not(Vb in[17,18,37,39])then { get,drop and but branch-off }
\r
1410 if not(Vb in[25,32,56,66..69,71,80,81])then { characters and type }
\r
1412 if(Vb<>FFlag)then FindWord(input,N1,Word,2);
\r
1413 if(N1<>Null)then LastNoun:=FN(N1);
\r
1415 if(Word<>'all')then
\r
1416 if(length(input)=0)then
\r
1417 if(Vb in ToNounOnly)then
\r
1418 if(VStr='fill')and(Prm=SinkRm)and(N1=29)then
\r
1419 begin N2:=79;Pr:=6;EFlag:=Legal;end else
\r
1420 if(Vb=64)and(Prm=8)and(N1 in[29,99])and(not en(21))and
\r
1421 here(8)then begin Pr:=6;N2:=8;EFlag:=Legal;end else
\r
1422 if(Vb=88)and(Prm in[9..11])and(N1=56)and here(3)then
\r
1423 begin Pr:=6;N2:=3;EFlag:=Legal;end
\r
1427 if(Vb in ToNounMaybe)or(Vb in ToNounOnly)then
\r
1429 FindWord(input,Pr,Word,3);
\r
1431 if(length(input)=0)then
\r
1432 if(Vb=50)and(Pr in[1,9])then EFlag:=Legal
\r
1435 if(Vb<>50)then { branch for turning dials }
\r
1437 FindWord(input,N2,Word,2);
\r
1439 if(Word<>'all')then
\r
1440 if(length(input)=0)then EFlag:=Legal
\r
1441 else Dictionary(12,9)
\r
1443 else Dictionary(11,2)
\r
1447 val(input,Code,testc);
\r
1448 if(testc=0)then EFlag:=Legal
\r
1449 else begin delete(input,1,testc-1);Dictionary(14,9);end;
\r
1451 else Dictionary(9,3)
\r
1454 begin Dictionary(3,9);if(List=2)then EFlag:=8;end
\r
1456 else Dictionary(10,2)
\r
1458 else { Special case for TYPE, characters, etc. }
\r
1462 end { of Special case for SAY, TYPE, etc. }
\r
1463 else { Special case for GET and DROP }
\r
1464 while EFlag=Null do
\r
1466 FindWord(input,N1,Word,2);
\r
1467 if(N1<>Null)then LastNoun:=FN(N1);
\r
1469 if not(N1 in NounSet)then
\r
1471 NounSet:=NounSet+[N1];
\r
1472 if(length(input)=0)then EFlag:=Legal
\r
1475 else Dictionary(10,2)
\r
1476 end { of Special case for GET and DROP }
\r
1477 else Dictionary(7,1)
\r
1482 if EFlag<>Legal then
\r
1483 begin Line:='';play(199,199,55);delay(70);play(60,60,55)end;
\r
1486 2:writeln('The word ',up(Word),' is too many adverbs.');
\r
1487 3:write('Illegal input',Print(Word));
\r
1488 4:if(Vb=56)then RL(187)
\r
1491 write('Noun missing--');
\r
1493 35,62:writeln('what do you want to ',up(Word),' on?');
\r
1494 65:writeln('what do you want to ',up(Word),' to?')
\r
1495 else writeln('what do you want to ',up(Word),'?');
\r
1497 PlayerInput(line);
\r
1498 if(length(input)>0)then goto JUMP1;
\r
1500 5:if(length(Word)>1)then
\r
1501 writeln('The word ',up(Word),' is not used in this adventure.')
\r
1503 writeln('The letter ',up(Word),' is not used as shorthand in this parser.');
\r
1505 writeln('Noun missing--what do you want to ',up(VStr),up(' the '),
\r
1506 up(NStr),' ',up(PStr),'?');
\r
1507 PlayerInput(line); FFlag:=Vb;
\r
1508 if(length(input)>0)then goto JUMP2;
\r
1510 7:write('Verb missing',Print(Word));
\r
1512 9:write('Preposition expected',Print(Word));
\r
1513 10:write('Noun expected',Print(Word));
\r
1514 11:write('Indirect noun expected',Print(Word));
\r
1515 12:write('No more input expected',Print(Word));
\r
1516 13:writeln('Illegal noun used--',up(Word),' referenced more than once.');
\r
1517 14:write('Number expected',Print(Word));
\r
1519 write('Preposition and noun missing--');
\r
1520 if(Vb in[33,48])then
\r
1521 writeln('where do you want to ',up(VStr),' the ',up(NStr),'?') else
\r
1524 writeln('who do you want to ',up(VStr),' the ',up(NStr),' to?')end
\r
1526 writeln('what do you want to ',up(VStr),' the ',up(NStr),' with?')end;
\r
1527 PlayerInput(line); FFlag:=Vb;
\r
1528 if(length(input)>0)then goto JUMP2;
\r
1533 end; { Parser Syntax }
\r
1535 procedure MC;{WhichChar,WatchRoom,ToRoom:byte;MessageNum:Integer}
\r
1536 { WhichChar refers to the character(s) being moved. }
\r
1537 { WatchRoom is the room the player must be in to see the responce.}
\r
1538 { ToRoom is the room the character(s) move to. }
\r
1539 { MessageNum is the message that is written if the player sees. }
\r
1541 if(Prm=WatchRoom)then RS(MessageNum);
\r
1542 case WhichChar of { 1 = Aliens, 2 = Scientist }
\r
1544 L[AlienRm]:=L[AlienRm]-[124];AlienRm:=ToRoom;
\r
1545 L[AlienRm]:=L[AlienRm]+[124]
\r
1548 L[FriendRm]:=L[FriendRm]-[123];FriendRm:=ToRoom;
\r
1549 L[FriendRm]:=L[FriendRm]+[123]
\r
1559 L[Prm]:=L[Prm]-[o];
\r
1560 if o in Wear then Wear:=Wear-[o];
\r
1561 if o=SatchCon then SatchCon:=Null;
\r
1562 if o=MugCon then MugCon:=Null;
\r
1563 if o=16 then Min(6);
\r
1564 if o=NicheCon then NicheCon:=Null;
\r
1565 if o=PyraCon then PyraCon:=Null;
\r
1566 if o=HingeCon then HingeCon:=Null;
\r
1567 if o=PodumCon then PodumCon:=Null;
\r
1568 if o=16 then begin Min(37);Min(6)end;
\r
1569 if o=RobotCon then RobotCon:=Null;
\r
1570 if o in Socket then Socket:=Socket-[o];
\r
1571 if o=HolstCon then HolstCon:=Null
\r
1575 begin SF; RL(random(7)+127)end;
\r
1577 procedure NoSense;
\r
1578 begin RL(190) end;
\r
1580 procedure Say(What1,What2:Str29);
\r
1581 begin SF; writeln('The ',What1,' is already ',What2,'.') end;
\r
1583 {******************* END OF PARSER AND MISC. PROCEDURES *********************}
\r