src/ADPAR.PAS

   1 {//-------------------------------------------------------------------------}\r
   2 {/*                                                                         }\r
   3 {Copyright (C) 2014 Jason Self <j@jxself.org>                               }\r
   4 {                                                                           }\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
   9 {                                                                           }\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
  14 {                                                                           }\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
  20 {  USA                                                                      }\r
  21 {                                                                           }\r
  22 {This file incorporates work covered by the following copyright and         }\r
  23 {permission notice:                                                         }\r
  24 {                                                                           }\r
  25 {Copyright (C) 1990, 2009 - Apogee Software, Ltd.                           }\r
  26 {                                                                           }\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
  31 {                                                                           }\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
  35 {                                                                           }\r
  36 {See the GNU General Public License for more details.                       }\r
  37 {                                                                           }\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
  43 {  USA                                                                      }\r
  44 {                                                                           }\r
  45 {Original Source: 1990 Scott Miller                                         }\r
  46 {Prepared for public release: 03/19/09 - Joe Siegler, Apogee Software, Ltd. }\r
  47 {*/                                                                         }\r
  48 {//-------------------------------------------------------------------------}\r
  49 (*****************************************************************************)\r
  50 (*                                  ADPAR                                    *)\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
  56 \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
  70 \r
  71 {$IFDEF UNIX}\r
  72 procedure init_windows;\r
  73   var lang:string;\r
  74  begin\r
  75   nEcho(false);\r
  76   stdscr:=nscreen;\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   {writeln(nCols(stdscr),nRows(stdscr));}\r
  82  end;\r
  83 \r
  84 procedure WritePrompt(x,y:integer);\r
  85  begin\r
  86   { UTF-8 print }\r
  87   if UTF8Scr then\r
  88    { U+00BB, », C2 BB, RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK.}\r
  89    nFWrite(x,y,TextAttr,0,#$C2#$BB)\r
  90   else \r
  91    nFWrite(x,y,TextAttr,0,chr(187));\r
  92   refresh;\r
  93  end;\r
  94 \r
  95 {$ELSE}\r
  96 procedure nSetActiveWin(win:pwin);\r
  97  begin\r
  98   with win^ do\r
  99    window(x,y,x1,y1);\r
 100  end;\r
 101 \r
 102 procedure nWindow(var win : pwin; x,y,x1,y1 : integer);\r
 103  begin\r
 104   win^.x:=x;   win^.y:=y;\r
 105   win^.x1:=x1; win^.y1:=y1;\r
 106  end;\r
 107 \r
 108 procedure init_windows;\r
 109  begin\r
 110   stdscr:=@win_arr[1];\r
 111   win1:=@win_arr[2];\r
 112   win2:=@win_arr[3];\r
 113   nWindow(stdscr,1,1,80,25);\r
 114  end;\r
 115 \r
 116 procedure WritePrompt(x,y:integer);\r
 117  begin\r
 118   gotoxy(x,y);\r
 119   write(chr(175));\r
 120  end;\r
 121 {$ENDIF}\r
 122 \r
 123 function square_wave(time : Real):integer;\r
 124   var l:longint;\r
 125  begin\r
 126   l:=trunc(time);\r
 127   if time-l < 0.5 then square_wave:=0 \r
 128                   else square_wave:=1;\r
 129  end;\r
 130 \r
 131 {callback function to generate sound}\r
 132 procedure ProccessAudio(userdata: Pointer; stream: PUInt8; len: LongInt); cdecl;\r
 133   var i,j,k,step:integer;\r
 134  begin\r
 135   step:=audio_STEP;\r
 136   for i:=0 to trunc((len-1)/step) do begin\r
 137    \r
 138    if speaker_on then\r
 139     if sound_i > 0 then begin\r
 140      current_freq:=sound_Freqs[sound_play]/audio_freq;\r
 141      if current_freq=0 then current_freq:=1;\r
 142      sound_play:=sound_play+1;\r
 143      if sound_play > sound_i then begin\r
 144       speaker_on:=false; sound_i:=0; sound_play:=0; end;\r
 145     end;\r
 146 \r
 147    lasttime:=trunc(lasttime*lastfreq/current_freq);\r
 148    \r
 149    for j:=0 to step-1 do begin\r
 150     k:=i*step+j;\r
 151     if k<len then\r
 152      if speaker_on then\r
 153       stream[k]:=audio_VOLUME*square_wave(current_freq * (j+lasttime) )\r
 154      else\r
 155       stream[k]:=0;\r
 156    end;\r
 157 \r
 158    lasttime:=lasttime+step;\r
 159    lastfreq:=current_freq; \r
 160   end;\r
 161  end; \r
 162 \r
 163 function InitAudio:boolean;\r
 164   var Desired, Obtained: TSDL_AudioSpec;\r
 165  begin\r
 166   { Set up the requested settings }\r
 167   Desired.freq    := audio_FREQ;\r
 168   Desired.format  := AUDIO_U8;\r
 169   Desired.channels:= 1;\r
 170   Desired.samples := audio_SAMPLES;\r
 171   Desired.callback:= @ProccessAudio;\r
 172   Desired.userdata:= nil;\r
 173 \r
 174   if SDL_Init(SDL_INIT_AUDIO) = 0 then\r
 175    if SDL_OpenAudio(@Desired, @Obtained) = 0 then begin\r
 176 \r
 177     speaker_on:=false;\r
 178     current_freq:=1; lastfreq:=1;\r
 179     sound_ticks:=1;\r
 180     SDL_PauseAudio(0);\r
 181     InitAudio:=true;\r
 182    end \r
 183     else InitAudio:=false\r
 184   else\r
 185    InitAudio:=false;\r
 186  end;\r
 187 \r
 188 procedure InitScrKbd;\r
 189  begin\r
 190   buflen:=127;\r
 191   CheckBreak:=false;\r
 192   if initaudio then sound_supported:=true\r
 193    else begin\r
 194     WriteLn('SDL failed to initialize audio: ', SDL_GetError);\r
 195     sound_supported:=false;\r
 196    end;\r
 197   UTF8Scr:=false;\r
 198   init_windows;\r
 199   nWindow(win1,2,2,79,4);\r
 200   nWindow(win2,2,5,79,24);\r
 201   nsetActiveWin(stdscr);\r
 202  end;\r
 203 \r
 204 procedure DoneAudio;\r
 205  begin\r
 206   if sound_supported then begin\r
 207    SDL_CloseAudio;\r
 208    SDL_Quit;\r
 209   end;\r
 210  end;\r
 211 \r
 212 procedure DoneScrKbd;\r
 213  begin\r
 214   DoneAudio;\r
 215   nSetActiveWin(stdscr);\r
 216   clrscr;\r
 217  end;\r
 218 \r
 219 procedure sound( Hz: Integer );\r
 220  begin\r
 221   if sound_supported then begin\r
 222    sound_i:=0;\r
 223    current_freq:=Hz/audio_Freq;\r
 224    if current_freq > 0 then\r
 225     speaker_on:=true\r
 226    else\r
 227     current_freq:=1;\r
 228   end;\r
 229  end;\r
 230 \r
 231 procedure nosound;\r
 232  begin\r
 233   if sound_supported then begin\r
 234    if sound_i > 0 then begin\r
 235     speaker_on:=true;\r
 236     while speaker_on do;\r
 237    end else\r
 238     speaker_on:=false;\r
 239   end;\r
 240  end;\r
 241 \r
 242 procedure sounddelayed( Hz,step: Integer ); forward;\r
 243 \r
 244 procedure sounddelayed( Hz: Integer );\r
 245  begin\r
 246   sounddelayed( Hz, audio_STEP );\r
 247  end;\r
 248 \r
 249 procedure sounddelayed( Hz,step: Integer );\r
 250  begin\r
 251   if sound_supported then begin\r
 252    sound_ticks:=sound_ticks+1;\r
 253    if sound_ticks mod step = 0 then begin\r
 254      if sound_i < audio_MAXENTRIES then begin\r
 255       Sound_Freqs[sound_i]:=Hz;\r
 256       sound_i:=sound_i+1;\r
 257      end;\r
 258    end;\r
 259   end;\r
 260  end;\r
 261 \r
 262 procedure delay( MS: Integer);\r
 263  begin\r
 264   if sound_supported then\r
 265    SDL_delay(MS)\r
 266   else\r
 267 {$IFDEF UNIX}\r
 268    ocrt.delay(MS);\r
 269 {$ELSE}\r
 270    crt.delay(MS);\r
 271 {$ENDIF}\r
 272  end;\r
 273 \r
 274 procedure ReadLine(var S:String);\r
 275  var Ch: Char;\r
 276  begin\r
 277   Repeat\r
 278    Ch:=ReadKey;\r
 279    write(ch);\r
 280    if (buflen>0) and (ch<>Chr(13)) then begin\r
 281     S:=S+ch;\r
 282     buflen:=buflen-1;\r
 283    end;\r
 284   Until (Ch=chr(13));\r
 285   buflen:=127;\r
 286  end;\r
 287 \r
 288 procedure SF; begin SFlag:=True end;\r
 289 \r
 290 procedure Cur(Num:byte);\r
 291  begin\r
 292   case Num of  \r
 293 {$IFDEF UNIX}\r
 294    1:ncursor(cON);  { Underline   }\r
 295    2:ncursor(cBIG); { Solid block }\r
 296    3:nCursor(cOFF); { Invisible   }\r
 297 {$ELSE}\r
 298    1:cursoron;      { Underline   }\r
 299    2:cursorbig;     { Solid block }\r
 300    3:cursoroff;     { Invisible   }\r
 301 {$ENDIF}\r
 302   end;\r
 303  end;\r
 304 \r
 305 procedure Col(Num1,Num2:byte);\r
 306  begin if Color then textcolor(Num1) else textcolor(Num2) end;\r
 307 \r
 308 procedure Bak(Num1,Num2:byte);\r
 309  begin if Color then textbackground(Num1) else textbackground(Num2) end;\r
 310 \r
 311 procedure Bor(Num1,Num2:byte);\r
 312  begin\r
 313   {with Result do\r
 314    begin AX:=$B00;if Color then BX:=Num1 else BX:=Num2 end;intr($10,Result)}\r
 315  end;\r
 316 \r
 317 function  En(Num:byte):boolean;\r
 318  begin if Num in Events then En:=true else En:=false end;\r
 319 \r
 320 procedure Add(Num:byte);\r
 321  begin Events:=Events+[Num] end;\r
 322 \r
 323 procedure Min(Num:byte);\r
 324  begin Events:=Events-[Num] end;\r
 325 \r
 326 procedure Score(Num,pointer:integer);\r
 327  begin if not en(pointer)then begin Sc:=Sc+Num;Add(Pointer)end end;\r
 328 \r
 329 procedure Cn(s:str78);\r
 330  begin gotoxy(40-(length(s)div 2),wherey);write(s);gotoxy(1,wherey+1)end;\r
 331 \r
 332 procedure wCn(s:str78);\r
 333  begin gotoxy(39-(length(s)div 2),wherey);writeln(s);end;\r
 334 \r
 335 procedure Pause;\r
 336  begin col(15,15);write('Press any key to continue...');\r
 337   CFlag:=ReadKey;col(11,7);writeln;\r
 338  end;\r
 339 \r
 340 procedure Tune(Octave,Note,Duration:integer);\r
 341   var Frequency:real;\r
 342       i:integer;\r
 343  begin\r
 344   Frequency:=32.625;\r
 345   for i:=1 to Octave do\r
 346    Frequency:=Frequency*2;\r
 347   for i:=1 to Note-1 do\r
 348    Frequency:=Frequency*1.059463094;\r
 349   if Duration <> 0 then\r
 350    begin\r
 351     sound(round(Frequency));\r
 352     delay(Duration);\r
 353     nosound\r
 354    end\r
 355   else sound(round(Frequency));\r
 356  end;\r
 357 \r
 358 procedure Play(Start,Stop,Speed:integer);\r
 359   var x:integer;\r
 360  begin\r
 361   if Start<=Stop then\r
 362    for x:=Start to Stop do\r
 363     if Speed>0 then begin sound(x);delay(Speed)end\r
 364      else sounddelayed(x)\r
 365   else\r
 366    for x:= Start downto Stop do\r
 367     if Speed>0 then begin sound(x);delay(Speed)end\r
 368      else sounddelayed(x);\r
 369   if Speed>0 then begin\r
 370    nosound;if Region=4 then sound(20);if Region=5 then sound(60);\r
 371    end;\r
 372  end;\r
 373 \r
 374 procedure Explode(Duration:byte);\r
 375   var x:integer;\r
 376  begin for x:=Duration*999 downto 20 do sounddelayed(random(x));nosound end;\r
 377 \r
 378 procedure Walls(Duration:byte);\r
 379   var x:integer;\r
 380  begin for x:=1 to Duration*999 do sounddelayed(random(35)+20);nosound end;\r
 381 \r
 382 procedure Static;\r
 383   var x,y:integer;\r
 384  begin\r
 385   for x:=1 to 50 do\r
 386    case random(2) of\r
 387     0:for y:=1 to random(70)+10 do sounddelayed(random(4000)+3000);\r
 388     1:begin nosound;delay(random(29))end\r
 389    end;nosound;if Region=5 then sound(60)\r
 390  end;\r
 391 \r
 392 procedure Blast;\r
 393   var x:byte;\r
 394  begin\r
 395   for x:=1 to 40 do\r
 396    begin play(550-x*6,600+x*6,0);play(600+x*6,550-x*6,0)end;explode(2)\r
 397  end;\r
 398 \r
 399 procedure Dopen(Num:byte);\r
 400  begin writeln('The door slides open...');\r
 401   if Num<>0 then play(50,125-Num,Num)\r
 402   else begin for i:=3500 to 5000 do sounddelayed(random(4500)+i);nosound;end;\r
 403   if Region=5 then sound(60)\r
 404  end;\r
 405 \r
 406 procedure Dclose(Num:byte);\r
 407  begin writeln('The sliding door closes.');\r
 408   if Num<>0 then play(125-Num,50,Num)\r
 409   else begin for i:=5000 downto 3500 do sounddelayed(random(4500)+i);nosound;end;\r
 410   if Region=5 then sound(60)\r
 411  end;\r
 412 \r
 413 procedure Door(New,Num:byte);\r
 414  begin\r
 415   if en(7)then RL(22)else\r
 416   if en(8)then RL(23)else begin DOpen(Num);Move(New);DClose(Num)end\r
 417  end;\r
 418 \r
 419 procedure won; forward;\r
 420 \r
 421 procedure SoundTest;\r
 422   var ch:char;\r
 423  begin\r
 424 \r
 425   while true do begin\r
 426     \r
 427     writeln(' Sounds ');\r
 428     writeln(' 1. Won ');\r
 429     writeln(' 2. explode(32) ');\r
 430     writeln(' 3. Walls(12) ');\r
 431     writeln(' 4. Static ');\r
 432     writeln(' 5. Blast ');\r
 433     writeln(' 6. Dopen(10) ');\r
 434     writeln(' 7. Dclose(0) ');\r
 435     writeln(' Q. Quit ');\r
 436 \r
 437     ch:=readkey;\r
 438 \r
 439     if ch='q' then halt;\r
 440 \r
 441     case ch of\r
 442      '1' : Won;\r
 443      '2' : explode(32);\r
 444      '3' : Walls(12);\r
 445      '4' : Static;\r
 446      '5' : Blast;\r
 447      '6' : Dopen(10);\r
 448      '7' : DClose(0);\r
 449      '8' : begin\r
 450             for x:=1 to 20 do for y:=1 to x*8 do sounddelayed(x*9,trunc((168-y)/8)); nosound;\r
 451            end;\r
 452     end;\r
 453 \r
 454   end;\r
 455 \r
 456  end;\r
 457 \r
 458 procedure Time1;\r
 459  begin Tic:=Tic+1; Min(128); { <--Negates DEAD } col(13,15);\r
 460   for x:=1 to TMax do T[x]:=T[x]-1;\r
 461   if T[2]=1 then begin PStat:=PStat-[5];RL(1)end;\r
 462   case T[3] of { Hunger }\r
 463    25:begin PStat:=PStat+[2];RL(2)end;\r
 464    12:RL(3);\r
 465    4:begin Bor(4,7);RL(4)end;\r
 466    1:begin RL(124);DEAD;end\r
 467   end;\r
 468   case T[4] of { Thirst }\r
 469    22:begin PStat:=PStat+[6];RL(5)end;\r
 470    11:RL(6);\r
 471    4:begin Bor(4,7);RL(7)end;\r
 472    1:begin RL(125);DEAD;end\r
 473   end;\r
 474   case T[5] of { Sleep }\r
 475    32:begin PStat:=PStat+[5];RL(8)end;\r
 476    14:RL(9);\r
 477    5:begin Bor(4,7);RL(10)end;\r
 478    1:begin RL(126);DEAD;end;\r
 479    2..4,6..13:begin x:=random(29)+1;\r
 480           if(x in Inv)and not(x in Wear)then\r
 481            begin Van(x);R[x]:=Prm;\r
 482             writeln('A bout of weariness causes you to loose your grip on',\r
 483                     ' the ',FN(x),'!')\r
 484            end\r
 485          end\r
 486   end;\r
 487   case T[29] of { Laser Injury }\r
 488    9:RS(214);\r
 489    4:begin RL(507);Bor(4,7)end;\r
 490    2,3,5..8,10,11:begin repeat x:=random(27)+1 until x in[1..12,16..20,22..26,28];\r
 491      if(x in Inv)and not(x in Wear)then\r
 492       begin Van(x);R[x]:=Prm;\r
 493        if random(2)=0 then\r
 494         writeln('A sudden stab of pain shoots up your side, you drop the ',\r
 495                  FN(x),'.') else begin\r
 496         writeln('The ',FN(x),' falls from your grip as you almost collapse ',\r
 497                 'from the');writeln('extreme pain.')end\r
 498       end\r
 499      end;\r
 500    1:begin RS(215);DEAD;end\r
 501   end;\r
 502   case T[12] of  { Sickness }\r
 503    120,99,83,55:RL(207);\r
 504    65:begin PStat:=PStat+[3];RL(208)end;\r
 505    47:RL(209); 30:RS(73); 15:RS(74); 4:begin Bor(4,7);RS(75)end;\r
 506    1:begin RS(76);DEAD end;\r
 507    2,3,5..14,16..29:if(random(25)=0)and(Inv<>[])and not(en(125))then\r
 508           begin RS(232);\r
 509            for x:=1 to 29 do if(x in Inv)and not(x in Wear)then\r
 510             begin Van(x);R[x]:=Prm end\r
 511           end\r
 512   end;\r
 513   Col(10,7);\r
 514   if(Prm in[81..88])and(T[30]<1)and(random(4)=0)then\r
 515    if 28 in Wear then\r
 516     begin T[30]:=9;RS(153+Prm);\r
 517      for i:=999 to 2300 do sounddelayed(random(i*3)+i);\r
 518      for i:=3000 downto 20 do sounddelayed(random(i*4)+i*2);nosound\r
 519     end\r
 520    else\r
 521     begin\r
 522      write('A small droid appears from the ');\r
 523      case Prm of\r
 524       81:write('south'); 82:write('southwest'); 83:write('west');\r
 525       84:write('northwest'); 85:write('north'); 86:write('northeast');\r
 526       87:write('east'); 88:write('southeast')\r
 527      end; writeln(' section of the corridor and flies');\r
 528      RS(242);RS(243);for i:=20 to 3000 do sounddelayed(random(i*3)+i);nosound;\r
 529      delay(1500);DEAD\r
 530     end;\r
 531  end; { Time1 }\r
 532 \r
 533 procedure Time2A;\r
 534  begin col(10,7);  { Pre-Jungle Planet }\r
 535   case T[1] of\r
 536    19:MC(1,13,13,0);\r
 537    18:begin MC(1,8,8,1);MC(1,13,8,2)end;\r
 538    17:if en(19) then begin RS(9);T[1]:=11;end;\r
 539    11..16:if not(en(19))and(Prm=8)and(random(2)=1)then RL(0);\r
 540    10:MC(1,8,9,3);\r
 541    9:begin MC(1,9,0,4);T[1]:=Null;end;\r
 542    5..7:if(en(2))and(en(3))then begin RB2(5-(T[1]-3),10);col(10,7)end;\r
 543    4:if Prm=8 then begin T[1]:=11;RS(5)end;\r
 544   end;\r
 545   if(T[7]=1)then begin RS(35);DEAD;end;\r
 546   if(T[6]=2)and(en(7))then RL(140);\r
 547   if(T[6]=1)and(en(7))then begin RS(20);DEAD;end;\r
 548   case T[8] of { Lift-off countdown }\r
 549    5:RL(181); 4:RL(182); 3:RL(191); 2:RL(192);\r
 550    1:if en(10)then\r
 551       begin Min(10);Min(26);Min(27);Explode(32);\r
 552        sound(20);Bor(0,0);Score(10,122);\r
 553        n[84]:='reactor regulat\';\r
 554        RB(7,10);delay(9999);Pause;col(10,7);RS(43);PStat:=PStat-[2,5,6];\r
 555        Region:=4;T[3]:=150;T[4]:=125;T[5]:=230;T[8]:=0;T[9]:=1;T[10]:=5;end\r
 556      else begin RS(44);Explode(32);DEAD;end;\r
 557   end;\r
 558   if T[9]<1 then T[9]:=15;\r
 559   if(Region=4)and(Prm=1)and(T[9]=12)then RS(62);\r
 560   if T[10] in[1..4]then RL(194);\r
 561   if(Tic>3)and(Prm=8)and not(en(9))and not(en(7))then\r
 562    begin RS(6);Add(9)end else\r
 563   if(Tic>5)and(Prm=8)and(en(9))and not(en(16))and not(en(7))then\r
 564    begin RS(7);Add(16)end;\r
 565   case Prm of\r
 566     1:if(random(2)=0)and(T[9]>12)and(T[9]<15)and(Region=4)and not en(129)then\r
 567        begin RL(593);RL(594);Add(129)end\r
 568       else if(random(20)=0)and(Region=4)then RL(592);\r
 569     7:if random(5)=0 then RL(595);\r
 570     8:if random(3)=1 then RL(24)else if random(3)=1 then RL(178);\r
 571    15,17,19:case random(60) of\r
 572      1:RL(596);\r
 573      2:RL(597);\r
 574      3,4:if RC>40 then begin if T[4]>10 then T[4]:=10;RL(598)end;\r
 575      end; {case}\r
 576    20:if random(4)=1 then RL(25);\r
 577   end; {case}\r
 578   if Prm=SinkRm then begin RL(85);L[Prm]:=L[Prm]+[79];end;\r
 579 end; { Time2A }\r
 580 \r
 581 procedure Time2B;\r
 582  begin col(10,7);  { Jungle Planet }\r
 583   Maze:=not(Maze);\r
 584   if Prm in[42..49]then\r
 585    begin writeln('Some of the walls shift positions.');Walls(4);end;\r
 586   case Prm of\r
 587    7:if random(5)=0 then RL(595);\r
 588    26..29,32..34,59,60:case random(40) of\r
 589       0,1:RL(210); 2,3:RL(211); 4:RS(77); 5,6:RS(78); 7,8:RL(212);\r
 590       9:RL(213); 10:RL(214); 11:begin RL(215);play(6000,6001,20)end\r
 591      end;\r
 592    42..50:if random(7)=0 then RL(280);\r
 593   end; {case}\r
 594   if(Prm=28)and(random(2)=0)then RL(233);\r
 595   if Prm=SinkRm then begin RL(85);L[Prm]:=L[Prm]+[79];end;\r
 596   if T[11]=2 then RL(205);\r
 597   if T[11]=1 then begin RS(70);DEAD;end;\r
 598   if T[13]=1 then begin RB(11,10);for x:=1 to 3 do begin tune(4,2,200);\r
 599    delay(99);tune(4,5,200);delay(99)end;Pause end;\r
 600   if(T[14]=2)and(Prm in[40,41])then RL(251);\r
 601   if T[14]=1 then\r
 602    case Prm of 40:begin RL(249);Walls(8);end;41:begin RL(250);Walls(8);end end;\r
 603   if(T[15]=1)and(Prm=39)then begin RS(94);DEAD;end;\r
 604   if T[17]=4 then begin RS(109);DEAD;end;\r
 605   if T[17]=1 then begin Add(36);if Prm=56 then begin RS(110);Walls(8);end end;\r
 606   if T[18]=2 then begin RS(123);Walls(12)end;\r
 607   if(T[18]=1)and(Prm=53)then begin RS(124);Walls(12);DEAD;end;\r
 608   if T[19]=1 then begin RS(128);Walls(12);DEAD;end;\r
 609  end; { Time2B }\r
 610 \r
 611 procedure Time2C;\r
 612  begin col(11,7);  { Inner Planet }\r
 613   if T[20]=1 then\r
 614    case Prm of 73:DClose(20);66:begin RL(337);play(105,50,20)end end;\r
 615   col(10,7);\r
 616   if(Prm=74)and not(en(47))then\r
 617    writeln('There is something flashing on the computer''s screen.');\r
 618   if(Prm=73)and(CodeSet<>4)then begin\r
 619    writeln('There''s an alarm sound coming over the radio.');\r
 620    for x:=1 to 23 do\r
 621     begin\r
 622      for i:=450 to 999 do sounddelayed(i);\r
 623      for i:=999 downto 450 do sounddelayed(i);\r
 624     end;nosound\r
 625    end;\r
 626   case random(50) of\r
 627    1..3:if here(38)then RL(588);\r
 628    4,5:begin RL(589);Explode(3)end;\r
 629    6:begin RS(244);for x:=1 to 7 do Static;end\r
 630    else if(Prm in[64,73])and(random(9)=0)then begin RL(590);RL(591)end\r
 631   end;\r
 632  end; { Time2C }\r
 633 \r
 634 procedure Time2D;  { Planetship }\r
 635   function Warn(Message,IfTime,Said:integer):boolean;\r
 636    begin Warn:=false;\r
 637     if not en(Said)and(IfTime>=T[26])then\r
 638      begin if Said<>59 then begin Static;RS(Message);Static end\r
 639            else if Prm>99 then begin Static;RS(Message);Static end;\r
 640       if(Said=59)and(Prm<100)then begin end\r
 641       else begin Warn:=True;Add(Said)end\r
 642      end\r
 643    end; {Warn}\r
 644  begin col(11,7);\r
 645  for x:=0 to 2 do if T[23+x]>2 then Score(20,118+x); { 60 total points }\r
 646  if en(64)then Score(10,121);\r
 647   if T[21]=1 then\r
 648    case Prm of 91:DClose(20);86:begin RL(337);play(110,50,15)end end;\r
 649   col(10,7);\r
 650   if(Prm=95)and not(en(48))then begin\r
 651    writeln('A loud siren is sounding off...');\r
 652    play(300,530,6);delay(200);play(300,530,6)end;\r
 653   if(Prm=91)and not en(53)then begin writeln('An alarm is ringing...');\r
 654     for x:=1 to 23 do begin sound(400);delay(99);sound(940);delay(60);nosound;\r
 655    end end;\r
 656   if T[22]=1 then\r
 657    begin write('The door slides open...');play(50,60,65);\r
 658     writeln('then closes.');play(60,50,60);\r
 659     if en(50)then RS(153)else\r
 660     if Inv=[] then begin RS(247);RS(248)end\r
 661     else begin RS(154);RS(155);Inv:=[];end;\r
 662     delay(2500);write('The door slides open...');play(50,60,65);\r
 663     writeln('then closes.');play(60,50,65);\r
 664    end;\r
 665   case T[23] of\r
 666    13:begin if Prm=91 then RL(438);MC(2,91,91,161);Add(53)end;\r
 667    12:MC(2,91,91,162);\r
 668    11:begin if Prm in[86,91]then DOpen(15);MC(2,91,86,163);MC(2,86,86,164);\r
 669        if Prm in[86,91]then DClose(15)end;\r
 670    10:begin MC(2,86,87,165);MC(2,87,87,166)end;\r
 671    9:begin if Prm in[87,89]then DOpen(65);MC(2,87,89,167);MC(2,89,89,168);\r
 672       if Prm in[87,89]then DClose(65)end;\r
 673    7,8:if Prm=89 then begin ScrnSet:=4;RL(417)end;\r
 674    6:begin if Prm in[87,89]then DOpen(65);MC(2,89,87,169);MC(2,87,87,170);\r
 675       if Prm in[87,89]then DClose(65)end;\r
 676    5:begin MC(2,87,86,171);MC(2,86,86,172)end;\r
 677    4:if T[21]<2 then begin MC(2,86,91,173);if Prm in[86,91]then DOpen(15);\r
 678       if Prm=86 then RL(418);MC(2,91,91,174);if Prm in[86,91]then DClose(15)end\r
 679       else if Prm=86 then begin RL(418);MC(2,0,91,0)end;\r
 680    1:if Prm=91 then begin RL(419);Van(123);DClose(55)end else Van(123)\r
 681   end; {T[23]}\r
 682   if(T[23]>1)and(T[23]<4)and(Prm=91)then begin T[24]:=7;T[23]:=NULL;end;\r
 683   case T[24] of\r
 684    7:if Prm=91 then RS(175);\r
 685    6:if Prm=91 then begin RS(176);RS(177)end;\r
 686    5:if Prm=91 then begin RS(178);RS(179)end;\r
 687    4:begin if Prm=91 then RL(420);if not(1 in Inv)then T[24]:=2;end;\r
 688    2,3:if(Prm=91)and(1 in Inv)then RL(419+T[24]);\r
 689    1:begin Van(123);if Prm=91 then begin RS(180);DOpen(55);RL(418);\r
 690       DClose(55)end;\r
 691      end;\r
 692   end; {T[24]}\r
 693   case T[25] of\r
 694    2..5:if Prm=91 then RS(188-T[25]);\r
 695    1:begin if Prm=91 then RS(187);T[24]:=2;T[26]:=40;Add(64)end;\r
 696   end; {T[25]}\r
 697   if en(64)then\r
 698   if not Warn(198,38,54)then\r
 699   if not Warn(199,33,55)then\r
 700   if not Warn(203,30,59)then\r
 701   if not Warn(200,25,57)then\r
 702   if not Warn(201,20,58)then\r
 703   if not Warn(202,15,56)then\r
 704   if not Warn(204,10,60)then\r
 705   if not Warn(205,6,61)then\r
 706   if not Warn(206,3,62)then\r
 707   if not Warn(207,2,63)then begin end;\r
 708   if T[26]=1 then begin RS(197);DEAD;end;\r
 709   if(T[27]=1998)and(Prm=99)then  begin RS(213);Blast;DEAD;end;\r
 710   if(T[28]=1998)and(Prm=101)then begin RS(213);Blast;DEAD;end;\r
 711  end; { Time2D }\r
 712 \r
 713 procedure Directory;\r
 714 var\r
 715   SM1Found  : boolean;\r
 716   Info      : TSearchRec;\r
 717 begin\r
 718   {ChDir(Drive+':');}\r
 719   SM1Found:=false;\r
 720   writeln;\r
 721   if FindFirst ('*',faAnyFile,Info)=0 then\r
 722     repeat\r
 723       if length(Info.Name)>4 then\r
 724        if copy(Info.Name,length(Info.Name)-2,3)='sm1' then\r
 725         begin\r
 726          if not SM1Found then\r
 727           writeln('Here is a list of the SAVE/RESTORE files on the ',\r
 728                   'disk in drive ',up(Drive),':');\r
 729         SM1Found:=true;\r
 730         writeln('    * ',copy(Info.Name,1,length(Info.Name)-4));\r
 731        end;\r
 732     until FindNext(Info)<>0;\r
 733   \r
 734   FindClose(Info);\r
 735   writeln;\r
 736   if not SM1Found then\r
 737    begin\r
 738     writeln('There are not any SAVE/RESTORE files on the disk in drive ',\r
 739             up(Drive),':');writeln;\r
 740    end;\r
 741   Pause;{ChDir(Log+':');}\r
 742 end; {Directory}\r
 743 \r
 744 function Up(Word:Str130):Str1;\r
 745  begin word:=word+' ';\r
 746   if(Word[1]='l')and(Word[2]=' ')then insert('ook',Word,2);\r
 747   if(Word[1]='e')and(Word[2]='x')and(Word[3]=' ')then insert('amine',Word,3);\r
 748   delete(Word,length(word),2);Up:='';\r
 749   for x:=1 to length(Word) do Word[x]:=upcase(Word[x]);\r
 750   col(12,15); write(Word); col(11,7)\r
 751  end;\r
 752 \r
 753 procedure Spaces(var I:Str130);\r
 754  begin I:=concat(' ',I,' ')end;\r
 755 \r
 756 procedure QFormat(var I:Str130);\r
 757  begin\r
 758   if(I[1]='.')or(I[1]=' ')then delete(I,1,1);\r
 759   if(I[length(I)]='.')or(I[length(I)]=' ')then delete(I,length(I),1);\r
 760  end;\r
 761 \r
 762 procedure PreFormat(var I:Str130);\r
 763  procedure D(A:Str29;B:byte);\r
 764   begin while pos(A,I)<>0 do delete(I,pos(A,I),B)end;\r
 765  begin D('  ',1);QFormat(I);\r
 766   FFlag:=0; if(length(I)>0)then FFlag:=1;\r
 767   Spaces(I);\r
 768   Crawl:=false;if pos(' crawl ',I)>0 then Crawl:=true;D(' crawl ',6);\r
 769   D(' walk ',5);D(' run ',4);D(' go ',3);D(' travel ',7);\r
 770   QFormat(I); if(length(I)=0)and(FFlag=1)then FFlag:=2; Spaces(I);\r
 771   D(' of ',3);D(' the ',4);D(' very ',5);D(' more ',5);D(' and ',4);\r
 772   D(' large ',6);D(' big ',4);D(' huge ',5);D(' please ',7);\r
 773   D(' small ',6);D(' little ',7);D(' tiny ',5);\r
 774   D('''',1);D('#',1);D('!',1);D('?',1);D(' number ',7);\r
 775   QFormat(I); if(length(I)=0)and(FFlag=1)then FFlag:=3; Spaces(I);\r
 776   while pos('examine ',I)>0  do delete(I,pos('examine ',I)+2,5);\r
 777   while pos(' into ',I)>0    do delete(I,pos(' into ',I)+3,2);\r
 778   while pos(' onto ',I)>0    do delete(I,pos(' onto ',I)+3,2);\r
 779   while pos(' inside ',I)>0  do delete(I,pos(' inside ',I)+3,4);\r
 780   while pos(' within ',I)>0  do delete(I,pos(' within ',I)+1,4);\r
 781   while pos('look ',I)>0     do delete(I,pos('look ',I)+1,3);\r
 782   while pos('. ',I)>0        do delete(I,pos('. ',I)+1,1);\r
 783   while pos(',',I)>0         do\r
 784    begin insert(' ',I,pos(',',I));delete(I,pos(',',I),1)end;\r
 785   D('..',1);D(' .',1);D('  ',1);\r
 786   QFormat(I);\r
 787   if(length(I)=0)then\r
 788    begin EFlag:=Null;\r
 789     case FFlag of\r
 790      2:RL(193);\r
 791      3:RL(186)\r
 792      else writeln('Pardon me?')\r
 793     end;\r
 794    end\r
 795  end; { PreFormat }\r
 796 \r
 797 procedure LowerCase(var I:Str130);\r
 798  begin\r
 799   if(length(I)>0)then\r
 800    for x:=1 to length(I) do\r
 801     if(I[x] in['A'..'Z'])then\r
 802      I[x]:=chr(ord(I[x])+32);\r
 803  end; { LowerCase }\r
 804 \r
 805 procedure ChopSeven(var I:Str130);\r
 806   var Word:Str130;\r
 807  begin\r
 808   if(length(I)>0)then\r
 809    begin\r
 810     I:=I+' '; x:=1;\r
 811      repeat\r
 812       Word:='';\r
 813       while(I[x]<>' ')and(I[x]<>'.')and(I[x]<>',')do\r
 814        begin Word:=Word+I[x]; x:=x+1 end;\r
 815       if(length(Word)>7)then\r
 816        begin\r
 817         y:=pos(Word,I); x:=x+(7-length(Word));\r
 818         delete(I,y,length(Word)); delete(Word,8,130);\r
 819         insert(Word,I,y)\r
 820        end;\r
 821       x:=x+1;\r
 822      until(x-1)=length(I);\r
 823     delete(I,length(I),1)\r
 824    end\r
 825   end; { ChopSeven }\r
 826 \r
 827 procedure FindMood(var input:Str130;var Word:Str29;var Md:byte);\r
 828   var Temp1:Str53;\r
 829       Temp2:Str29;\r
 830       Counter:char;\r
 831  begin\r
 832   Spaces(input);x:=0;\r
 833   while x < AMax do\r
 834    begin x:=x+1;\r
 835     Counter:='1';\r
 836     Temp1:=A[x];\r
 837     while pos(Counter,Temp1)>0 do\r
 838      begin\r
 839       Temp2:=copy(Temp1,1,pos(Counter,Temp1)-1);\r
 840       if(pos(' '+Temp2+' ',input)>0)then\r
 841        begin\r
 842         Word:=Temp2;\r
 843         Md:=x;if Md=2 then Md:=1;\r
 844         x:=AMax;Counter:='8';\r
 845         delete(input,pos(Temp2,input),length(Temp2)+1);\r
 846        end;\r
 847       delete(Temp1,1,pos(Counter,Temp1));\r
 848       Counter:=succ(Counter);\r
 849      end;\r
 850    end;\r
 851   QFormat(input);\r
 852  end; { FindMood }\r
 853 \r
 854 function FN(VNP:byte) : Str29; { ( Finds first Noun ) }\r
 855   var Temp:Str29;\r
 856  begin SF;\r
 857   Temp:=n[VNP];\r
 858   FN:=copy(Temp,1,pos('\',Temp)-1);\r
 859  end; { FW }\r
 860 \r
 861 function Here(Obj:byte) : Boolean;\r
 862  begin Here:=false;\r
 863   if Obj in L[Prm] then Here:=true;\r
 864   if(Obj=79)and(MugCon=79)and(29 in Inv)then Here:=true;\r
 865   if Obj<=MMax then if(R[Obj]=Prm)or(Obj in Inv)then Here:=true;\r
 866   if(Obj=58)and((3 in Inv)or(4 in Inv)or(R[4]=Prm)or(R[3]=Prm))then Here:=true;\r
 867  end;\r
 868 \r
 869 function Present : Boolean;\r
 870   label JUMP;\r
 871  begin Present:=false; x:=0;\r
 872   if not(Vb in [17,18,37,39]) then\r
 873    if N1<>Null then\r
 874     if Here(N1) then\r
 875      if N2<>Null then\r
 876       if Here(N2) then Present:=true\r
 877       else writeln('You can''t see any ',FN(N2),' here.')\r
 878      else Present:=true\r
 879     else writeln('You can''t see any ',FN(N1),' here.')\r
 880    else Present:=true\r
 881   else\r
 882    begin JUMP: x:=x+1;\r
 883     if x<=NMax then\r
 884      if x in NounSet then\r
 885       if Here(x) then goto JUMP\r
 886       else begin writeln('You can''t see any ',FN(x),' here.');end\r
 887      else goto JUMP\r
 888     else Present:=true\r
 889    end\r
 890  end; { Present }\r
 891 \r
 892 procedure Convert(var n:byte;Max:byte);\r
 893  begin\r
 894   case Max of\r
 895    1:case n of                     { Verbs }\r
 896       12:n:=11; 14:n:=13; 23:n:=22; 27:n:=26;\r
 897       29:n:=28; 34:n:=33; 36:n:=35; 38:n:=37; 40:n:=39; 43:n:=42; 45:n:=44;\r
 898       52:n:=51; 55:n:=54; 57,58:n:=56; 60,61:n:=59; 63:n:=62;\r
 899      end;\r
 900    2:case n of                     { Nouns }\r
 901       13..15:n:=12; 21:n:=20; 33:n:=32; 36:n:=35; 39:n:=38; 45:n:=44;\r
 902       50:n:=49; 53:n:=52; 65:n:=64; 67:n:=66; 70:n:=69; 76,77:n:=75;\r
 903       97:n:=96; 101,102:n:=100; 114:n:=113; 117:n:=116; 63:n:=62;\r
 904       27:n:=26; 57:n:=56; 61:n:=60; 91:n:=90; 105..108:n:=109; 31:n:=28;\r
 905       133:n:=46; 84:if Prm>21 then n:=128; 115:if Prm=28 then n:=112;\r
 906       58:if Prm=52 then n:=64;\r
 907      end;\r
 908    3:case n of                  { Prepositions }\r
 909        2:n:=1; 4:n:=3; 8:n:=7 ;\r
 910      end;\r
 911   end;\r
 912  end; { Convert }\r
 913 \r
 914 procedure FindWord( var I    : Str130;   { input string }\r
 915                     var VNP  : byte;     { flags which # word found }\r
 916                     var Word : Str29;    { stores last word found }\r
 917                         Max  : byte);    { check which list? }\r
 918   const Slash = '\';\r
 919   var j,ps:byte;\r
 920       Temp1,Temp2:Str29;\r
 921  begin\r
 922   QFormat(I); Spaces(I); J:=0;\r
 923   while (j<m[Max]) do\r
 924    begin\r
 925     j:=j+1;\r
 926     case Max of 1:Temp1:=v[j]; 2:Temp1:=n[j]; 3:Temp1:=p[j] end;\r
 927     ps:=pos(Slash,Temp1);\r
 928     while ps>0 do\r
 929      begin\r
 930       Temp2:=copy(Temp1,1,ps-1);\r
 931       if(copy(I,1,length(Temp2)+2)=' '+Temp2+' ')then\r
 932        begin { Match Found }\r
 933         VNP:=j;\r
 934         Convert(VNP,Max);\r
 935         Word:=Temp2;\r
 936         delete(I,1,length(Temp2)+1);\r
 937         case Max of 1:VStr:=Word; 2:NStr:=Word end;\r
 938         j:=m[Max];\r
 939         Temp1:='X';\r
 940        end;\r
 941       delete(Temp1,1,ps);\r
 942       ps:=pos(Slash,Temp1);\r
 943      end;\r
 944    end; { main loop }\r
 945   QFormat(I);\r
 946  end; { FindWord }\r
 947 \r
 948 procedure Dictionary(IfFound,SkipList:byte);\r
 949   var StopLoopFlag:byte;\r
 950  begin VNP:=Null; list:=1; StopLoopFlag:=1;\r
 951   while(list<4)and(StopLoopFlag=1)do\r
 952    begin\r
 953     if list=SkipList then list:=list+1\r
 954      else\r
 955       begin\r
 956        FindWord(input,VNP,Word,list);\r
 957        if(VNP<>Null)then\r
 958         begin EFlag:=IfFound;list:=list-1;StopLoopFlag:=0;end;\r
 959        list:=list+1;\r
 960       end\r
 961    end;\r
 962   if(EFlag<>IfFound)then\r
 963   begin\r
 964    EFlag:=5;input:=input+' ';\r
 965    Word:=copy(input,1,pos(' ',input)-1);\r
 966    if(pos(' '+Word+' ',' top directi next some from is under underne '+\r
 967                         'leaning but speak pay ')>0)then\r
 968     EFlag:=IfFound\r
 969    else If Word[1] in['0','1','2','3','4','5','6','7','8','9'] then EFlag:=17;\r
 970    if IfFound=14 then EFlag:=14;\r
 971    QFormat(input);\r
 972   end;\r
 973  end; { Dictionary }\r
 974 \r
 975 procedure RL(Pointer:Integer);\r
 976  begin SF;\r
 977   if(pointer<>StoreL)then\r
 978    begin StoreL:=pointer;\r
 979     seek(L1,pointer);\r
 980     read(L1,Text3)\r
 981    end;\r
 982   writeln(Text3);\r
 983  end; { Read Line }\r
 984 \r
 985 procedure RS(Pointer:Integer);\r
 986  begin SF;\r
 987   if(pointer<>StoreS)then\r
 988    begin StoreS:=pointer;\r
 989     seek(S1,pointer);\r
 990     read(S1,Text4)\r
 991    end;\r
 992   writeln(Text4);\r
 993  end; { Read Special }\r
 994 \r
 995 procedure RR(Pointer:integer);\r
 996  begin SF;\r
 997   if(pointer<>StoreR)then\r
 998    begin StoreR:=pointer;\r
 999     seek(R1,pointer);\r
1000     seek(R2,pointer);\r
1001     read(R1,Text1);\r
1002     read(R2,Text2);\r
1003    end;\r
1004   write(Text1);\r
1005   writeln(Text2);\r
1006  end; { Read Room }\r
1007 \r
1008 procedure RB(Pointer,Colour:byte);\r
1009   var Block:Str255;\r
1010       Tstart,TStop:Str19;\r
1011  begin SF; Col(Colour,7);\r
1012   str(Pointer-1,TStart);\r
1013   str(Pointer,TStop);\r
1014   TStart:='('+TStart+')';\r
1015   TStop:='('+TStop+')';\r
1016   if old>=Pointer then reset(T1);\r
1017   old:=Pointer+1;\r
1018   repeat readln(T1,Block) until Block=TStart;\r
1019   repeat\r
1020    readln(T1,Block);\r
1021    if(Block<>TStop)then writeln(Block)\r
1022   until Block=TStop; col(11,7);\r
1023  end;\r
1024 \r
1025 procedure RB2(Pointer,Colour:byte);\r
1026   var Block:Str255;\r
1027       Tstart,TStop:Str19;\r
1028  begin SF; Col(Colour,7);\r
1029   str(Pointer-1,TStart);\r
1030   str(Pointer,TStop);\r
1031   TStart:='('+TStart+')';\r
1032   TStop:='('+TStop+')';\r
1033   if old2>=Pointer then reset(T2);\r
1034   old2:=Pointer+1;\r
1035   repeat readln(T2,Block) until Block=TStart;\r
1036   repeat\r
1037    readln(T2,Block);\r
1038    if(Block<>TStop)then writeln(Block)\r
1039   until Block=TStop; col(11,7);\r
1040  end;\r
1041 \r
1042 procedure Won;\r
1043   const W=800;H=400;Q=200;T=131;\r
1044   label JUMP;\r
1045  begin writeln;\r
1046   gotoxy(1,20);for x:=1 to 5 do\r
1047    begin writeln;delay(99);sound(x*50);Bor(x,7)end;\r
1048   gotoxy(1,15);col(4,15);bak(1,7);\r
1049   writeln('#######################################',\r
1050           '#######################################');\r
1051   delay(99);sound(300);Bor(6,0);\r
1052   gotoxy(1,16);for x:=1 to 3 do begin\r
1053   write('#                                      ',\r
1054         '                                      #');\r
1055         delay(99);sound(300+(x*50));Bor(x+8,15)end;gotoxy(1,19);\r
1056   write('#######################################',\r
1057         '#######################################');\r
1058   delay(99);sound(500);Bor(14,0);\r
1059   gotoxy(26,17);col(31,31);\r
1060   write('Y O U   H A V E   W O N ! !');delay(99);sound(550);\r
1061   gotoxy(1,20);bak(0,0);Bor(2,7);writeln;delay(99);nosound;\r
1062   for x:=1 to 12 do begin writeln;delay(80)end;\r
1063   gotoxy(1,9);Col(9,9);\r
1064   writeln('                              S U P E R N O V A');writeln;Col(11,7);\r
1065   writeln('     Programmed by . . . . . . . . . . . . . . . . . . . . . Scott Miller');\r
1066   writeln('     Story by  . . . . . . . . . . . . . . . . . . . . . . . Scott Miller');\r
1067   writeln('     Additional story development. . . . . . . . . . . . . . . Terry Nagy');\r
1068   writeln;writeln;\r
1069   Vb:=78;Call13;writeln;writeln;Col(3,7);\r
1070   write('Press any hey to quit...');\r
1071   tune(2,8,q);tune(2,8,q);tune(3,1,w);\r
1072   repeat\r
1073    tune(2,8,q);tune(2,8,q);\r
1074    tune(3,1,h);tune(2,12,h);tune(2,10,h);tune(2,8,q);tune(2,8,q);\r
1075    tune(3,1,w);tune(2,8,t);tune(2,8,t);tune(2,8,t);\r
1076    if keypressed then goto JUMP;\r
1077    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
1078    tune(3,3,w);\r
1079    if keypressed then goto JUMP;\r
1080    tune(2,10,q);tune(2,10,q);\r
1081    tune(3,3,h);tune(3,1,h);tune(2,12,h);tune(2,10,q);tune(2,10,q);\r
1082    if keypressed then goto JUMP;\r
1083    tune(3,3,w);tune(2,10,t);tune(2,10,t);tune(2,10,t);\r
1084    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
1085    tune(3,1,w);\r
1086   until keypressed;\r
1087   JUMP: CFlag:=ReadKey;\r
1088   DoneScrKbd;\r
1089   window(1,1,80,25);clrscr;gotoxy(2,2);Col(31,31);Bor(0,0);Cur(1);Bak(2,0);\r
1090   writeln('Congratulations!');\r
1091   HALT;\r
1092  end; { Won }\r
1093 \r
1094 procedure PlayerInput(var LINE:Str130);\r
1095   label JUMP;\r
1096   var Ch : Char;\r
1097       ExtCode : integer;\r
1098   procedure Key(k:Str19); begin Line:=Line+k;QFlag:=true;write(k)end;\r
1099  begin\r
1100  {with Result do begin}\r
1101   WRITELN; { Main Space In Game }\r
1102   if(length(Line)=0)then\r
1103    begin\r
1104     nSetActiveWin(win1);\r
1105     bak(4,7);col(14,0);\r
1106     gotoxy(7,1);write(Tic,'   ');\r
1107     gotoxy(34-(length(RN[Prm])div 2),1);\r
1108       write('      ',RN[Prm],'      ');\r
1109     gotoxy(74,1);write('    ');gotoxy(74,1);write(Sc,' ');\r
1110     bak(7,7);\r
1111     col(1,0);gotoxy(21,2);\r
1112     if PStat=[] then write('Healthy') else write('  *    ');\r
1113     col(15,0);gotoxy(32,2);\r
1114     if 2 in PStat then begin col(31,16);write('Hungry')end\r
1115     else write(' *    ');\r
1116     col(4,0);gotoxy(42,2);\r
1117     if 3 in PStat then begin col(20,16);write('Sick')end\r
1118     else write(' *  ');\r
1119     col(0,0);gotoxy(50,2);\r
1120     if 4 in PStat then begin col(16,16);write('Injured')end\r
1121     else write('   *   ');\r
1122     col(6,0);gotoxy(61,2);\r
1123     if 5 in PStat then begin col(22,16);write('Tired')end\r
1124     else write('  *  ');\r
1125     col(5,0);gotoxy(70,2);\r
1126     if 6 in PStat then begin col(21,16);write('Thirsty')end\r
1127     else write('   *   ');\r
1128     nSetActiveWin(win2);bak(0,0);\r
1129     if en(66)then begin gotoxy(1,20);goto JUMP;end;\r
1130     gotoxy(1,20);col(28,31);writeln;\r
1131     WritePrompt(1,19);\r
1132     Cur(1);\r
1133     col(14,7);gotoxy(3,19);\r
1134     QFlag:=false;\r
1135     repeat\r
1136      Ch:=Readkey;\r
1137      { Read Extended (Scan) Code }\r
1138      if Ch = #0 then ExtCode:=Ord(Readkey);\r
1139      sounddelayed(99,1);speaker_on:=true;delay(1);case Region of 4:sound(20);5:sound(60)end;\r
1140      case Ch of\r
1141      ^h:begin\r
1142         if(wherex=1)and(wherey=20)then\r
1143            begin gotoxy(78,wherey-1); ClrEol; end else\r
1144          if length(Line)>0 then write(^h,' ',^h);\r
1145          delete(Line,length(Line),2);\r
1146         end;\r
1147      ^m:QFlag:=true\r
1148      else\r
1149       begin\r
1150        if(Ord(Ch)>0)and(length(Line)<110)then\r
1151         begin write(Ch);Line:=Line+Ch;end\r
1152        else { read scan }\r
1153         begin\r
1154          case ExtCode of\r
1155           59:key('Save');      71:key('Northwest');\r
1156           60:key('Restore');   73:key('Northeast');\r
1157           61:key('R D');       79:key('Southwest');\r
1158           62:key('Look');      81:key('Southeast');\r
1159           63:key('Get all');   82:key('Down');\r
1160           64:key('Drop all');  83:key('Up');\r
1161           65:key('Score');     104:begin QFlag:=true;RR(0)end;\r
1162           66:key('Inventory');\r
1163           67:key('Wait');\r
1164           68:begin Line:='';key('Repeat')end;\r
1165           94,30:key('by Scott Miller');\r
1166           95,47:key('Version A Dec 9, 85');\r
1167           31:SoundTest;\r
1168          end;\r
1169         if Prm in[1..7] then\r
1170          case ExtCode of\r
1171           72:key('Fore'); 75:key('Port'); 77:key('Starboard'); 80:key('Aft')\r
1172          end\r
1173         else\r
1174          case ExtCode of\r
1175           72:key('North'); 75:key('West'); 77:key('East'); 80:key('South')\r
1176          end\r
1177        end\r
1178       end\r
1179      end; {case}\r
1180      until QFlag=true;\r
1181     Cur(3);\r
1182     col(5,7);WritePrompt(1,19);col(11,7);gotoxy(1,20);\r
1183     if length(Line)>76 then writeln;\r
1184     LowerCase(Line);Spaces(Line);\r
1185     if(pos(' r ',Line)>0)or(pos(' repeat ',Line)>0)then PreFormat(Line);\r
1186     if(Line='r')or(Line='repeat')then Line:=Again else Again:=Line;\r
1187     Spaces(Line);\r
1188     while pos(' then ',Line)>0 do\r
1189      begin\r
1190       x:=pos(' then ',Line);delete(Line,x,5);insert('.',Line,x)\r
1191      end;\r
1192     ChopSeven(Line);\r
1193     PreFormat(Line);\r
1194    end;\r
1195    if(pos('.',Line)>0)then\r
1196     begin    { SEPERATES LINE INTO SINGLE INPUTS }\r
1197      input:=copy(Line,1,pos('.',Line));\r
1198      delete(Line,1,pos('.',Line));\r
1199      delete(input,pos('.',input),1);\r
1200      PreFormat(input);\r
1201     end\r
1202    else\r
1203     begin\r
1204      input:=Line; Line:='';\r
1205     end; { END OF LINE SEPERATION }\r
1206    Spaces(input);\r
1207    while pos(' it ',input)>0 do\r
1208     begin x:=pos(' it ',input)+1;delete(input,x,2);insert(LastNoun,input,x);\r
1209      PreFormat(input);ChopSeven(input);\r
1210     end;\r
1211    while pos(' them ',input)>0 do\r
1212     begin x:=pos(' them ',input)+1;delete(input,x,4);insert(LastNoun,input,x);\r
1213      PreFormat(input);ChopSeven(input);\r
1214     end;\r
1215    QFormat(input);\r
1216    col(11,7);\r
1217    JUMP:\r
1218  {end;} { of with statement }\r
1219  end; { PlayerInput }\r
1220 \r
1221 procedure Title;\r
1222 {$IFDEF UNIX}\r
1223  var win:pwindow;\r
1224 {$ENDIF}\r
1225  begin\r
1226   clrscr;textcolor(7);Color:=true;\r
1227   if ParamCount=0 then begin\r
1228    write('Do you want ');textcolor(15);write('C');textcolor(7);\r
1229    write('olor or ');textcolor(15);write('B');textcolor(7);\r
1230    write('lack and white? ');textcolor(15); CFlag:=ReadKey;\r
1231    if(upcase(CFlag)='B')or(upcase(CFlag)='M')then\r
1232     begin Color:=false;write('Monochrome')end\r
1233    else write('Color');delay(300);\r
1234   end\r
1235   else\r
1236    begin input:=ParamStr(1);CFlag:=input[1];\r
1237     if(CFlag='/')and(length(input)>1)then CFlag:=input[2];\r
1238     if(upcase(CFlag)='B')or(upcase(CFlag)='M')then\r
1239      begin Color:=false;writeln('Monochrome screen option...')end\r
1240     else writeln('Color screen option...');delay(999)\r
1241    end;\r
1242   clrscr;textmode(BW80);\r
1243   Cur(3);\r
1244 \r
1245                  {**** Public Domain title screen ****}\r
1246   {Col(9,9);gotoxy(1,1);\r
1247   cn('S U P E R N O V A');\r
1248   Col(9,7);gotoxy(1,3);\r
1249   cn('Published by');\r
1250   gotoxy(1,5);\r
1251   cn('APOGEE SOFTWARE PRODUCTIONS');\r
1252   writeln;\r
1253   Col(11,7);\r
1254   cn('This game is placed in the public domain for your enjoyment.   Please do');\r
1255   cn('not abuse this product or the author''s rights.');\r
1256   writeln;\r
1257   cn('If you enjoy this game the author asks that you contribute $10 (by check).');\r
1258   cn('This payment  will encourage the author  to create similar games  and will');\r
1259   cn('help compensate him  for the several years work that went into  Supernova.');\r
1260   cn('This fee will also register the payer for telephone support and clues.');\r
1261   writeln;\r
1262   Col(14,15);\r
1263   writeln('Please make checks payable to:  Scott Miller');\r
1264   writeln;\r
1265   writeln('Scott Miller      (214) 240-0614');\r
1266   writeln('4206 Mayflower Drive');\r
1267   writeln('Garland, TX 75043');\r
1268   writeln;\r
1269   writeln('Also call for help:  Terry Nagy  (214) 271-3065');\r
1270   writeln;\r
1271   Col(11,7);delay(7000);\r
1272   cn('Thanks, enjoy the game...');\r
1273 \r
1274   Col(7,7);gotoxy(27,25);delay(999);\r
1275   write('Press any key to continue.');repeat;delay(1);until keypressed;\r
1276   CFlag:=ReadKey;}bak(1,0);clrscr;\r
1277                  {**** Main SUPERNOVA title screen ****}\r
1278 \r
1279   Bor(1,0);Col(15,15);Bak(4,0);\r
1280 {$IFDEF UNIX}\r
1281   nWindow(win,1,1,80,24);\r
1282   nFrame(win);\r
1283 {$ELSE}\r
1284   for x:=1 to 80 do\r
1285    begin gotoxy(x,1);write(chr(205));gotoxy(x,24);write(chr(205))end;\r
1286   for y:=1 to 24 do\r
1287    begin gotoxy(1,y);write(chr(186));gotoxy(80,y);write(chr(186))end;\r
1288   gotoxy(1,1);write(chr(201)); gotoxy(80,1);write(chr(187));\r
1289   gotoxy(1,24);write(chr(200)); gotoxy(80,24);write(chr(188));\r
1290 {$ENDIF}\r
1291   Bak(1,0);\r
1292   Col(2,7);gotoxy(1,10);cn('Copyright 1987 Scott Miller');\r
1293   Col(14,7);gotoxy(1,12);cn('Version B');\r
1294   Col(7,7);gotoxy(1,15);\r
1295   cn('Programmed by Scott Miller');\r
1296   cn('Story by Scott Miller and Terry Nagy');\r
1297   gotoxy(1,23);Col(3,7);\r
1298   cn('Press any key to continue.');\r
1299   repeat\r
1300    gotoxy(32,8);\r
1301    if Color then textcolor(random(16))\r
1302    else case random(3) of  0:textcolor(0); 1:textcolor(7); 2:textcolor(15)end;\r
1303    write('S U P E R N O V A');\r
1304    delay(1);\r
1305   until keypressed;\r
1306   CFlag:=ReadKey;\r
1307 {$IFDEF UNIX}\r
1308   nSetActiveWin(stdscr);\r
1309   nDelWindow(win);\r
1310 {$ENDIF}\r
1311   if Color then textmode(C80)else textmode(BW80);\r
1312  end; { Title }\r
1313 \r
1314 procedure Init1;\r
1315   label Abort;\r
1316  begin ABORT:\r
1317   Bor(0,0);bak(0,0);clrscr;nosound;\r
1318   Cur(3);randomize;\r
1319   GetDir(0,Word);Log:=Word[1];\r
1320   for x:=1 to 20 do begin sound(x*9);delay(x*2)end;nosound;\r
1321   gotoxy(1,9);y:=0;col(14,7);Identity:='';\r
1322   Cn('Please enter your identity code name:');col(12,15);\r
1323   repeat begin i:=random(maxint); delay(1) end; until keypressed;\r
1324   repeat CFlag:=ReadKey;\r
1325    if(CFlag<>chr(13))then\r
1326     if(CFlag<>^h)then Identity:=Identity+upcase(CFlag)\r
1327     else delete(Identity,length(Identity),2);\r
1328    gotoxy(1,11);Cn(' '+Identity+' ');\r
1329 {sound(50);delay(50);nosound;}\r
1330    for x:=1 to 50 do sounddelayed(50,1); nosound;\r
1331   until CFlag=chr(13);\r
1332   col(10,7);gotoxy(1,7);\r
1333   if identity<>'' then\r
1334    Cn(' IDENTITY CODE ACCEPTED--YOU MAY PROCEED '+Identity)\r
1335   else begin\r
1336    col(25,31);Bor(4,7);Cn('IDENTITY CODE REJECTED--ABORTING SEQUENCE')end;\r
1337   LowerCase(Identity);ChopSeven(Identity);\r
1338   delay(1500);\r
1339   if Identity='' then goto ABORT;\r
1340   assign(L1,'L1');\r
1341   assign(C1,'C1');\r
1342   assign(S1,'S1');\r
1343   assign(R1,'R1');assign(R2,'R2');\r
1344   assign(T1,'SM');assign(T2,'B1');\r
1345   reset(R1);reset(R2);\r
1346   reset(S1);reset(L1);reset(C1);\r
1347  end; { Init1 }\r
1348 \r
1349 procedure Init2;\r
1350  begin\r
1351   col(7,15);bak(1,7);\r
1352 {$IFDEF UNIX}\r
1353   nFrame(stdscr);\r
1354   nWriteAC(stdscr,1,4,TextAttr,nLT);\r
1355   nWriteAC(stdscr,nCols(stdScr),4,TextAttr,nRT);\r
1356   nrefresh(stdscr);\r
1357 {$ELSE}\r
1358   for x:=1 to 80 do\r
1359    begin gotoxy(x,1);write(chr(205));gotoxy(x,24);write(chr(205))end;\r
1360   gotoxy(80,24);write(chr(190));gotoxy(1,24);write(chr(212));\r
1361   gotoxy(1,4);InsLine;\r
1362   for x:=2 to 24 do\r
1363    begin gotoxy(1,x);write(chr(179));gotoxy(80,x);write(chr(179))end;\r
1364   gotoxy(1,4);write(chr(198));for x:=2 to 79 do\r
1365    begin gotoxy(x,4);write(chr(205))end;write(chr(181));\r
1366   gotoxy(1,1);write(chr(213));gotoxy(80,1);write(chr(184));\r
1367 {$ENDIF}\r
1368   nSetActiveWin(win1);\r
1369   bak(4,7);col(14,0);gotoxy(1,1);\r
1370   for x:=1 to 78 do write(' ');\r
1371    gotoxy(1,1);write('Move');\r
1372   gotoxy(67,1);write('Score');\r
1373   bak(7,7);gotoxy(1,2);\r
1374   for x:=1 to 78 do write(' ');\r
1375   bak(5,7);col(15,0);\r
1376   gotoxy(1,2);write('Player Condition:');\r
1377   col(7,15);bak(1,7);\r
1378 {$IFDEF UNIX}\r
1379   gotoxy(1,3);whLine(win1,nHL,nCols(stdScr)-2);\r
1380   nRefresh(win1);\r
1381 {$ENDIF}\r
1382   nSetActiveWin(win2);\r
1383   bak(0,0);\r
1384   gotoxy(1,10);col(14,7);\r
1385   wcn('Working 14 hours a day in the core of some dusty, smelly mine');\r
1386   wcn('is not your idea of the perfect lifestyle.');\r
1387   wcn('Barre-An is a dust ball in space, its only salvation being that it is');\r
1388   wcn('rich in precious barre-an metal.  Or used to be.  Nowadays the mines');\r
1389   wcn('don''t seem so generous, which is why you''re looking for a more');\r
1390   wcn('profitable venture.');\r
1391   wcn('A break, that''s all you ask for, maybe today you figure...');\r
1392   writeln;\r
1393  end; { Init2 }\r
1394 \r
1395 procedure Init3;\r
1396  begin\r
1397   Line    :='';\r
1398   Again   :='z';\r
1399   LastNoun:='mug';\r
1400   Vb      :=Null;\r
1401   Prm     :=8;\r
1402   Sc      :=0;\r
1403   Tic     :=0;\r
1404   PStat   :=[6];\r
1405   Events  :=[];\r
1406   for o   :=1 to MMax do r[o]:=Null;\r
1407   Inv     :=[3,8];\r
1408   Mov     :=[1..29];\r
1409   AlienRm :=Null;\r
1410   FriendRm:=91;\r
1411   Brief   :=[];\r
1412   Wear    :=[];\r
1413   MugCon  :=99;\r
1414   FoodCon :=4;\r
1415   SatchCon:=6;\r
1416   HolstCon:=Null;\r
1417   NicheCon:=Null;\r
1418   SinkRm  :=Null;\r
1419   PyraCon :=Null;\r
1420   Serum   :=Null;\r
1421   HingeCon:=9;\r
1422   PodumCon:=18;\r
1423   RobotCon:=12;\r
1424   Socket  :=[22..25];\r
1425   CodeSet :=7;\r
1426   ScrnSet :=1;\r
1427   Floor   :=1;\r
1428   Region  :=1;\r
1429   TFlag   :=1;\r
1430   Old     :=250;\r
1431   Old2    :=Old;\r
1432   Maze    :=true;\r
1433   Drive   :='A';\r
1434   StoreR:=-1;StoreS:=-1;StoreL:=-1;StoreC:=-1;{ Stores Last Read File Number }\r
1435   Dir[1]:='NORTH';Dir[2]:='SOUTH';Dir[3]:='EAST';Dir[4]:='WEST';\r
1436   Dir[5]:='NORTHEAST';Dir[6]:='NORTHWEST';\r
1437   Dir[7]:='SOUTHEAST';Dir[8]:='SOUTHWEST';\r
1438   m[1]:=VMax;m[2]:=NMax;m[3]:=PMax;\r
1439   for x   :=1 to TMax do T[x]:=Null;\r
1440   T[2]    :=0;\r
1441   T[3]    :=70;  { Hunger }\r
1442   T[4]    :=26;  { Thirst }\r
1443   T[5]    :=85; { Sleep (No relation to the T[2] sleep timer!) }\r
1444   NoNounOnly  :=[1..8,15,16,30,77..79,82,85..87,95];\r
1445   OneNounMaybe:=[9..14,25,32,46,59..60,66..71,80,81,90,91];\r
1446   ToNounOnly  :=[33,49,64,88,93];\r
1447   ToNounMaybe :=[19,41..44,48,50,53,54,74..76,89,90,92,94];\r
1448   { NOTE:  All other verbs would be OneNounOnly! }\r
1449   nSetActiveWin(win2);gotoxy(1,19);\r
1450  end; { Init3 }\r
1451 \r
1452 procedure Save;\r
1453   label JUMPABORT,JUMPBACK;\r
1454   {var   DiskTest:file;}\r
1455  begin SF; JUMPBACK: nosound; for x:=1 to 20 do writeln;\r
1456   Bor(2,7);CFlag:=Drive;Cur(2);\r
1457   gotoxy(1,2);\r
1458   { remove floppy drive selection\r
1459   write('Which disk drive (default ',Up(Drive),':)? ');\r
1460   col(14,15);buflen:=1;readline(Drive);col(11,7);\r
1461   Drive:=upcase(Drive);if not(Drive in['A','B'])then Drive:=CFlag;}\r
1462   gotoxy(1,5);\r
1463   writeln('Make sure your SAVE/RESTORE disk is in disk drive ',up(Drive),':');\r
1464   writeln;writeln;\r
1465   write('SAVE under what file name (''',up('/'),''' aborts SAVE)? ');\r
1466   buflen:=8;col(14,15);readline(input);col(11,7);\r
1467   Cur(3);\r
1468   while pos(' ',input)>0 do delete(input,pos(' ',input),1);\r
1469   while pos('.',input)>0 do delete(input,pos('.',input),1);\r
1470   while pos(':',input)>0 do delete(input,pos(':',input),1);\r
1471   if pos('/',input)>0 then\r
1472    begin writeln;writeln(up('SAVE ABORTED'));goto JUMPABORT;end;\r
1473   LowerCase(input);\r
1474   if(pos('list',input)>0)or(pos('dir',input)>0)or(pos('file',input)>0)then\r
1475    begin Directory;goto JUMPBACK;end;\r
1476   if length(input)=0 then input:='LASTSAVE';writeln;writeln;\r
1477   writeln('The game file ',Up(Input),' is now being saved on disk drive ',\r
1478            up(Drive),':...');\r
1479   { don't put Drive\r
1480   input:=Drive+':'+input;}\r
1481   assign(Objects,input+'.sm1');\r
1482   rewrite(Objects);\r
1483   for x:=0 to RMax do write(Objects,L[x]);\r
1484   close(Objects);\r
1485   assign(Things,input+'.sm2');\r
1486   rewrite(Things);\r
1487   write(Things,Prm,Region,MugCon,FoodCon,SatchCon,NicheCon,PyraCon,\r
1488                HingeCon,PodumCon,AlienRm,FriendRm,SinkRm,Serum,TFlag,\r
1489                RobotCon,CodeSet,ScrnSet,HolstCon);\r
1490   for x:=1 to MMax do write(Things,R[x]);\r
1491   close(Things);\r
1492   assign(Timers,input+'.sm3');\r
1493   rewrite(Timers);\r
1494   write(Timers,Tic,Sc,RC,Floor);\r
1495   for x:=1 to TMax do write(Timers,T[x]);\r
1496   close(Timers);\r
1497   with SetSave do\r
1498    begin aInv:=Inv;aPStat:=PStat;aEvents:=Events;\r
1499     aSocket:=Socket;aWear:=Wear;end;\r
1500   assign(Sets,input+'.sm4');\r
1501   rewrite(Sets);\r
1502   write(Sets,SetSave);\r
1503   close(Sets);\r
1504   writeln;writeln;delete(input,1,2);\r
1505   writeln('Your present game location is now SAVED under the name ',\r
1506            up(input),'.');\r
1507   writeln; JUMPABORT: writeln;\r
1508   { remove checking SUPERNOVA floppy disk\r
1509   writeln('Please make sure the SUPERNOVA disk is in drive ',up(Log),':');\r
1510   writeln;writeln;Pause;\r
1511   assign(DiskTest,'Nova.com');}\r
1512   {$I-}\r
1513   {reset(DiskTest);}\r
1514   {$I+}\r
1515   {if IOResult<>0 then\r
1516    begin Col(15,15);close(DiskTest);write(^g);goto JUMPABORT;end;\r
1517   close(DiskTest);} Col(11,7);\r
1518   Bor(0,0);Line:='l';\r
1519   case Region of 4:sound(20);5:sound(60)end\r
1520  end; { SAVE }\r
1521 \r
1522 procedure Restore;\r
1523   label JUMP,JUMPBACK;\r
1524   {var   DiskTest:file;}\r
1525  begin SF; JUMPBACK: nosound; for x:=1 to 25 do writeln;\r
1526   Bor(6,7);CFlag:=Drive;Cur(2);\r
1527   gotoxy(1,2);\r
1528   { remove floppy disk selection\r
1529   write('Which disk drive (default ',Up(Drive),':)? ');\r
1530   col(14,15);buflen:=1;readline(Drive);col(11,7);\r
1531   Drive:=upcase(Drive);if not(Drive in['A','B'])then Drive:=CFlag;}\r
1532   gotoxy(1,5);\r
1533   writeln('Make sure your SAVE/RESTORE disk is in disk drive ',up(Drive),':');\r
1534   writeln;writeln;\r
1535   write('RESTORE from what file name (''',up('/'),''' aborts RESTORE)? ');\r
1536   buflen:=8;col(14,15);readline(input);col(11,7);\r
1537   Cur(3);\r
1538   while pos(' ',input)>0 do delete(input,pos(' ',input),1);\r
1539   while pos('.',input)>0 do delete(input,pos('.',input),1);\r
1540   while pos(':',input)>0 do delete(input,pos(':',input),1);\r
1541   if pos('/',input)>0 then\r
1542    begin writeln;writeln(up('RESTORE ABORTED'));goto JUMP;end;\r
1543   LowerCase(input);\r
1544   if(pos('list',input)>0)or(pos('dir',input)>0)or(pos('file',input)>0)then\r
1545    begin Directory;goto JUMPBACK;end;\r
1546   if length(input)=0 then input:='LASTSAVE';writeln;writeln;\r
1547   writeln('The game file ',Up(Input),' is now being restored from drive ',\r
1548            up(Drive),':...');\r
1549   { Don't put Drive\r
1550   input:=Drive+':'+input;}\r
1551   assign(Objects,input+'.sm1');\r
1552   {$I-}\r
1553   reset(Objects);\r
1554   {$I+}\r
1555   if IOResult<>0 then\r
1556    begin close(Objects);col(12,15);writeln;writeln;delete(input,1,2);\r
1557     for x:=1 to length(input) do input[x]:=upcase(input[x]);\r
1558     wCn('The file '+input+' does not exist on your SAVE/RESTORE disk!');\r
1559     writeln(^g);delay(2000);col(11,7);goto JUMPBACK;\r
1560    end;\r
1561   reset(Objects);\r
1562   for x:=0 to RMax do read(Objects,L[x]);\r
1563   close(Objects);\r
1564   assign(Things,input+'.sm2');\r
1565   reset(Things);\r
1566   read(Things,Prm,Region,MugCon,FoodCon,SatchCon,NicheCon,PyraCon,\r
1567               HingeCon,PodumCon,AlienRm,FriendRm,SinkRm,Serum,TFlag,\r
1568               RobotCon,CodeSet,ScrnSet,HolstCon);\r
1569   for x:=1 to MMax do read(Things,R[x]);\r
1570   close(Things);\r
1571   assign(Timers,input+'.sm3');\r
1572   reset(Timers);\r
1573   read(Timers,Tic,Sc,RC,Floor);\r
1574   for x:=1 to TMax do read(Timers,T[x]);\r
1575   close(Timers);\r
1576   assign(Sets,input+'.sm4');\r
1577   reset(Sets);\r
1578   read(Sets,SetSave);\r
1579   close(Sets);\r
1580   with SetSave do\r
1581    begin Inv:=aInv;PStat:=aPStat;Events:=aEvents;\r
1582     Socket:=aSocket;Wear:=aWear;end;\r
1583   Add(126);\r
1584   writeln;writeln;delete(input,1,2);\r
1585   writeln('Your present game location is now RESTORED from the name ',\r
1586            up(input),'.');\r
1587   writeln; JUMP: writeln;\r
1588   { remove checking SUPERNOVA floppy disk\r
1589   writeln('Please make sure the SUPERNOVA disk is in drive ',up(Log),':');\r
1590   writeln;writeln;Pause;\r
1591   assign(DiskTest,'Nova.com');}\r
1592   {$I-}\r
1593   {reset(DiskTest);}\r
1594   {$I+}\r
1595   {if IOResult<>0 then\r
1596    begin Col(15,15);close(DiskTest);write(^g);goto JUMP;end;\r
1597   close(DiskTest);} Col(11,7);\r
1598   Bor(0,0);\r
1599   case Region of 4:sound(20);5:sound(60)end;\r
1600   if Region>1 then\r
1601    begin\r
1602     n[84]:='reactor regulat\';\r
1603     n[126]:='hinged mouth\mouth\hinge\';\r
1604    end\r
1605    else\r
1606     begin\r
1607      n[84]:='middle table\middle\';\r
1608      n[126]:='bar\';\r
1609     end;\r
1610   if en(34)then n[18]:='glass ball\ball\glass\'\r
1611    else n[18]:='dusty ball\ball\dusty\';\r
1612   if Prm>79 then\r
1613    begin\r
1614     n[40]:='sockets\socket\';\r
1615     n[82]:='laser beam\beam\laser\';\r
1616     n[110]:='speaker\';\r
1617    end else\r
1618    begin\r
1619     n[40]:='cyan button\cyan\';\r
1620     n[82]:='solar map\map\solar\drawing\';\r
1621     n[110]:='keyhole\';\r
1622    end;\r
1623    Min(128);Line:='l';\r
1624  end; { RESTORE }\r
1625 \r
1626 procedure MoreThanOne;\r
1627  begin\r
1628   if((N1=58)or(58 in NounSet)or(N2=58))and Here(3) and Here(4) then\r
1629    begin Cur(2);\r
1630     repeat write('Which one, the R)usty or S)hiney key? ');\r
1631      CFlag:=Readkey;writeln(CFlag);writeln until upcase(CFlag) in ['R','S'];\r
1632     case upcase(CFlag) of 'R':x:=3; 'S':x:=4 end;\r
1633     if N1=58 then N1:=x;\r
1634     if N2=58 then N2:=x;\r
1635     if 58 in NounSet then begin NounSet:=NounSet-[58];NounSet:=NounSet+[x] end;\r
1636    end;\r
1637   if((N1=86)or(86 in NounSet)or(N2=86))and(Prm=8)then\r
1638    begin Cur(2);\r
1639     repeat write('Which one, the W)estern, M)iddle or E)astern table? ');\r
1640      CFlag:=ReadKey;writeln(CFlag);\r
1641      writeln until upcase(CFlag) in ['W','M','E'];\r
1642     case upcase(CFlag) of 'W':x:=83; 'M':x:=84; 'E':x:=85 end;\r
1643     if N1=86 then N1:=x;\r
1644     if N2=86 then N2:=x;\r
1645     if 86 in NounSet then begin NounSet:=NounSet-[86];NounSet:=NounSet+[x] end;\r
1646    end;\r
1647   if((N1=44)or(44 in NounSet)or(N2=44))and(Prm in[1,70])and(Vb<>28)then\r
1648    begin Cur(2);\r
1649     repeat write('Which one, the T)an, P)urple or C)yan button? ');\r
1650      CFlag:=ReadKey;writeln(CFlag);\r
1651      writeln until upcase(CFlag) in ['T','P','C'];\r
1652     case upcase(CFlag) of 'T':x:=41; 'P':x:=43; 'C':x:=40 end;\r
1653     if N1=44 then N1:=x;\r
1654     if N2=44 then N2:=x;\r
1655     if 44 in NounSet then begin NounSet:=NounSet-[44];NounSet:=NounSet+[x] end;\r
1656    end;\r
1657   if(N1=58)and Here(3)and not(Here(4))then N1:=3;\r
1658   if(N2=58)and Here(3)and not(Here(4))then N2:=3;\r
1659   if(58 in NounSet)and Here(3)and not(Here(4))then\r
1660     begin NounSet:=NounSet-[58];NounSet:=NounSet+[3] end;\r
1661   if(N1=58)and Here(4)and not(Here(3))then N1:=4;\r
1662   if(N2=58)and Here(4)and not(Here(3))then N2:=4;\r
1663   if(58 in NounSet)and Here(4)and not(Here(3))then\r
1664     begin NounSet:=NounSet-[58];NounSet:=NounSet+[4] end;\r
1665 end; { MoreThanOne }\r
1666 \r
1667 \r
1668 function Print(Word:Str29):Str1;\r
1669  begin Print:='';writeln('--you can''t use the word ',Up(Word),' here.')end;\r
1670 \r
1671 procedure Parser_Syntax(var Input:Str130);\r
1672    label JUMP1, JUMP2;\r
1673 begin\r
1674  Word:=''; Md:=Null; Num:=Null; Code:=Null;\r
1675  Vb:=Null; N1:=Null; N2:=Null; NounSet:=[];\r
1676 JUMP1:  { Used if the player forgets the first noun. }\r
1677  FFlag:=Null; Pr:=Null;\r
1678 JUMP2:  { Used if the player forgets the second noun or preposition. }\r
1679  EFlag:=Null;\r
1680  FindMood(input,Word,Md);\r
1681  if(length(input)>0)then\r
1682   begin\r
1683    FindMood(input,Word,Num);\r
1684    if(Num=Null)then\r
1685     begin\r
1686      FindWord(input,Vb,Word,1);\r
1687      if(Vb<>Null)then\r
1688       if(length(input)=0)then\r
1689        begin\r
1690         if(Vb in NoNounOnly)or(Vb in OneNounMaybe)then EFlag:=Legal;\r
1691         if EFlag<>Legal then\r
1692          begin\r
1693           if(Vb=35)and here(35)then begin EFlag:=Legal;N1:=35;NStr:='seat';end;\r
1694           if(Vb=47)and here(6)then begin EFlag:=Legal;N1:=6;end;\r
1695           if(Vb=62)and here(80)then begin EFlag:=Legal;N1:=80;end;\r
1696           if(Vb=65)and here(124)then begin EFlag:=Legal;N1:=124;end;\r
1697           if EFlag<>Legal then EFlag:=4\r
1698          end\r
1699        end\r
1700       else\r
1701        if(Vb in NoNounOnly)then Dictionary(3,9)\r
1702        else\r
1703         if not(Vb in[17,18,37,39])then       { get,drop and but branch-off }\r
1704          if not(Vb in[25,32,56,66..69,71,80,81])then { characters and type }\r
1705           begin\r
1706            if(Vb<>FFlag)then FindWord(input,N1,Word,2);\r
1707            if(N1<>Null)then LastNoun:=FN(N1);\r
1708            if(N1<>Null)then\r
1709             if(Word<>'all')then\r
1710              if(length(input)=0)then\r
1711               if(Vb in ToNounOnly)then\r
1712                if(VStr='fill')and(Prm=SinkRm)and(N1=29)then\r
1713                   begin N2:=79;Pr:=6;EFlag:=Legal;end else\r
1714                if(Vb=64)and(Prm=8)and(N1 in[29,99])and(not en(21))and\r
1715                   here(8)then begin Pr:=6;N2:=8;EFlag:=Legal;end else\r
1716                if(Vb=88)and(Prm in[9..11])and(N1=56)and here(3)then\r
1717                   begin Pr:=6;N2:=3;EFlag:=Legal;end\r
1718                else EFlag:=15\r
1719               else EFlag:=Legal\r
1720              else\r
1721               if(Vb in ToNounMaybe)or(Vb in ToNounOnly)then\r
1722                begin\r
1723                 FindWord(input,Pr,Word,3);\r
1724                 if(Pr<>Null)then\r
1725                  if(length(input)=0)then\r
1726                    if(Vb=50)and(Pr in[1,9])then EFlag:=Legal\r
1727                    else EFlag:=6\r
1728                  else\r
1729                   if(Vb<>50)then  { branch for turning dials }\r
1730                    begin\r
1731                     FindWord(input,N2,Word,2);\r
1732                     if(N2<>Null)then\r
1733                      if(Word<>'all')then\r
1734                       if(length(input)=0)then EFlag:=Legal\r
1735                       else Dictionary(12,9)\r
1736                      else EFlag:=16\r
1737                     else Dictionary(11,2)\r
1738                    end\r
1739                   else\r
1740                    begin\r
1741                     val(input,Code,testc);\r
1742                     if(testc=0)then EFlag:=Legal\r
1743                     else begin delete(input,1,testc-1);Dictionary(14,9);end;\r
1744                    end\r
1745                 else Dictionary(9,3)\r
1746                end\r
1747               else\r
1748                begin Dictionary(3,9);if(List=2)then EFlag:=8;end\r
1749              else EFlag:=16\r
1750            else Dictionary(10,2)\r
1751           end\r
1752          else { Special case for TYPE, characters, etc. }\r
1753           begin\r
1754            QFormat(input);\r
1755            EFlag:=Legal\r
1756           end { of Special case for SAY, TYPE, etc. }\r
1757         else  { Special case for GET and DROP }\r
1758          while EFlag=Null do\r
1759           begin N1:=Null;\r
1760            FindWord(input,N1,Word,2);\r
1761            if(N1<>Null)then LastNoun:=FN(N1);\r
1762            if(N1<>Null)then\r
1763             if not(N1 in NounSet)then\r
1764              begin\r
1765               NounSet:=NounSet+[N1];\r
1766               if(length(input)=0)then EFlag:=Legal\r
1767              end\r
1768             else EFlag:=13\r
1769            else Dictionary(10,2)\r
1770           end { of Special case for GET and DROP }\r
1771      else Dictionary(7,1)\r
1772     end\r
1773    else EFlag:=2\r
1774   end\r
1775  else EFlag:=1;\r
1776  if EFlag<>Legal then\r
1777   begin Line:='';play(199,199,55);delay(70);play(60,60,55)end;\r
1778  case EFlag of\r
1779  1:RL(186);\r
1780  2:writeln('The word ',up(Word),' is too many adverbs.');\r
1781  3:write('Illegal input',Print(Word));\r
1782  4:if(Vb=56)then RL(187)\r
1783    else\r
1784     begin\r
1785      write('Noun missing--');\r
1786      case Vb of\r
1787       35,62:writeln('what do you want to ',up(Word),' on?');\r
1788       65:writeln('what do you want to ',up(Word),' to?')\r
1789       else writeln('what do you want to ',up(Word),'?');\r
1790      end;\r
1791      PlayerInput(line);\r
1792      if(length(input)>0)then goto JUMP1;\r
1793     end;\r
1794  5:if(length(Word)>1)then\r
1795     writeln('The word ',up(Word),' is not used in this adventure.')\r
1796    else\r
1797     writeln('The letter ',up(Word),' is not used as shorthand in this parser.');\r
1798  6:begin\r
1799     writeln('Noun missing--what do you want to ',up(VStr),up(' the '),\r
1800             up(NStr),' ',up(PStr),'?');\r
1801     PlayerInput(line); FFlag:=Vb;\r
1802     if(length(input)>0)then goto JUMP2;\r
1803    end;\r
1804  7:write('Verb missing',Print(Word));\r
1805  8:RL(188);\r
1806  9:write('Preposition expected',Print(Word));\r
1807  10:write('Noun expected',Print(Word));\r
1808  11:write('Indirect noun expected',Print(Word));\r
1809  12:write('No more input expected',Print(Word));\r
1810  13:writeln('Illegal noun used--',up(Word),' referenced more than once.');\r
1811  14:write('Number expected',Print(Word));\r
1812  15:begin\r
1813      write('Preposition and noun missing--');\r
1814      if(Vb in[33,48])then\r
1815       writeln('where do you want to ',up(VStr),' the ',up(NStr),'?') else\r
1816      if Vb=49 then\r
1817       begin Pr:=1;\r
1818        writeln('who do you want to ',up(VStr),' the ',up(NStr),' to?')end\r
1819      else begin Pr:=6;\r
1820        writeln('what do you want to ',up(VStr),' the ',up(NStr),' with?')end;\r
1821      PlayerInput(line); FFlag:=Vb;\r
1822      if(length(input)>0)then goto JUMP2;\r
1823     end;\r
1824  16:RL(189);\r
1825  17:RL(576)\r
1826  end;\r
1827 end; { Parser Syntax }\r
1828 \r
1829 procedure MC(WhichChar,WatchRoom,ToRoom:byte;MessageNum:Integer);\r
1830     { WhichChar refers to the character(s) being moved.               }\r
1831     { WatchRoom is the room the player must be in to see the responce.}\r
1832     { ToRoom is the room the character(s) move to.                    }\r
1833     { MessageNum is the message that is written if the player sees.   }\r
1834  begin\r
1835   if(Prm=WatchRoom)then RS(MessageNum);\r
1836   case WhichChar of     { 1 = Aliens,  2 = Scientist }\r
1837    1:begin\r
1838       L[AlienRm]:=L[AlienRm]-[124];AlienRm:=ToRoom;\r
1839       L[AlienRm]:=L[AlienRm]+[124]\r
1840      end;\r
1841    2:begin\r
1842       L[FriendRm]:=L[FriendRm]-[123];FriendRm:=ToRoom;\r
1843       L[FriendRm]:=L[FriendRm]+[123]\r
1844      end\r
1845   end;\r
1846   SFlag:=false;\r
1847  end;\r
1848 \r
1849 procedure Van(o:byte);\r
1850  begin\r
1851   Inv:=Inv-[o];\r
1852   r[o]:=Null;\r
1853   L[Prm]:=L[Prm]-[o];\r
1854   if o in Wear then Wear:=Wear-[o];\r
1855   if o=SatchCon then SatchCon:=Null;\r
1856   if o=MugCon then MugCon:=Null;\r
1857   if o=16 then Min(6);\r
1858   if o=NicheCon then NicheCon:=Null;\r
1859   if o=PyraCon then PyraCon:=Null;\r
1860   if o=HingeCon then HingeCon:=Null;\r
1861   if o=PodumCon then PodumCon:=Null;\r
1862   if o=16 then begin Min(37);Min(6)end;\r
1863   if o=RobotCon then RobotCon:=Null;\r
1864   if o in Socket then Socket:=Socket-[o];\r
1865   if o=HolstCon then HolstCon:=Null\r
1866  end;\r
1867 \r
1868 procedure Crazy;\r
1869  begin SF; RL(random(7)+127)end;\r
1870 \r
1871 procedure NoSense;\r
1872  begin RL(190) end;\r
1873 \r
1874 procedure Say(What1,What2:Str29);\r
1875  begin SF; writeln('The ',What1,' is already ',What2,'.') end;\r
1876 \r
1877 {******************* END OF PARSER AND MISC. PROCEDURES *********************}\r
1878 \1a\r