1 {//-------------------------------------------------------------------------}
\r
3 {Copyright (C) 2014 Jason Self <j@jxself.org> }
\r
5 {This file is free software: you may copy, redistribute and/or modify it }
\r
6 {under the terms of the GNU Affero General Public License as published by }
\r
7 {the Free Software Foundation, either version 3 of the License, or (at your }
\r
8 {option) any later version. }
\r
10 {This file is distributed in the hope that it will be useful, but WITHOUT }
\r
11 {ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or }
\r
12 {FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License}
\r
13 {for more details. }
\r
15 {You should have received a copy of the GNU Affero General Public License }
\r
16 {along with this program; if not, see https://gnu.org/licenses or write to: }
\r
17 { Free Software Foundation, Inc. }
\r
18 { 51 Franklin Street, Fifth Floor }
\r
19 { Boston, MA 02110-1301 }
\r
22 {This file incorporates work covered by the following copyright and }
\r
23 {permission notice: }
\r
25 {Copyright (C) 1990, 2009 - Apogee Software, Ltd. }
\r
27 {This file is part of Supernova. Supernova is free software; you can }
\r
28 {redistribute it and/or modify it under the terms of the GNU General Public }
\r
29 {License as published by the Free Software Foundation; either version 3 }
\r
30 {of the License, or (at your option) any later version. }
\r
32 {This program is distributed in the hope that it will be useful, }
\r
33 {but WITHOUT ANY WARRANTY; without even the implied warranty of }
\r
34 {MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. }
\r
36 {See the GNU General Public License for more details. }
\r
38 {You should have received a copy of the GNU General Public License }
\r
39 {along with this program; if not, see https://gnu.org/licenses or write to: }
\r
40 { Free Software Foundation, Inc. }
\r
41 { 51 Franklin Street, Fifth Floor }
\r
42 { Boston, MA 02110-1301 }
\r
45 {Original Source: 1990 Scott Miller }
\r
46 {Prepared for public release: 03/19/09 - Joe Siegler, Apogee Software, Ltd. }
\r
48 {//-------------------------------------------------------------------------}
\r
49 (*****************************************************************************)
\r
51 (* >> Contains the Parser, Initialization, Time and Misc. Routines << *)
\r
52 (* Programmer: Scott Miller *)
\r
53 (* << Began February 2, 1985 >> *)
\r
54 (* Copyright 1985 Scott Miller *)
\r
55 (*****************************************************************************)
\r
57 procedure RL(Pointer:integer);forward;
\r
58 procedure RS(Pointer:integer);forward;
\r
59 procedure RR(Pointer:integer);forward;
\r
60 procedure RB(Pointer,Colour:byte);forward;
\r
61 procedure RB2(Pointer,Colour:byte);forward;
\r
62 procedure MC(WhichChar,WatchRoom,ToRoom:byte;MessageNum:Integer);forward;
\r
63 procedure Move(New:byte);forward;
\r
64 procedure DEAD;forward;
\r
65 procedure Call13;forward;
\r
66 procedure Van(o:byte);forward;
\r
67 function FN(VNP:byte):Str29;forward;
\r
68 function Here(Obj:byte):Boolean;forward;
\r
69 function Up(Word:Str130):Str1;forward;
\r
72 procedure init_windows;
\r
77 { Get ENV LANG and check for UTF-8 support}
\r
78 lang:=upcase(GetEnvironmentVariable('LANG'));
\r
79 UTF8Scr:= (Pos('.UTF-8', lang) > 0) or (Pos('.UTF8', lang) > 0);
\r
80 { Check min req col & rows}
\r
81 if nCols(stdscr) < 80 then begin
\r
82 writeln('You must have 80 character columns');
\r
85 if nRows(stdscr) < 25 then begin
\r
86 writeln('You must have 25 character rows');
\r
89 {writeln(nCols(stdscr),nRows(stdscr));}
\r
92 procedure WritePrompt(x,y:integer);
\r
96 { U+00BB, ยป, C2 BB, RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK.}
\r
97 nFWrite(x,y,TextAttr,0,#$C2#$BB)
\r
99 nFWrite(x,y,TextAttr,0,chr(187));
\r
104 procedure nSetActiveWin(win:pwin);
\r
110 procedure nWindow(var win : pwin; x,y,x1,y1 : integer);
\r
112 win^.x:=x; win^.y:=y;
\r
113 win^.x1:=x1; win^.y1:=y1;
\r
116 procedure init_windows;
\r
118 stdscr:=@win_arr[1];
\r
121 nWindow(stdscr,1,1,80,25);
\r
124 procedure WritePrompt(x,y:integer);
\r
131 function square_wave(time : Real):integer;
\r
135 if time-l < 0.5 then square_wave:=0
\r
136 else square_wave:=1;
\r
139 {callback function to generate sound}
\r
140 procedure ProccessAudio(userdata: Pointer; stream: PUInt8; len: LongInt); cdecl;
\r
141 var i,j,k,step:integer;
\r
144 for i:=0 to trunc((len-1)/step) do begin
\r
147 if sound_i > 0 then begin
\r
148 current_freq:=sound_Freqs[sound_play]/audio_freq;
\r
149 if current_freq=0 then current_freq:=1;
\r
150 sound_play:=sound_play+1;
\r
151 if sound_play > sound_i then begin
\r
152 speaker_on:=false; sound_i:=0; sound_play:=0; end;
\r
155 lasttime:=trunc(lasttime*lastfreq/current_freq);
\r
157 for j:=0 to step-1 do begin
\r
161 stream[k]:=audio_VOLUME*square_wave(current_freq * (j+lasttime) )
\r
166 lasttime:=lasttime+step;
\r
167 lastfreq:=current_freq;
\r
171 function InitAudio:boolean;
\r
172 var Desired, Obtained: TSDL_AudioSpec;
\r
174 { Set up the requested settings }
\r
175 Desired.freq := audio_FREQ;
\r
176 Desired.format := AUDIO_U8;
\r
177 Desired.channels:= 1;
\r
178 Desired.samples := audio_SAMPLES;
\r
179 Desired.callback:= @ProccessAudio;
\r
180 Desired.userdata:= nil;
\r
182 if SDL_Init(SDL_INIT_AUDIO) = 0 then
\r
183 if SDL_OpenAudio(@Desired, @Obtained) = 0 then begin
\r
186 current_freq:=1; lastfreq:=1;
\r
191 else InitAudio:=false
\r
196 procedure InitScrKbd;
\r
200 if initaudio then sound_supported:=true
\r
202 WriteLn('SDL failed to initialize audio: ', SDL_GetError);
\r
203 sound_supported:=false;
\r
207 nWindow(win1,2,2,79,4);
\r
208 nWindow(win2,2,5,79,24);
\r
209 nsetActiveWin(stdscr);
\r
212 procedure DoneAudio;
\r
214 if sound_supported then begin
\r
220 procedure DoneScrKbd;
\r
223 nSetActiveWin(stdscr);
\r
227 procedure sound( Hz: Integer );
\r
229 if sound_supported then begin
\r
231 current_freq:=Hz/audio_Freq;
\r
232 if current_freq > 0 then
\r
241 if sound_supported then begin
\r
242 if sound_i > 0 then begin
\r
244 while speaker_on do;
\r
250 procedure sounddelayed( Hz,step: Integer ); forward;
\r
252 procedure sounddelayed( Hz: Integer );
\r
254 sounddelayed( Hz, audio_STEP );
\r
257 procedure sounddelayed( Hz,step: Integer );
\r
259 if sound_supported then begin
\r
260 sound_ticks:=sound_ticks+1;
\r
261 if sound_ticks mod step = 0 then begin
\r
262 if sound_i < audio_MAXENTRIES then begin
\r
263 Sound_Freqs[sound_i]:=Hz;
\r
264 sound_i:=sound_i+1;
\r
270 procedure delay( MS: Integer);
\r
272 if sound_supported then
\r
282 procedure ReadLine(var S:String);
\r
288 if (buflen>0) and (ch<>Chr(13)) then begin
\r
292 Until (Ch=chr(13));
\r
296 procedure SF; begin SFlag:=True end;
\r
298 procedure Cur(Num:byte);
\r
302 1:ncursor(cON); { Underline }
\r
303 2:ncursor(cBIG); { Solid block }
\r
304 3:nCursor(cOFF); { Invisible }
\r
306 1:cursoron; { Underline }
\r
307 2:cursorbig; { Solid block }
\r
308 3:cursoroff; { Invisible }
\r
313 procedure Col(Num1,Num2:byte);
\r
314 begin if Color then textcolor(Num1) else textcolor(Num2) end;
\r
316 procedure Bak(Num1,Num2:byte);
\r
317 begin if Color then textbackground(Num1) else textbackground(Num2) end;
\r
319 procedure Bor(Num1,Num2:byte);
\r
322 begin AX:=$B00;if Color then BX:=Num1 else BX:=Num2 end;intr($10,Result)}
\r
325 function En(Num:byte):boolean;
\r
326 begin if Num in Events then En:=true else En:=false end;
\r
328 procedure Add(Num:byte);
\r
329 begin Events:=Events+[Num] end;
\r
331 procedure Min(Num:byte);
\r
332 begin Events:=Events-[Num] end;
\r
334 procedure Score(Num,pointer:integer);
\r
335 begin if not en(pointer)then begin Sc:=Sc+Num;Add(Pointer)end end;
\r
337 procedure Cn(s:str78);
\r
338 begin gotoxy(40-(length(s)div 2),wherey);write(s);gotoxy(1,wherey+1)end;
\r
340 procedure wCn(s:str78);
\r
341 begin gotoxy(39-(length(s)div 2),wherey);writeln(s);end;
\r
344 begin col(15,15);write('Press any key to continue...');
\r
345 CFlag:=ReadKey;col(11,7);writeln;
\r
348 procedure Tune(Octave,Note,Duration:integer);
\r
349 var Frequency:real;
\r
353 for i:=1 to Octave do
\r
354 Frequency:=Frequency*2;
\r
355 for i:=1 to Note-1 do
\r
356 Frequency:=Frequency*1.059463094;
\r
357 if Duration <> 0 then
\r
359 sound(round(Frequency));
\r
363 else sound(round(Frequency));
\r
366 procedure Play(Start,Stop,Speed:integer);
\r
369 if Start<=Stop then
\r
370 for x:=Start to Stop do
\r
371 if Speed>0 then begin sound(x);delay(Speed)end
\r
372 else sounddelayed(x)
\r
374 for x:= Start downto Stop do
\r
375 if Speed>0 then begin sound(x);delay(Speed)end
\r
376 else sounddelayed(x);
\r
377 if Speed>0 then begin
\r
378 nosound;if Region=4 then sound(20);if Region=5 then sound(60);
\r
382 procedure Explode(Duration:byte);
\r
384 begin for x:=Duration*999 downto 20 do sounddelayed(random(x));nosound end;
\r
386 procedure Walls(Duration:byte);
\r
388 begin for x:=1 to Duration*999 do sounddelayed(random(35)+20);nosound end;
\r
395 0:for y:=1 to random(70)+10 do sounddelayed(random(4000)+3000);
\r
396 1:begin nosound;delay(random(29))end
\r
397 end;nosound;if Region=5 then sound(60)
\r
404 begin play(550-x*6,600+x*6,0);play(600+x*6,550-x*6,0)end;explode(2)
\r
407 procedure Dopen(Num:byte);
\r
408 begin writeln('The door slides open...');
\r
409 if Num<>0 then play(50,125-Num,Num)
\r
410 else begin for i:=3500 to 5000 do sounddelayed(random(4500)+i);nosound;end;
\r
411 if Region=5 then sound(60)
\r
414 procedure Dclose(Num:byte);
\r
415 begin writeln('The sliding door closes.');
\r
416 if Num<>0 then play(125-Num,50,Num)
\r
417 else begin for i:=5000 downto 3500 do sounddelayed(random(4500)+i);nosound;end;
\r
418 if Region=5 then sound(60)
\r
421 procedure Door(New,Num:byte);
\r
423 if en(7)then RL(22)else
\r
424 if en(8)then RL(23)else begin DOpen(Num);Move(New);DClose(Num)end
\r
427 procedure won; forward;
\r
429 procedure SoundTest;
\r
433 while true do begin
\r
435 writeln(' Sounds ');
\r
436 writeln(' 1. Won ');
\r
437 writeln(' 2. explode(32) ');
\r
438 writeln(' 3. Walls(12) ');
\r
439 writeln(' 4. Static ');
\r
440 writeln(' 5. Blast ');
\r
441 writeln(' 6. Dopen(10) ');
\r
442 writeln(' 7. Dclose(0) ');
\r
443 writeln(' Q. Quit ');
\r
447 if ch='q' then halt;
\r
458 for x:=1 to 20 do for y:=1 to x*8 do sounddelayed(x*9,trunc((168-y)/8)); nosound;
\r
467 begin Tic:=Tic+1; Min(128); { <--Negates DEAD } col(13,15);
\r
468 for x:=1 to TMax do T[x]:=T[x]-1;
\r
469 if T[2]=1 then begin PStat:=PStat-[5];RL(1)end;
\r
470 case T[3] of { Hunger }
\r
471 25:begin PStat:=PStat+[2];RL(2)end;
\r
473 4:begin Bor(4,7);RL(4)end;
\r
474 1:begin RL(124);DEAD;end
\r
476 case T[4] of { Thirst }
\r
477 22:begin PStat:=PStat+[6];RL(5)end;
\r
479 4:begin Bor(4,7);RL(7)end;
\r
480 1:begin RL(125);DEAD;end
\r
482 case T[5] of { Sleep }
\r
483 32:begin PStat:=PStat+[5];RL(8)end;
\r
485 5:begin Bor(4,7);RL(10)end;
\r
486 1:begin RL(126);DEAD;end;
\r
487 2..4,6..13:begin x:=random(29)+1;
\r
488 if(x in Inv)and not(x in Wear)then
\r
489 begin Van(x);R[x]:=Prm;
\r
490 writeln('A bout of weariness causes you to loose your grip on',
\r
495 case T[29] of { Laser Injury }
\r
497 4:begin RL(507);Bor(4,7)end;
\r
498 2,3,5..8,10,11:begin repeat x:=random(27)+1 until x in[1..12,16..20,22..26,28];
\r
499 if(x in Inv)and not(x in Wear)then
\r
500 begin Van(x);R[x]:=Prm;
\r
501 if random(2)=0 then
\r
502 writeln('A sudden stab of pain shoots up your side, you drop the ',
\r
503 FN(x),'.') else begin
\r
504 writeln('The ',FN(x),' falls from your grip as you almost collapse ',
\r
505 'from the');writeln('extreme pain.')end
\r
508 1:begin RS(215);DEAD;end
\r
510 case T[12] of { Sickness }
\r
511 120,99,83,55:RL(207);
\r
512 65:begin PStat:=PStat+[3];RL(208)end;
\r
513 47:RL(209); 30:RS(73); 15:RS(74); 4:begin Bor(4,7);RS(75)end;
\r
514 1:begin RS(76);DEAD end;
\r
515 2,3,5..14,16..29:if(random(25)=0)and(Inv<>[])and not(en(125))then
\r
517 for x:=1 to 29 do if(x in Inv)and not(x in Wear)then
\r
518 begin Van(x);R[x]:=Prm end
\r
522 if(Prm in[81..88])and(T[30]<1)and(random(4)=0)then
\r
524 begin T[30]:=9;RS(153+Prm);
\r
525 for i:=999 to 2300 do sounddelayed(random(i*3)+i);
\r
526 for i:=3000 downto 20 do sounddelayed(random(i*4)+i*2);nosound
\r
530 write('A small droid appears from the ');
\r
532 81:write('south'); 82:write('southwest'); 83:write('west');
\r
533 84:write('northwest'); 85:write('north'); 86:write('northeast');
\r
534 87:write('east'); 88:write('southeast')
\r
535 end; writeln(' section of the corridor and flies');
\r
536 RS(242);RS(243);for i:=20 to 3000 do sounddelayed(random(i*3)+i);nosound;
\r
542 begin col(10,7); { Pre-Jungle Planet }
\r
545 18:begin MC(1,8,8,1);MC(1,13,8,2)end;
\r
546 17:if en(19) then begin RS(9);T[1]:=11;end;
\r
547 11..16:if not(en(19))and(Prm=8)and(random(2)=1)then RL(0);
\r
549 9:begin MC(1,9,0,4);T[1]:=Null;end;
\r
550 5..7:if(en(2))and(en(3))then begin RB2(5-(T[1]-3),10);col(10,7)end;
\r
551 4:if Prm=8 then begin T[1]:=11;RS(5)end;
\r
553 if(T[7]=1)then begin RS(35);DEAD;end;
\r
554 if(T[6]=2)and(en(7))then RL(140);
\r
555 if(T[6]=1)and(en(7))then begin RS(20);DEAD;end;
\r
556 case T[8] of { Lift-off countdown }
\r
557 5:RL(181); 4:RL(182); 3:RL(191); 2:RL(192);
\r
559 begin Min(10);Min(26);Min(27);Explode(32);
\r
560 sound(20);Bor(0,0);Score(10,122);
\r
561 n[84]:='reactor regulat\';
\r
562 RB(7,10);delay(9999);Pause;col(10,7);RS(43);PStat:=PStat-[2,5,6];
\r
563 Region:=4;T[3]:=150;T[4]:=125;T[5]:=230;T[8]:=0;T[9]:=1;T[10]:=5;end
\r
564 else begin RS(44);Explode(32);DEAD;end;
\r
566 if T[9]<1 then T[9]:=15;
\r
567 if(Region=4)and(Prm=1)and(T[9]=12)then RS(62);
\r
568 if T[10] in[1..4]then RL(194);
\r
569 if(Tic>3)and(Prm=8)and not(en(9))and not(en(7))then
\r
570 begin RS(6);Add(9)end else
\r
571 if(Tic>5)and(Prm=8)and(en(9))and not(en(16))and not(en(7))then
\r
572 begin RS(7);Add(16)end;
\r
574 1:if(random(2)=0)and(T[9]>12)and(T[9]<15)and(Region=4)and not en(129)then
\r
575 begin RL(593);RL(594);Add(129)end
\r
576 else if(random(20)=0)and(Region=4)then RL(592);
\r
577 7:if random(5)=0 then RL(595);
\r
578 8:if random(3)=1 then RL(24)else if random(3)=1 then RL(178);
\r
579 15,17,19:case random(60) of
\r
582 3,4:if RC>40 then begin if T[4]>10 then T[4]:=10;RL(598)end;
\r
584 20:if random(4)=1 then RL(25);
\r
586 if Prm=SinkRm then begin RL(85);L[Prm]:=L[Prm]+[79];end;
\r
590 begin col(10,7); { Jungle Planet }
\r
592 if Prm in[42..49]then
\r
593 begin writeln('Some of the walls shift positions.');Walls(4);end;
\r
595 7:if random(5)=0 then RL(595);
\r
596 26..29,32..34,59,60:case random(40) of
\r
597 0,1:RL(210); 2,3:RL(211); 4:RS(77); 5,6:RS(78); 7,8:RL(212);
\r
598 9:RL(213); 10:RL(214); 11:begin RL(215);play(6000,6001,20)end
\r
600 42..50:if random(7)=0 then RL(280);
\r
602 if(Prm=28)and(random(2)=0)then RL(233);
\r
603 if Prm=SinkRm then begin RL(85);L[Prm]:=L[Prm]+[79];end;
\r
604 if T[11]=2 then RL(205);
\r
605 if T[11]=1 then begin RS(70);DEAD;end;
\r
606 if T[13]=1 then begin RB(11,10);for x:=1 to 3 do begin tune(4,2,200);
\r
607 delay(99);tune(4,5,200);delay(99)end;Pause end;
\r
608 if(T[14]=2)and(Prm in[40,41])then RL(251);
\r
610 case Prm of 40:begin RL(249);Walls(8);end;41:begin RL(250);Walls(8);end end;
\r
611 if(T[15]=1)and(Prm=39)then begin RS(94);DEAD;end;
\r
612 if T[17]=4 then begin RS(109);DEAD;end;
\r
613 if T[17]=1 then begin Add(36);if Prm=56 then begin RS(110);Walls(8);end end;
\r
614 if T[18]=2 then begin RS(123);Walls(12)end;
\r
615 if(T[18]=1)and(Prm=53)then begin RS(124);Walls(12);DEAD;end;
\r
616 if T[19]=1 then begin RS(128);Walls(12);DEAD;end;
\r
620 begin col(11,7); { Inner Planet }
\r
622 case Prm of 73:DClose(20);66:begin RL(337);play(105,50,20)end end;
\r
624 if(Prm=74)and not(en(47))then
\r
625 writeln('There is something flashing on the computer''s screen.');
\r
626 if(Prm=73)and(CodeSet<>4)then begin
\r
627 writeln('There''s an alarm sound coming over the radio.');
\r
630 for i:=450 to 999 do sounddelayed(i);
\r
631 for i:=999 downto 450 do sounddelayed(i);
\r
635 1..3:if here(38)then RL(588);
\r
636 4,5:begin RL(589);Explode(3)end;
\r
637 6:begin RS(244);for x:=1 to 7 do Static;end
\r
638 else if(Prm in[64,73])and(random(9)=0)then begin RL(590);RL(591)end
\r
642 procedure Time2D; { Planetship }
\r
643 function Warn(Message,IfTime,Said:integer):boolean;
\r
645 if not en(Said)and(IfTime>=T[26])then
\r
646 begin if Said<>59 then begin Static;RS(Message);Static end
\r
647 else if Prm>99 then begin Static;RS(Message);Static end;
\r
648 if(Said=59)and(Prm<100)then begin end
\r
649 else begin Warn:=True;Add(Said)end
\r
653 for x:=0 to 2 do if T[23+x]>2 then Score(20,118+x); { 60 total points }
\r
654 if en(64)then Score(10,121);
\r
656 case Prm of 91:DClose(20);86:begin RL(337);play(110,50,15)end end;
\r
658 if(Prm=95)and not(en(48))then begin
\r
659 writeln('A loud siren is sounding off...');
\r
660 play(300,530,6);delay(200);play(300,530,6)end;
\r
661 if(Prm=91)and not en(53)then begin writeln('An alarm is ringing...');
\r
662 for x:=1 to 23 do begin sound(400);delay(99);sound(940);delay(60);nosound;
\r
665 begin write('The door slides open...');play(50,60,65);
\r
666 writeln('then closes.');play(60,50,60);
\r
667 if en(50)then RS(153)else
\r
668 if Inv=[] then begin RS(247);RS(248)end
\r
669 else begin RS(154);RS(155);Inv:=[];end;
\r
670 delay(2500);write('The door slides open...');play(50,60,65);
\r
671 writeln('then closes.');play(60,50,65);
\r
674 13:begin if Prm=91 then RL(438);MC(2,91,91,161);Add(53)end;
\r
675 12:MC(2,91,91,162);
\r
676 11:begin if Prm in[86,91]then DOpen(15);MC(2,91,86,163);MC(2,86,86,164);
\r
677 if Prm in[86,91]then DClose(15)end;
\r
678 10:begin MC(2,86,87,165);MC(2,87,87,166)end;
\r
679 9:begin if Prm in[87,89]then DOpen(65);MC(2,87,89,167);MC(2,89,89,168);
\r
680 if Prm in[87,89]then DClose(65)end;
\r
681 7,8:if Prm=89 then begin ScrnSet:=4;RL(417)end;
\r
682 6:begin if Prm in[87,89]then DOpen(65);MC(2,89,87,169);MC(2,87,87,170);
\r
683 if Prm in[87,89]then DClose(65)end;
\r
684 5:begin MC(2,87,86,171);MC(2,86,86,172)end;
\r
685 4:if T[21]<2 then begin MC(2,86,91,173);if Prm in[86,91]then DOpen(15);
\r
686 if Prm=86 then RL(418);MC(2,91,91,174);if Prm in[86,91]then DClose(15)end
\r
687 else if Prm=86 then begin RL(418);MC(2,0,91,0)end;
\r
688 1:if Prm=91 then begin RL(419);Van(123);DClose(55)end else Van(123)
\r
690 if(T[23]>1)and(T[23]<4)and(Prm=91)then begin T[24]:=7;T[23]:=NULL;end;
\r
692 7:if Prm=91 then RS(175);
\r
693 6:if Prm=91 then begin RS(176);RS(177)end;
\r
694 5:if Prm=91 then begin RS(178);RS(179)end;
\r
695 4:begin if Prm=91 then RL(420);if not(1 in Inv)then T[24]:=2;end;
\r
696 2,3:if(Prm=91)and(1 in Inv)then RL(419+T[24]);
\r
697 1:begin Van(123);if Prm=91 then begin RS(180);DOpen(55);RL(418);
\r
702 2..5:if Prm=91 then RS(188-T[25]);
\r
703 1:begin if Prm=91 then RS(187);T[24]:=2;T[26]:=40;Add(64)end;
\r
706 if not Warn(198,38,54)then
\r
707 if not Warn(199,33,55)then
\r
708 if not Warn(203,30,59)then
\r
709 if not Warn(200,25,57)then
\r
710 if not Warn(201,20,58)then
\r
711 if not Warn(202,15,56)then
\r
712 if not Warn(204,10,60)then
\r
713 if not Warn(205,6,61)then
\r
714 if not Warn(206,3,62)then
\r
715 if not Warn(207,2,63)then begin end;
\r
716 if T[26]=1 then begin RS(197);DEAD;end;
\r
717 if(T[27]=1998)and(Prm=99)then begin RS(213);Blast;DEAD;end;
\r
718 if(T[28]=1998)and(Prm=101)then begin RS(213);Blast;DEAD;end;
\r
721 procedure Directory;
\r
723 SM1Found : boolean;
\r
726 {ChDir(Drive+':');}
\r
729 if FindFirst ('*',faAnyFile,Info)=0 then
\r
731 if length(Info.Name)>4 then
\r
732 if copy(Info.Name,length(Info.Name)-2,3)='sm1' then
\r
734 if not SM1Found then
\r
735 writeln('Here is a list of the SAVE/RESTORE files on the ',
\r
736 'disk in drive ',up(Drive),':');
\r
738 writeln(' * ',copy(Info.Name,1,length(Info.Name)-4));
\r
740 until FindNext(Info)<>0;
\r
744 if not SM1Found then
\r
746 writeln('There are not any SAVE/RESTORE files on the disk in drive ',
\r
747 up(Drive),':');writeln;
\r
749 Pause;{ChDir(Log+':');}
\r
752 function Up(Word:Str130):Str1;
\r
753 begin word:=word+' ';
\r
754 if(Word[1]='l')and(Word[2]=' ')then insert('ook',Word,2);
\r
755 if(Word[1]='e')and(Word[2]='x')and(Word[3]=' ')then insert('amine',Word,3);
\r
756 delete(Word,length(word),2);Up:='';
\r
757 for x:=1 to length(Word) do Word[x]:=upcase(Word[x]);
\r
758 col(12,15); write(Word); col(11,7)
\r
761 procedure Spaces(var I:Str130);
\r
762 begin I:=concat(' ',I,' ')end;
\r
764 procedure QFormat(var I:Str130);
\r
766 if(I[1]='.')or(I[1]=' ')then delete(I,1,1);
\r
767 if(I[length(I)]='.')or(I[length(I)]=' ')then delete(I,length(I),1);
\r
770 procedure PreFormat(var I:Str130);
\r
771 procedure D(A:Str29;B:byte);
\r
772 begin while pos(A,I)<>0 do delete(I,pos(A,I),B)end;
\r
773 begin D(' ',1);QFormat(I);
\r
774 FFlag:=0; if(length(I)>0)then FFlag:=1;
\r
776 Crawl:=false;if pos(' crawl ',I)>0 then Crawl:=true;D(' crawl ',6);
\r
777 D(' walk ',5);D(' run ',4);D(' go ',3);D(' travel ',7);
\r
778 QFormat(I); if(length(I)=0)and(FFlag=1)then FFlag:=2; Spaces(I);
\r
779 D(' of ',3);D(' the ',4);D(' very ',5);D(' more ',5);D(' and ',4);
\r
780 D(' large ',6);D(' big ',4);D(' huge ',5);D(' please ',7);
\r
781 D(' small ',6);D(' little ',7);D(' tiny ',5);
\r
782 D('''',1);D('#',1);D('!',1);D('?',1);D(' number ',7);
\r
783 QFormat(I); if(length(I)=0)and(FFlag=1)then FFlag:=3; Spaces(I);
\r
784 while pos('examine ',I)>0 do delete(I,pos('examine ',I)+2,5);
\r
785 while pos(' into ',I)>0 do delete(I,pos(' into ',I)+3,2);
\r
786 while pos(' onto ',I)>0 do delete(I,pos(' onto ',I)+3,2);
\r
787 while pos(' inside ',I)>0 do delete(I,pos(' inside ',I)+3,4);
\r
788 while pos(' within ',I)>0 do delete(I,pos(' within ',I)+1,4);
\r
789 while pos('look ',I)>0 do delete(I,pos('look ',I)+1,3);
\r
790 while pos('. ',I)>0 do delete(I,pos('. ',I)+1,1);
\r
791 while pos(',',I)>0 do
\r
792 begin insert(' ',I,pos(',',I));delete(I,pos(',',I),1)end;
\r
793 D('..',1);D(' .',1);D(' ',1);
\r
795 if(length(I)=0)then
\r
800 else writeln('Pardon me?')
\r
805 procedure LowerCase(var I:Str130);
\r
807 if(length(I)>0)then
\r
808 for x:=1 to length(I) do
\r
809 if(I[x] in['A'..'Z'])then
\r
810 I[x]:=chr(ord(I[x])+32);
\r
813 procedure ChopSeven(var I:Str130);
\r
816 if(length(I)>0)then
\r
821 while(I[x]<>' ')and(I[x]<>'.')and(I[x]<>',')do
\r
822 begin Word:=Word+I[x]; x:=x+1 end;
\r
823 if(length(Word)>7)then
\r
825 y:=pos(Word,I); x:=x+(7-length(Word));
\r
826 delete(I,y,length(Word)); delete(Word,8,130);
\r
830 until(x-1)=length(I);
\r
831 delete(I,length(I),1)
\r
835 procedure FindMood(var input:Str130;var Word:Str29;var Md:byte);
\r
840 Spaces(input);x:=0;
\r
845 while pos(Counter,Temp1)>0 do
\r
847 Temp2:=copy(Temp1,1,pos(Counter,Temp1)-1);
\r
848 if(pos(' '+Temp2+' ',input)>0)then
\r
851 Md:=x;if Md=2 then Md:=1;
\r
852 x:=AMax;Counter:='8';
\r
853 delete(input,pos(Temp2,input),length(Temp2)+1);
\r
855 delete(Temp1,1,pos(Counter,Temp1));
\r
856 Counter:=succ(Counter);
\r
862 function FN(VNP:byte) : Str29; { ( Finds first Noun ) }
\r
866 FN:=copy(Temp,1,pos('\',Temp)-1);
\r
869 function Here(Obj:byte) : Boolean;
\r
871 if Obj in L[Prm] then Here:=true;
\r
872 if(Obj=79)and(MugCon=79)and(29 in Inv)then Here:=true;
\r
873 if Obj<=MMax then if(R[Obj]=Prm)or(Obj in Inv)then Here:=true;
\r
874 if(Obj=58)and((3 in Inv)or(4 in Inv)or(R[4]=Prm)or(R[3]=Prm))then Here:=true;
\r
877 function Present : Boolean;
\r
879 begin Present:=false; x:=0;
\r
880 if not(Vb in [17,18,37,39]) then
\r
884 if Here(N2) then Present:=true
\r
885 else writeln('You can''t see any ',FN(N2),' here.')
\r
887 else writeln('You can''t see any ',FN(N1),' here.')
\r
890 begin JUMP: x:=x+1;
\r
892 if x in NounSet then
\r
893 if Here(x) then goto JUMP
\r
894 else begin writeln('You can''t see any ',FN(x),' here.');end
\r
900 procedure Convert(var n:byte;Max:byte);
\r
903 1:case n of { Verbs }
\r
904 12:n:=11; 14:n:=13; 23:n:=22; 27:n:=26;
\r
905 29:n:=28; 34:n:=33; 36:n:=35; 38:n:=37; 40:n:=39; 43:n:=42; 45:n:=44;
\r
906 52:n:=51; 55:n:=54; 57,58:n:=56; 60,61:n:=59; 63:n:=62;
\r
908 2:case n of { Nouns }
\r
909 13..15:n:=12; 21:n:=20; 33:n:=32; 36:n:=35; 39:n:=38; 45:n:=44;
\r
910 50:n:=49; 53:n:=52; 65:n:=64; 67:n:=66; 70:n:=69; 76,77:n:=75;
\r
911 97:n:=96; 101,102:n:=100; 114:n:=113; 117:n:=116; 63:n:=62;
\r
912 27:n:=26; 57:n:=56; 61:n:=60; 91:n:=90; 105..108:n:=109; 31:n:=28;
\r
913 133:n:=46; 84:if Prm>21 then n:=128; 115:if Prm=28 then n:=112;
\r
914 58:if Prm=52 then n:=64;
\r
916 3:case n of { Prepositions }
\r
917 2:n:=1; 4:n:=3; 8:n:=7 ;
\r
922 procedure FindWord( var I : Str130; { input string }
\r
923 var VNP : byte; { flags which # word found }
\r
924 var Word : Str29; { stores last word found }
\r
925 Max : byte); { check which list? }
\r
930 QFormat(I); Spaces(I); J:=0;
\r
931 while (j<m[Max]) do
\r
934 case Max of 1:Temp1:=v[j]; 2:Temp1:=n[j]; 3:Temp1:=p[j] end;
\r
935 ps:=pos(Slash,Temp1);
\r
938 Temp2:=copy(Temp1,1,ps-1);
\r
939 if(copy(I,1,length(Temp2)+2)=' '+Temp2+' ')then
\r
940 begin { Match Found }
\r
944 delete(I,1,length(Temp2)+1);
\r
945 case Max of 1:VStr:=Word; 2:NStr:=Word end;
\r
949 delete(Temp1,1,ps);
\r
950 ps:=pos(Slash,Temp1);
\r
956 procedure Dictionary(IfFound,SkipList:byte);
\r
957 var StopLoopFlag:byte;
\r
958 begin VNP:=Null; list:=1; StopLoopFlag:=1;
\r
959 while(list<4)and(StopLoopFlag=1)do
\r
961 if list=SkipList then list:=list+1
\r
964 FindWord(input,VNP,Word,list);
\r
966 begin EFlag:=IfFound;list:=list-1;StopLoopFlag:=0;end;
\r
970 if(EFlag<>IfFound)then
\r
972 EFlag:=5;input:=input+' ';
\r
973 Word:=copy(input,1,pos(' ',input)-1);
\r
974 if(pos(' '+Word+' ',' top directi next some from is under underne '+
\r
975 'leaning but speak pay ')>0)then
\r
977 else If Word[1] in['0','1','2','3','4','5','6','7','8','9'] then EFlag:=17;
\r
978 if IfFound=14 then EFlag:=14;
\r
981 end; { Dictionary }
\r
983 procedure RL(Pointer:Integer);
\r
985 if(pointer<>StoreL)then
\r
986 begin StoreL:=pointer;
\r
993 procedure RS(Pointer:Integer);
\r
995 if(pointer<>StoreS)then
\r
996 begin StoreS:=pointer;
\r
1001 end; { Read Special }
\r
1003 procedure RR(Pointer:integer);
\r
1005 if(pointer<>StoreR)then
\r
1006 begin StoreR:=pointer;
\r
1014 end; { Read Room }
\r
1016 procedure RB(Pointer,Colour:byte);
\r
1018 Tstart,TStop:Str19;
\r
1019 begin SF; Col(Colour,7);
\r
1020 str(Pointer-1,TStart);
\r
1021 str(Pointer,TStop);
\r
1022 TStart:='('+TStart+')';
\r
1023 TStop:='('+TStop+')';
\r
1024 if old>=Pointer then reset(T1);
\r
1026 repeat readln(T1,Block) until Block=TStart;
\r
1029 if(Block<>TStop)then writeln(Block)
\r
1030 until Block=TStop; col(11,7);
\r
1033 procedure RB2(Pointer,Colour:byte);
\r
1035 Tstart,TStop:Str19;
\r
1036 begin SF; Col(Colour,7);
\r
1037 str(Pointer-1,TStart);
\r
1038 str(Pointer,TStop);
\r
1039 TStart:='('+TStart+')';
\r
1040 TStop:='('+TStop+')';
\r
1041 if old2>=Pointer then reset(T2);
\r
1043 repeat readln(T2,Block) until Block=TStart;
\r
1046 if(Block<>TStop)then writeln(Block)
\r
1047 until Block=TStop; col(11,7);
\r
1051 const W=800;H=400;Q=200;T=131;
\r
1054 gotoxy(1,20);for x:=1 to 5 do
\r
1055 begin writeln;delay(99);sound(x*50);Bor(x,7)end;
\r
1056 gotoxy(1,15);col(4,15);bak(1,7);
\r
1057 writeln('#######################################',
\r
1058 '#######################################');
\r
1059 delay(99);sound(300);Bor(6,0);
\r
1060 gotoxy(1,16);for x:=1 to 3 do begin
\r
1063 delay(99);sound(300+(x*50));Bor(x+8,15)end;gotoxy(1,19);
\r
1064 write('#######################################',
\r
1065 '#######################################');
\r
1066 delay(99);sound(500);Bor(14,0);
\r
1067 gotoxy(26,17);col(31,31);
\r
1068 write('Y O U H A V E W O N ! !');delay(99);sound(550);
\r
1069 gotoxy(1,20);bak(0,0);Bor(2,7);writeln;delay(99);nosound;
\r
1070 for x:=1 to 12 do begin writeln;delay(80)end;
\r
1071 gotoxy(1,9);Col(9,9);
\r
1072 writeln(' S U P E R N O V A');writeln;Col(11,7);
\r
1073 writeln(' Programmed by . . . . . . . . . . . . . . . . . . . . . Scott Miller');
\r
1074 writeln(' Story by . . . . . . . . . . . . . . . . . . . . . . . Scott Miller');
\r
1075 writeln(' Additional story development. . . . . . . . . . . . . . . Terry Nagy');
\r
1077 Vb:=78;Call13;writeln;writeln;Col(3,7);
\r
1078 write('Press any hey to quit...');
\r
1079 tune(2,8,q);tune(2,8,q);tune(3,1,w);
\r
1081 tune(2,8,q);tune(2,8,q);
\r
1082 tune(3,1,h);tune(2,12,h);tune(2,10,h);tune(2,8,q);tune(2,8,q);
\r
1083 tune(3,1,w);tune(2,8,t);tune(2,8,t);tune(2,8,t);
\r
1084 if keypressed then goto JUMP;
\r
1085 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
1087 if keypressed then goto JUMP;
\r
1088 tune(2,10,q);tune(2,10,q);
\r
1089 tune(3,3,h);tune(3,1,h);tune(2,12,h);tune(2,10,q);tune(2,10,q);
\r
1090 if keypressed then goto JUMP;
\r
1091 tune(3,3,w);tune(2,10,t);tune(2,10,t);tune(2,10,t);
\r
1092 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
1095 JUMP: CFlag:=ReadKey;
\r
1097 window(1,1,80,25);clrscr;gotoxy(2,2);Col(31,31);Bor(0,0);Cur(1);Bak(2,0);
\r
1098 writeln('Congratulations!');
\r
1102 procedure PlayerInput(var LINE:Str130);
\r
1105 ExtCode : integer;
\r
1106 procedure Key(k:Str19); begin Line:=Line+k;QFlag:=true;write(k)end;
\r
1108 {with Result do begin}
\r
1109 WRITELN; { Main Space In Game }
\r
1110 if(length(Line)=0)then
\r
1112 nSetActiveWin(win1);
\r
1113 bak(4,7);col(14,0);
\r
1114 gotoxy(7,1);write(Tic,' ');
\r
1115 gotoxy(34-(length(RN[Prm])div 2),1);
\r
1116 write(' ',RN[Prm],' ');
\r
1117 gotoxy(74,1);write(' ');gotoxy(74,1);write(Sc,' ');
\r
1119 col(1,0);gotoxy(21,2);
\r
1120 if PStat=[] then write('Healthy') else write(' * ');
\r
1121 col(15,0);gotoxy(32,2);
\r
1122 if 2 in PStat then begin col(31,16);write('Hungry')end
\r
1123 else write(' * ');
\r
1124 col(4,0);gotoxy(42,2);
\r
1125 if 3 in PStat then begin col(20,16);write('Sick')end
\r
1126 else write(' * ');
\r
1127 col(0,0);gotoxy(50,2);
\r
1128 if 4 in PStat then begin col(16,16);write('Injured')end
\r
1129 else write(' * ');
\r
1130 col(6,0);gotoxy(61,2);
\r
1131 if 5 in PStat then begin col(22,16);write('Tired')end
\r
1132 else write(' * ');
\r
1133 col(5,0);gotoxy(70,2);
\r
1134 if 6 in PStat then begin col(21,16);write('Thirsty')end
\r
1135 else write(' * ');
\r
1136 nSetActiveWin(win2);bak(0,0);
\r
1137 if en(66)then begin gotoxy(1,20);goto JUMP;end;
\r
1138 gotoxy(1,20);col(28,31);writeln;
\r
1139 WritePrompt(1,19);
\r
1141 col(14,7);gotoxy(3,19);
\r
1145 { Read Extended (Scan) Code }
\r
1146 if Ch = #0 then ExtCode:=Ord(Readkey);
\r
1147 sounddelayed(99,1);speaker_on:=true;delay(1);case Region of 4:sound(20);5:sound(60)end;
\r
1150 if(wherex=1)and(wherey=20)then
\r
1151 begin gotoxy(78,wherey-1); ClrEol; end else
\r
1152 if length(Line)>0 then write(^h,' ',^h);
\r
1153 delete(Line,length(Line),2);
\r
1158 if(Ord(Ch)>0)and(length(Line)<110)then
\r
1159 begin write(Ch);Line:=Line+Ch;end
\r
1160 else { read scan }
\r
1163 59:key('Save'); 71:key('Northwest');
\r
1164 60:key('Restore'); 73:key('Northeast');
\r
1165 61:key('R D'); 79:key('Southwest');
\r
1166 62:key('Look'); 81:key('Southeast');
\r
1167 63:key('Get all'); 82:key('Down');
\r
1168 64:key('Drop all'); 83:key('Up');
\r
1169 65:key('Score'); 104:begin QFlag:=true;RR(0)end;
\r
1170 66:key('Inventory');
\r
1172 68:begin Line:='';key('Repeat')end;
\r
1173 94,30:key('by Scott Miller');
\r
1174 95,47:key('Version A Dec 9, 85');
\r
1177 if Prm in[1..7] then
\r
1179 72:key('Fore'); 75:key('Port'); 77:key('Starboard'); 80:key('Aft')
\r
1183 72:key('North'); 75:key('West'); 77:key('East'); 80:key('South')
\r
1190 col(5,7);WritePrompt(1,19);col(11,7);gotoxy(1,20);
\r
1191 if length(Line)>76 then writeln;
\r
1192 LowerCase(Line);Spaces(Line);
\r
1193 if(pos(' r ',Line)>0)or(pos(' repeat ',Line)>0)then PreFormat(Line);
\r
1194 if(Line='r')or(Line='repeat')then Line:=Again else Again:=Line;
\r
1196 while pos(' then ',Line)>0 do
\r
1198 x:=pos(' then ',Line);delete(Line,x,5);insert('.',Line,x)
\r
1203 if(pos('.',Line)>0)then
\r
1204 begin { SEPERATES LINE INTO SINGLE INPUTS }
\r
1205 input:=copy(Line,1,pos('.',Line));
\r
1206 delete(Line,1,pos('.',Line));
\r
1207 delete(input,pos('.',input),1);
\r
1212 input:=Line; Line:='';
\r
1213 end; { END OF LINE SEPERATION }
\r
1215 while pos(' it ',input)>0 do
\r
1216 begin x:=pos(' it ',input)+1;delete(input,x,2);insert(LastNoun,input,x);
\r
1217 PreFormat(input);ChopSeven(input);
\r
1219 while pos(' them ',input)>0 do
\r
1220 begin x:=pos(' them ',input)+1;delete(input,x,4);insert(LastNoun,input,x);
\r
1221 PreFormat(input);ChopSeven(input);
\r
1226 {end;} { of with statement }
\r
1227 end; { PlayerInput }
\r
1234 clrscr;textcolor(7);Color:=true;
\r
1235 if ParamCount=0 then begin
\r
1236 write('Do you want ');textcolor(15);write('C');textcolor(7);
\r
1237 write('olor or ');textcolor(15);write('B');textcolor(7);
\r
1238 write('lack and white? ');textcolor(15); CFlag:=ReadKey;
\r
1239 if(upcase(CFlag)='B')or(upcase(CFlag)='M')then
\r
1240 begin Color:=false;write('Monochrome')end
\r
1241 else write('Color');delay(300);
\r
1244 begin input:=ParamStr(1);CFlag:=input[1];
\r
1245 if(CFlag='/')and(length(input)>1)then CFlag:=input[2];
\r
1246 if(upcase(CFlag)='B')or(upcase(CFlag)='M')then
\r
1247 begin Color:=false;writeln('Monochrome screen option...')end
\r
1248 else writeln('Color screen option...');delay(999)
\r
1250 clrscr;textmode(BW80);
\r
1253 {**** Public Domain title screen ****}
\r
1254 {Col(9,9);gotoxy(1,1);
\r
1255 cn('S U P E R N O V A');
\r
1256 Col(9,7);gotoxy(1,3);
\r
1257 cn('Published by');
\r
1259 cn('APOGEE SOFTWARE PRODUCTIONS');
\r
1262 cn('This game is placed in the public domain for your enjoyment. Please do');
\r
1263 cn('not abuse this product or the author''s rights.');
\r
1265 cn('If you enjoy this game the author asks that you contribute $10 (by check).');
\r
1266 cn('This payment will encourage the author to create similar games and will');
\r
1267 cn('help compensate him for the several years work that went into Supernova.');
\r
1268 cn('This fee will also register the payer for telephone support and clues.');
\r
1271 writeln('Please make checks payable to: Scott Miller');
\r
1273 writeln('Scott Miller (214) 240-0614');
\r
1274 writeln('4206 Mayflower Drive');
\r
1275 writeln('Garland, TX 75043');
\r
1277 writeln('Also call for help: Terry Nagy (214) 271-3065');
\r
1279 Col(11,7);delay(7000);
\r
1280 cn('Thanks, enjoy the game...');
\r
1282 Col(7,7);gotoxy(27,25);delay(999);
\r
1283 write('Press any key to continue.');repeat;delay(1);until keypressed;
\r
1284 CFlag:=ReadKey;}bak(1,0);clrscr;
\r
1285 {**** Main SUPERNOVA title screen ****}
\r
1287 Bor(1,0);Col(15,15);Bak(4,0);
\r
1289 nWindow(win,1,1,80,24);
\r
1293 begin gotoxy(x,1);write(chr(205));gotoxy(x,24);write(chr(205))end;
\r
1295 begin gotoxy(1,y);write(chr(186));gotoxy(80,y);write(chr(186))end;
\r
1296 gotoxy(1,1);write(chr(201)); gotoxy(80,1);write(chr(187));
\r
1297 gotoxy(1,24);write(chr(200)); gotoxy(80,24);write(chr(188));
\r
1300 Col(2,7);gotoxy(1,10);cn('Copyright 1987 Scott Miller');
\r
1301 Col(14,7);gotoxy(1,12);cn('Version B');
\r
1302 Col(7,7);gotoxy(1,15);
\r
1303 cn('Programmed by Scott Miller');
\r
1304 cn('Story by Scott Miller and Terry Nagy');
\r
1305 gotoxy(1,23);Col(3,7);
\r
1306 cn('Press any key to continue.');
\r
1309 if Color then textcolor(random(16))
\r
1310 else case random(3) of 0:textcolor(0); 1:textcolor(7); 2:textcolor(15)end;
\r
1311 write('S U P E R N O V A');
\r
1318 nSetActiveWin(stdscr);
\r
1322 if Color then textmode(C80)else textmode(BW80);
\r
1328 Bor(0,0);bak(0,0);clrscr;nosound;
\r
1330 GetDir(0,Word);Log:=Word[1];
\r
1331 for x:=1 to 20 do begin sound(x*9);delay(x*2)end;nosound;
\r
1332 gotoxy(1,9);y:=0;col(14,7);Identity:='';
\r
1333 Cn('Please enter your identity code name:');col(12,15);
\r
1334 repeat begin i:=random(maxint); delay(1) end; until keypressed;
\r
1335 repeat CFlag:=ReadKey;
\r
1336 if(CFlag<>chr(13))then
\r
1337 if(CFlag<>^h)then Identity:=Identity+upcase(CFlag)
\r
1338 else delete(Identity,length(Identity),2);
\r
1339 gotoxy(1,11);Cn(' '+Identity+' ');
\r
1343 {sound(50);delay(50);nosound;}
\r
1344 for x:=1 to 50 do sounddelayed(50,1); nosound;
\r
1345 until CFlag=chr(13);
\r
1346 col(10,7);gotoxy(1,7);
\r
1347 if identity<>'' then
\r
1348 Cn(' IDENTITY CODE ACCEPTED--YOU MAY PROCEED '+Identity)
\r
1350 col(25,31);Bor(4,7);Cn('IDENTITY CODE REJECTED--ABORTING SEQUENCE')end;
\r
1351 LowerCase(Identity);ChopSeven(Identity);
\r
1353 if Identity='' then goto ABORT;
\r
1357 assign(R1,'R1');assign(R2,'R2');
\r
1358 assign(T1,'SM');assign(T2,'B1');
\r
1359 reset(R1);reset(R2);
\r
1360 reset(S1);reset(L1);reset(C1);
\r
1365 col(7,15);bak(1,7);
\r
1368 nWriteAC(stdscr,1,4,TextAttr,nLT);
\r
1369 nWriteAC(stdscr,nCols(stdScr),4,TextAttr,nRT);
\r
1373 begin gotoxy(x,1);write(chr(205));gotoxy(x,24);write(chr(205))end;
\r
1374 gotoxy(80,24);write(chr(190));gotoxy(1,24);write(chr(212));
\r
1375 gotoxy(1,4);InsLine;
\r
1377 begin gotoxy(1,x);write(chr(179));gotoxy(80,x);write(chr(179))end;
\r
1378 gotoxy(1,4);write(chr(198));for x:=2 to 79 do
\r
1379 begin gotoxy(x,4);write(chr(205))end;write(chr(181));
\r
1380 gotoxy(1,1);write(chr(213));gotoxy(80,1);write(chr(184));
\r
1382 nSetActiveWin(win1);
\r
1383 bak(4,7);col(14,0);gotoxy(1,1);
\r
1384 for x:=1 to 78 do write(' ');
\r
1385 gotoxy(1,1);write('Move');
\r
1386 gotoxy(67,1);write('Score');
\r
1387 bak(7,7);gotoxy(1,2);
\r
1388 for x:=1 to 78 do write(' ');
\r
1389 bak(5,7);col(15,0);
\r
1390 gotoxy(1,2);write('Player Condition:');
\r
1391 col(7,15);bak(1,7);
\r
1393 gotoxy(1,3);whLine(win1,nHL,nCols(stdScr)-2);
\r
1396 nSetActiveWin(win2);
\r
1398 gotoxy(1,10);col(14,7);
\r
1399 wcn('Working 14 hours a day in the core of some dusty, smelly mine');
\r
1400 wcn('is not your idea of the perfect lifestyle.');
\r
1401 wcn('Barre-An is a dust ball in space, its only salvation being that it is');
\r
1402 wcn('rich in precious barre-an metal. Or used to be. Nowadays the mines');
\r
1403 wcn('don''t seem so generous, which is why you''re looking for a more');
\r
1404 wcn('profitable venture.');
\r
1405 wcn('A break, that''s all you ask for, maybe today you figure...');
\r
1420 for o :=1 to MMax do r[o]:=Null;
\r
1438 Socket :=[22..25];
\r
1448 StoreR:=-1;StoreS:=-1;StoreL:=-1;StoreC:=-1;{ Stores Last Read File Number }
\r
1449 Dir[1]:='NORTH';Dir[2]:='SOUTH';Dir[3]:='EAST';Dir[4]:='WEST';
\r
1450 Dir[5]:='NORTHEAST';Dir[6]:='NORTHWEST';
\r
1451 Dir[7]:='SOUTHEAST';Dir[8]:='SOUTHWEST';
\r
1452 m[1]:=VMax;m[2]:=NMax;m[3]:=PMax;
\r
1453 for x :=1 to TMax do T[x]:=Null;
\r
1455 T[3] :=70; { Hunger }
\r
1456 T[4] :=26; { Thirst }
\r
1457 T[5] :=85; { Sleep (No relation to the T[2] sleep timer!) }
\r
1458 NoNounOnly :=[1..8,15,16,30,77..79,82,85..87,95];
\r
1459 OneNounMaybe:=[9..14,25,32,46,59..60,66..71,80,81,90,91];
\r
1460 ToNounOnly :=[33,49,64,88,93];
\r
1461 ToNounMaybe :=[19,41..44,48,50,53,54,74..76,89,90,92,94];
\r
1462 { NOTE: All other verbs would be OneNounOnly! }
\r
1463 nSetActiveWin(win2);gotoxy(1,19);
\r
1467 label JUMPABORT,JUMPBACK;
\r
1468 {var DiskTest:file;}
\r
1469 begin SF; JUMPBACK: nosound; for x:=1 to 20 do writeln;
\r
1470 Bor(2,7);CFlag:=Drive;Cur(2);
\r
1472 { remove floppy drive selection
\r
1473 write('Which disk drive (default ',Up(Drive),':)? ');
\r
1474 col(14,15);buflen:=1;readline(Drive);col(11,7);
\r
1475 Drive:=upcase(Drive);if not(Drive in['A','B'])then Drive:=CFlag;}
\r
1477 writeln('Make sure your SAVE/RESTORE disk is in disk drive ',up(Drive),':');
\r
1479 write('SAVE under what file name (''',up('/'),''' aborts SAVE)? ');
\r
1480 buflen:=8;col(14,15);readline(input);col(11,7);
\r
1482 while pos(' ',input)>0 do delete(input,pos(' ',input),1);
\r
1483 while pos('.',input)>0 do delete(input,pos('.',input),1);
\r
1484 while pos(':',input)>0 do delete(input,pos(':',input),1);
\r
1485 if pos('/',input)>0 then
\r
1486 begin writeln;writeln(up('SAVE ABORTED'));goto JUMPABORT;end;
\r
1488 if(pos('list',input)>0)or(pos('dir',input)>0)or(pos('file',input)>0)then
\r
1489 begin Directory;goto JUMPBACK;end;
\r
1490 if length(input)=0 then input:='LASTSAVE';writeln;writeln;
\r
1491 writeln('The game file ',Up(Input),' is now being saved on disk drive ',
\r
1492 up(Drive),':...');
\r
1494 input:=Drive+':'+input;}
\r
1495 assign(Objects,input+'.sm1');
\r
1497 for x:=0 to RMax do write(Objects,L[x]);
\r
1499 assign(Things,input+'.sm2');
\r
1501 write(Things,Prm,Region,MugCon,FoodCon,SatchCon,NicheCon,PyraCon,
\r
1502 HingeCon,PodumCon,AlienRm,FriendRm,SinkRm,Serum,TFlag,
\r
1503 RobotCon,CodeSet,ScrnSet,HolstCon);
\r
1504 for x:=1 to MMax do write(Things,R[x]);
\r
1506 assign(Timers,input+'.sm3');
\r
1508 write(Timers,Tic,Sc,RC,Floor);
\r
1509 for x:=1 to TMax do write(Timers,T[x]);
\r
1512 begin aInv:=Inv;aPStat:=PStat;aEvents:=Events;
\r
1513 aSocket:=Socket;aWear:=Wear;end;
\r
1514 assign(Sets,input+'.sm4');
\r
1516 write(Sets,SetSave);
\r
1518 writeln;writeln;delete(input,1,2);
\r
1519 writeln('Your present game location is now SAVED under the name ',
\r
1521 writeln; JUMPABORT: writeln;
\r
1522 { remove checking SUPERNOVA floppy disk
\r
1523 writeln('Please make sure the SUPERNOVA disk is in drive ',up(Log),':');
\r
1524 writeln;writeln;Pause;
\r
1525 assign(DiskTest,'Nova.com');}
\r
1527 {reset(DiskTest);}
\r
1529 {if IOResult<>0 then
\r
1530 begin Col(15,15);close(DiskTest);write(^g);goto JUMPABORT;end;
\r
1531 close(DiskTest);} Col(11,7);
\r
1532 Bor(0,0);Line:='l';
\r
1533 case Region of 4:sound(20);5:sound(60)end
\r
1536 procedure Restore;
\r
1537 label JUMP,JUMPBACK;
\r
1538 {var DiskTest:file;}
\r
1539 begin SF; JUMPBACK: nosound; for x:=1 to 25 do writeln;
\r
1540 Bor(6,7);CFlag:=Drive;Cur(2);
\r
1542 { remove floppy disk selection
\r
1543 write('Which disk drive (default ',Up(Drive),':)? ');
\r
1544 col(14,15);buflen:=1;readline(Drive);col(11,7);
\r
1545 Drive:=upcase(Drive);if not(Drive in['A','B'])then Drive:=CFlag;}
\r
1547 writeln('Make sure your SAVE/RESTORE disk is in disk drive ',up(Drive),':');
\r
1549 write('RESTORE from what file name (''',up('/'),''' aborts RESTORE)? ');
\r
1550 buflen:=8;col(14,15);readline(input);col(11,7);
\r
1552 while pos(' ',input)>0 do delete(input,pos(' ',input),1);
\r
1553 while pos('.',input)>0 do delete(input,pos('.',input),1);
\r
1554 while pos(':',input)>0 do delete(input,pos(':',input),1);
\r
1555 if pos('/',input)>0 then
\r
1556 begin writeln;writeln(up('RESTORE ABORTED'));goto JUMP;end;
\r
1558 if(pos('list',input)>0)or(pos('dir',input)>0)or(pos('file',input)>0)then
\r
1559 begin Directory;goto JUMPBACK;end;
\r
1560 if length(input)=0 then input:='LASTSAVE';writeln;writeln;
\r
1561 writeln('The game file ',Up(Input),' is now being restored from drive ',
\r
1562 up(Drive),':...');
\r
1564 input:=Drive+':'+input;}
\r
1565 assign(Objects,input+'.sm1');
\r
1569 if IOResult<>0 then
\r
1570 begin close(Objects);col(12,15);writeln;writeln;delete(input,1,2);
\r
1571 for x:=1 to length(input) do input[x]:=upcase(input[x]);
\r
1572 wCn('The file '+input+' does not exist on your SAVE/RESTORE disk!');
\r
1573 writeln(^g);delay(2000);col(11,7);goto JUMPBACK;
\r
1576 for x:=0 to RMax do read(Objects,L[x]);
\r
1578 assign(Things,input+'.sm2');
\r
1580 read(Things,Prm,Region,MugCon,FoodCon,SatchCon,NicheCon,PyraCon,
\r
1581 HingeCon,PodumCon,AlienRm,FriendRm,SinkRm,Serum,TFlag,
\r
1582 RobotCon,CodeSet,ScrnSet,HolstCon);
\r
1583 for x:=1 to MMax do read(Things,R[x]);
\r
1585 assign(Timers,input+'.sm3');
\r
1587 read(Timers,Tic,Sc,RC,Floor);
\r
1588 for x:=1 to TMax do read(Timers,T[x]);
\r
1590 assign(Sets,input+'.sm4');
\r
1592 read(Sets,SetSave);
\r
1595 begin Inv:=aInv;PStat:=aPStat;Events:=aEvents;
\r
1596 Socket:=aSocket;Wear:=aWear;end;
\r
1598 writeln;writeln;delete(input,1,2);
\r
1599 writeln('Your present game location is now RESTORED from the name ',
\r
1601 writeln; JUMP: writeln;
\r
1602 { remove checking SUPERNOVA floppy disk
\r
1603 writeln('Please make sure the SUPERNOVA disk is in drive ',up(Log),':');
\r
1604 writeln;writeln;Pause;
\r
1605 assign(DiskTest,'Nova.com');}
\r
1607 {reset(DiskTest);}
\r
1609 {if IOResult<>0 then
\r
1610 begin Col(15,15);close(DiskTest);write(^g);goto JUMP;end;
\r
1611 close(DiskTest);} Col(11,7);
\r
1613 case Region of 4:sound(20);5:sound(60)end;
\r
1616 n[84]:='reactor regulat\';
\r
1617 n[126]:='hinged mouth\mouth\hinge\';
\r
1621 n[84]:='middle table\middle\';
\r
1624 if en(34)then n[18]:='glass ball\ball\glass\'
\r
1625 else n[18]:='dusty ball\ball\dusty\';
\r
1628 n[40]:='sockets\socket\';
\r
1629 n[82]:='laser beam\beam\laser\';
\r
1630 n[110]:='speaker\';
\r
1633 n[40]:='cyan button\cyan\';
\r
1634 n[82]:='solar map\map\solar\drawing\';
\r
1635 n[110]:='keyhole\';
\r
1637 Min(128);Line:='l';
\r
1640 procedure MoreThanOne;
\r
1642 if((N1=58)or(58 in NounSet)or(N2=58))and Here(3) and Here(4) then
\r
1644 repeat write('Which one, the R)usty or S)hiney key? ');
\r
1645 CFlag:=Readkey;writeln(CFlag);writeln until upcase(CFlag) in ['R','S'];
\r
1646 case upcase(CFlag) of 'R':x:=3; 'S':x:=4 end;
\r
1647 if N1=58 then N1:=x;
\r
1648 if N2=58 then N2:=x;
\r
1649 if 58 in NounSet then begin NounSet:=NounSet-[58];NounSet:=NounSet+[x] end;
\r
1651 if((N1=86)or(86 in NounSet)or(N2=86))and(Prm=8)then
\r
1653 repeat write('Which one, the W)estern, M)iddle or E)astern table? ');
\r
1654 CFlag:=ReadKey;writeln(CFlag);
\r
1655 writeln until upcase(CFlag) in ['W','M','E'];
\r
1656 case upcase(CFlag) of 'W':x:=83; 'M':x:=84; 'E':x:=85 end;
\r
1657 if N1=86 then N1:=x;
\r
1658 if N2=86 then N2:=x;
\r
1659 if 86 in NounSet then begin NounSet:=NounSet-[86];NounSet:=NounSet+[x] end;
\r
1661 if((N1=44)or(44 in NounSet)or(N2=44))and(Prm in[1,70])and(Vb<>28)then
\r
1663 repeat write('Which one, the T)an, P)urple or C)yan button? ');
\r
1664 CFlag:=ReadKey;writeln(CFlag);
\r
1665 writeln until upcase(CFlag) in ['T','P','C'];
\r
1666 case upcase(CFlag) of 'T':x:=41; 'P':x:=43; 'C':x:=40 end;
\r
1667 if N1=44 then N1:=x;
\r
1668 if N2=44 then N2:=x;
\r
1669 if 44 in NounSet then begin NounSet:=NounSet-[44];NounSet:=NounSet+[x] end;
\r
1671 if(N1=58)and Here(3)and not(Here(4))then N1:=3;
\r
1672 if(N2=58)and Here(3)and not(Here(4))then N2:=3;
\r
1673 if(58 in NounSet)and Here(3)and not(Here(4))then
\r
1674 begin NounSet:=NounSet-[58];NounSet:=NounSet+[3] end;
\r
1675 if(N1=58)and Here(4)and not(Here(3))then N1:=4;
\r
1676 if(N2=58)and Here(4)and not(Here(3))then N2:=4;
\r
1677 if(58 in NounSet)and Here(4)and not(Here(3))then
\r
1678 begin NounSet:=NounSet-[58];NounSet:=NounSet+[4] end;
\r
1679 end; { MoreThanOne }
\r
1682 function Print(Word:Str29):Str1;
\r
1683 begin Print:='';writeln('--you can''t use the word ',Up(Word),' here.')end;
\r
1685 procedure Parser_Syntax(var Input:Str130);
\r
1686 label JUMP1, JUMP2;
\r
1688 Word:=''; Md:=Null; Num:=Null; Code:=Null;
\r
1689 Vb:=Null; N1:=Null; N2:=Null; NounSet:=[];
\r
1690 JUMP1: { Used if the player forgets the first noun. }
\r
1691 FFlag:=Null; Pr:=Null;
\r
1692 JUMP2: { Used if the player forgets the second noun or preposition. }
\r
1694 FindMood(input,Word,Md);
\r
1695 if(length(input)>0)then
\r
1697 FindMood(input,Word,Num);
\r
1700 FindWord(input,Vb,Word,1);
\r
1702 if(length(input)=0)then
\r
1704 if(Vb in NoNounOnly)or(Vb in OneNounMaybe)then EFlag:=Legal;
\r
1705 if EFlag<>Legal then
\r
1707 if(Vb=35)and here(35)then begin EFlag:=Legal;N1:=35;NStr:='seat';end;
\r
1708 if(Vb=47)and here(6)then begin EFlag:=Legal;N1:=6;end;
\r
1709 if(Vb=62)and here(80)then begin EFlag:=Legal;N1:=80;end;
\r
1710 if(Vb=65)and here(124)then begin EFlag:=Legal;N1:=124;end;
\r
1711 if EFlag<>Legal then EFlag:=4
\r
1715 if(Vb in NoNounOnly)then Dictionary(3,9)
\r
1717 if not(Vb in[17,18,37,39])then { get,drop and but branch-off }
\r
1718 if not(Vb in[25,32,56,66..69,71,80,81])then { characters and type }
\r
1720 if(Vb<>FFlag)then FindWord(input,N1,Word,2);
\r
1721 if(N1<>Null)then LastNoun:=FN(N1);
\r
1723 if(Word<>'all')then
\r
1724 if(length(input)=0)then
\r
1725 if(Vb in ToNounOnly)then
\r
1726 if(VStr='fill')and(Prm=SinkRm)and(N1=29)then
\r
1727 begin N2:=79;Pr:=6;EFlag:=Legal;end else
\r
1728 if(Vb=64)and(Prm=8)and(N1 in[29,99])and(not en(21))and
\r
1729 here(8)then begin Pr:=6;N2:=8;EFlag:=Legal;end else
\r
1730 if(Vb=88)and(Prm in[9..11])and(N1=56)and here(3)then
\r
1731 begin Pr:=6;N2:=3;EFlag:=Legal;end
\r
1735 if(Vb in ToNounMaybe)or(Vb in ToNounOnly)then
\r
1737 FindWord(input,Pr,Word,3);
\r
1739 if(length(input)=0)then
\r
1740 if(Vb=50)and(Pr in[1,9])then EFlag:=Legal
\r
1743 if(Vb<>50)then { branch for turning dials }
\r
1745 FindWord(input,N2,Word,2);
\r
1747 if(Word<>'all')then
\r
1748 if(length(input)=0)then EFlag:=Legal
\r
1749 else Dictionary(12,9)
\r
1751 else Dictionary(11,2)
\r
1755 val(input,Code,testc);
\r
1756 if(testc=0)then EFlag:=Legal
\r
1757 else begin delete(input,1,testc-1);Dictionary(14,9);end;
\r
1759 else Dictionary(9,3)
\r
1762 begin Dictionary(3,9);if(List=2)then EFlag:=8;end
\r
1764 else Dictionary(10,2)
\r
1766 else { Special case for TYPE, characters, etc. }
\r
1770 end { of Special case for SAY, TYPE, etc. }
\r
1771 else { Special case for GET and DROP }
\r
1772 while EFlag=Null do
\r
1774 FindWord(input,N1,Word,2);
\r
1775 if(N1<>Null)then LastNoun:=FN(N1);
\r
1777 if not(N1 in NounSet)then
\r
1779 NounSet:=NounSet+[N1];
\r
1780 if(length(input)=0)then EFlag:=Legal
\r
1783 else Dictionary(10,2)
\r
1784 end { of Special case for GET and DROP }
\r
1785 else Dictionary(7,1)
\r
1790 if EFlag<>Legal then
\r
1791 begin Line:='';play(199,199,55);delay(70);play(60,60,55)end;
\r
1794 2:writeln('The word ',up(Word),' is too many adverbs.');
\r
1795 3:write('Illegal input',Print(Word));
\r
1796 4:if(Vb=56)then RL(187)
\r
1799 write('Noun missing--');
\r
1801 35,62:writeln('what do you want to ',up(Word),' on?');
\r
1802 65:writeln('what do you want to ',up(Word),' to?')
\r
1803 else writeln('what do you want to ',up(Word),'?');
\r
1805 PlayerInput(line);
\r
1806 if(length(input)>0)then goto JUMP1;
\r
1808 5:if(length(Word)>1)then
\r
1809 writeln('The word ',up(Word),' is not used in this adventure.')
\r
1811 writeln('The letter ',up(Word),' is not used as shorthand in this parser.');
\r
1813 writeln('Noun missing--what do you want to ',up(VStr),up(' the '),
\r
1814 up(NStr),' ',up(PStr),'?');
\r
1815 PlayerInput(line); FFlag:=Vb;
\r
1816 if(length(input)>0)then goto JUMP2;
\r
1818 7:write('Verb missing',Print(Word));
\r
1820 9:write('Preposition expected',Print(Word));
\r
1821 10:write('Noun expected',Print(Word));
\r
1822 11:write('Indirect noun expected',Print(Word));
\r
1823 12:write('No more input expected',Print(Word));
\r
1824 13:writeln('Illegal noun used--',up(Word),' referenced more than once.');
\r
1825 14:write('Number expected',Print(Word));
\r
1827 write('Preposition and noun missing--');
\r
1828 if(Vb in[33,48])then
\r
1829 writeln('where do you want to ',up(VStr),' the ',up(NStr),'?') else
\r
1832 writeln('who do you want to ',up(VStr),' the ',up(NStr),' to?')end
\r
1834 writeln('what do you want to ',up(VStr),' the ',up(NStr),' with?')end;
\r
1835 PlayerInput(line); FFlag:=Vb;
\r
1836 if(length(input)>0)then goto JUMP2;
\r
1841 end; { Parser Syntax }
\r
1843 procedure MC(WhichChar,WatchRoom,ToRoom:byte;MessageNum:Integer);
\r
1844 { WhichChar refers to the character(s) being moved. }
\r
1845 { WatchRoom is the room the player must be in to see the responce.}
\r
1846 { ToRoom is the room the character(s) move to. }
\r
1847 { MessageNum is the message that is written if the player sees. }
\r
1849 if(Prm=WatchRoom)then RS(MessageNum);
\r
1850 case WhichChar of { 1 = Aliens, 2 = Scientist }
\r
1852 L[AlienRm]:=L[AlienRm]-[124];AlienRm:=ToRoom;
\r
1853 L[AlienRm]:=L[AlienRm]+[124]
\r
1856 L[FriendRm]:=L[FriendRm]-[123];FriendRm:=ToRoom;
\r
1857 L[FriendRm]:=L[FriendRm]+[123]
\r
1863 procedure Van(o:byte);
\r
1867 L[Prm]:=L[Prm]-[o];
\r
1868 if o in Wear then Wear:=Wear-[o];
\r
1869 if o=SatchCon then SatchCon:=Null;
\r
1870 if o=MugCon then MugCon:=Null;
\r
1871 if o=16 then Min(6);
\r
1872 if o=NicheCon then NicheCon:=Null;
\r
1873 if o=PyraCon then PyraCon:=Null;
\r
1874 if o=HingeCon then HingeCon:=Null;
\r
1875 if o=PodumCon then PodumCon:=Null;
\r
1876 if o=16 then begin Min(37);Min(6)end;
\r
1877 if o=RobotCon then RobotCon:=Null;
\r
1878 if o in Socket then Socket:=Socket-[o];
\r
1879 if o=HolstCon then HolstCon:=Null
\r
1883 begin SF; RL(random(7)+127)end;
\r
1885 procedure NoSense;
\r
1886 begin RL(190) end;
\r
1888 procedure Say(What1,What2:Str29);
\r
1889 begin SF; writeln('The ',What1,' is already ',What2,'.') end;
\r
1891 {******************* END OF PARSER AND MISC. PROCEDURES *********************}
\r