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   if nCols(stdscr) < 80 then begin\r
  82    writeln('You must have 80 character columns');\r
  83    Halt;\r
  84   end;\r
  85   if nRows(stdscr) < 25 then begin\r
  86    writeln('You must have 25 character rows');\r
  87    Halt;\r
  88   end;\r
  89   {writeln(nCols(stdscr),nRows(stdscr));}\r
  90  end;\r
  91 \r
  92 procedure WritePrompt(x,y:integer);\r
  93  begin\r
  94   { UTF-8 print }\r
  95   if UTF8Scr then\r
  96    { U+00BB, », C2 BB, RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK.}\r
  97    nFWrite(x,y,TextAttr,0,#$C2#$BB)\r
  98   else \r
  99    nFWrite(x,y,TextAttr,0,chr(187));\r
 100   refresh;\r
 101  end;\r
 102 \r
 103 {$ELSE}\r
 104 procedure nSetActiveWin(win:pwin);\r
 105  begin\r
 106   with win^ do\r
 107    window(x,y,x1,y1);\r
 108  end;\r
 109 \r
 110 procedure nWindow(var win : pwin; x,y,x1,y1 : integer);\r
 111  begin\r
 112   win^.x:=x;   win^.y:=y;\r
 113   win^.x1:=x1; win^.y1:=y1;\r
 114  end;\r
 115 \r
 116 procedure init_windows;\r
 117  begin\r
 118   stdscr:=@win_arr[1];\r
 119   win1:=@win_arr[2];\r
 120   win2:=@win_arr[3];\r
 121   nWindow(stdscr,1,1,80,25);\r
 122  end;\r
 123 \r
 124 procedure WritePrompt(x,y:integer);\r
 125  begin\r
 126   gotoxy(x,y);\r
 127   write(chr(175));\r
 128  end;\r
 129 {$ENDIF}\r
 130 \r
 131 function square_wave(time : Real):integer;\r
 132   var l:longint;\r
 133  begin\r
 134   l:=trunc(time);\r
 135   if time-l < 0.5 then square_wave:=0 \r
 136                   else square_wave:=1;\r
 137  end;\r
 138 \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
 142  begin\r
 143   step:=audio_STEP;\r
 144   for i:=0 to trunc((len-1)/step) do begin\r
 145    \r
 146    if speaker_on then\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
 153     end;\r
 154 \r
 155    lasttime:=trunc(lasttime*lastfreq/current_freq);\r
 156    \r
 157    for j:=0 to step-1 do begin\r
 158     k:=i*step+j;\r
 159     if k<len then\r
 160      if speaker_on then\r
 161       stream[k]:=audio_VOLUME*square_wave(current_freq * (j+lasttime) )\r
 162      else\r
 163       stream[k]:=0;\r
 164    end;\r
 165 \r
 166    lasttime:=lasttime+step;\r
 167    lastfreq:=current_freq; \r
 168   end;\r
 169  end; \r
 170 \r
 171 function InitAudio:boolean;\r
 172   var Desired, Obtained: TSDL_AudioSpec;\r
 173  begin\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
 181 \r
 182   if SDL_Init(SDL_INIT_AUDIO) = 0 then\r
 183    if SDL_OpenAudio(@Desired, @Obtained) = 0 then begin\r
 184 \r
 185     speaker_on:=false;\r
 186     current_freq:=1; lastfreq:=1;\r
 187     sound_ticks:=1;\r
 188     SDL_PauseAudio(0);\r
 189     InitAudio:=true;\r
 190    end \r
 191     else InitAudio:=false\r
 192   else\r
 193    InitAudio:=false;\r
 194  end;\r
 195 \r
 196 procedure InitScrKbd;\r
 197  begin\r
 198   buflen:=127;\r
 199   CheckBreak:=false;\r
 200   if initaudio then sound_supported:=true\r
 201    else begin\r
 202     WriteLn('SDL failed to initialize audio: ', SDL_GetError);\r
 203     sound_supported:=false;\r
 204    end;\r
 205   UTF8Scr:=false;\r
 206   init_windows;\r
 207   nWindow(win1,2,2,79,4);\r
 208   nWindow(win2,2,5,79,24);\r
 209   nsetActiveWin(stdscr);\r
 210  end;\r
 211 \r
 212 procedure DoneAudio;\r
 213  begin\r
 214   if sound_supported then begin\r
 215    SDL_CloseAudio;\r
 216    SDL_Quit;\r
 217   end;\r
 218  end;\r
 219 \r
 220 procedure DoneScrKbd;\r
 221  begin\r
 222   DoneAudio;\r
 223   nSetActiveWin(stdscr);\r
 224   clrscr;\r
 225  end;\r
 226 \r
 227 procedure sound( Hz: Integer );\r
 228  begin\r
 229   if sound_supported then begin\r
 230    sound_i:=0;\r
 231    current_freq:=Hz/audio_Freq;\r
 232    if current_freq > 0 then\r
 233     speaker_on:=true\r
 234    else\r
 235     current_freq:=1;\r
 236   end;\r
 237  end;\r
 238 \r
 239 procedure nosound;\r
 240  begin\r
 241   if sound_supported then begin\r
 242    if sound_i > 0 then begin\r
 243     speaker_on:=true;\r
 244     while speaker_on do;\r
 245    end else\r
 246     speaker_on:=false;\r
 247   end;\r
 248  end;\r
 249 \r
 250 procedure sounddelayed( Hz,step: Integer ); forward;\r
 251 \r
 252 procedure sounddelayed( Hz: Integer );\r
 253  begin\r
 254   sounddelayed( Hz, audio_STEP );\r
 255  end;\r
 256 \r
 257 procedure sounddelayed( Hz,step: Integer );\r
 258  begin\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
 265      end;\r
 266    end;\r
 267   end;\r
 268  end;\r
 269 \r
 270 procedure delay( MS: Integer);\r
 271  begin\r
 272   if sound_supported then\r
 273    SDL_delay(MS)\r
 274   else\r
 275 {$IFDEF UNIX}\r
 276    ocrt.delay(MS);\r
 277 {$ELSE}\r
 278    crt.delay(MS);\r
 279 {$ENDIF}\r
 280  end;\r
 281 \r
 282 procedure ReadLine(var S:String);\r
 283  var Ch: Char;\r
 284  begin\r
 285   Repeat\r
 286    Ch:=ReadKey;\r
 287    write(ch);\r
 288    if (buflen>0) and (ch<>Chr(13)) then begin\r
 289     S:=S+ch;\r
 290     buflen:=buflen-1;\r
 291    end;\r
 292   Until (Ch=chr(13));\r
 293   buflen:=127;\r
 294  end;\r
 295 \r
 296 procedure SF; begin SFlag:=True end;\r
 297 \r
 298 procedure Cur(Num:byte);\r
 299  begin\r
 300   case Num of  \r
 301 {$IFDEF UNIX}\r
 302    1:ncursor(cON);  { Underline   }\r
 303    2:ncursor(cBIG); { Solid block }\r
 304    3:nCursor(cOFF); { Invisible   }\r
 305 {$ELSE}\r
 306    1:cursoron;      { Underline   }\r
 307    2:cursorbig;     { Solid block }\r
 308    3:cursoroff;     { Invisible   }\r
 309 {$ENDIF}\r
 310   end;\r
 311  end;\r
 312 \r
 313 procedure Col(Num1,Num2:byte);\r
 314  begin if Color then textcolor(Num1) else textcolor(Num2) end;\r
 315 \r
 316 procedure Bak(Num1,Num2:byte);\r
 317  begin if Color then textbackground(Num1) else textbackground(Num2) end;\r
 318 \r
 319 procedure Bor(Num1,Num2:byte);\r
 320  begin\r
 321   {with Result do\r
 322    begin AX:=$B00;if Color then BX:=Num1 else BX:=Num2 end;intr($10,Result)}\r
 323  end;\r
 324 \r
 325 function  En(Num:byte):boolean;\r
 326  begin if Num in Events then En:=true else En:=false end;\r
 327 \r
 328 procedure Add(Num:byte);\r
 329  begin Events:=Events+[Num] end;\r
 330 \r
 331 procedure Min(Num:byte);\r
 332  begin Events:=Events-[Num] end;\r
 333 \r
 334 procedure Score(Num,pointer:integer);\r
 335  begin if not en(pointer)then begin Sc:=Sc+Num;Add(Pointer)end end;\r
 336 \r
 337 procedure Cn(s:str78);\r
 338  begin gotoxy(40-(length(s)div 2),wherey);write(s);gotoxy(1,wherey+1)end;\r
 339 \r
 340 procedure wCn(s:str78);\r
 341  begin gotoxy(39-(length(s)div 2),wherey);writeln(s);end;\r
 342 \r
 343 procedure Pause;\r
 344  begin col(15,15);write('Press any key to continue...');\r
 345   CFlag:=ReadKey;col(11,7);writeln;\r
 346  end;\r
 347 \r
 348 procedure Tune(Octave,Note,Duration:integer);\r
 349   var Frequency:real;\r
 350       i:integer;\r
 351  begin\r
 352   Frequency:=32.625;\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
 358    begin\r
 359     sound(round(Frequency));\r
 360     delay(Duration);\r
 361     nosound\r
 362    end\r
 363   else sound(round(Frequency));\r
 364  end;\r
 365 \r
 366 procedure Play(Start,Stop,Speed:integer);\r
 367   var x:integer;\r
 368  begin\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
 373   else\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
 379    end;\r
 380  end;\r
 381 \r
 382 procedure Explode(Duration:byte);\r
 383   var x:integer;\r
 384  begin for x:=Duration*999 downto 20 do sounddelayed(random(x));nosound end;\r
 385 \r
 386 procedure Walls(Duration:byte);\r
 387   var x:integer;\r
 388  begin for x:=1 to Duration*999 do sounddelayed(random(35)+20);nosound end;\r
 389 \r
 390 procedure Static;\r
 391   var x,y:integer;\r
 392  begin\r
 393   for x:=1 to 50 do\r
 394    case random(2) of\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
 398  end;\r
 399 \r
 400 procedure Blast;\r
 401   var x:byte;\r
 402  begin\r
 403   for x:=1 to 40 do\r
 404    begin play(550-x*6,600+x*6,0);play(600+x*6,550-x*6,0)end;explode(2)\r
 405  end;\r
 406 \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
 412  end;\r
 413 \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
 419  end;\r
 420 \r
 421 procedure Door(New,Num:byte);\r
 422  begin\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
 425  end;\r
 426 \r
 427 procedure won; forward;\r
 428 \r
 429 procedure SoundTest;\r
 430   var ch:char;\r
 431  begin\r
 432 \r
 433   while true do begin\r
 434     \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
 444 \r
 445     ch:=readkey;\r
 446 \r
 447     if ch='q' then halt;\r
 448 \r
 449     case ch of\r
 450      '1' : Won;\r
 451      '2' : explode(32);\r
 452      '3' : Walls(12);\r
 453      '4' : Static;\r
 454      '5' : Blast;\r
 455      '6' : Dopen(10);\r
 456      '7' : DClose(0);\r
 457      '8' : begin\r
 458             for x:=1 to 20 do for y:=1 to x*8 do sounddelayed(x*9,trunc((168-y)/8)); nosound;\r
 459            end;\r
 460     end;\r
 461 \r
 462   end;\r
 463 \r
 464  end;\r
 465 \r
 466 procedure Time1;\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
 472    12:RL(3);\r
 473    4:begin Bor(4,7);RL(4)end;\r
 474    1:begin RL(124);DEAD;end\r
 475   end;\r
 476   case T[4] of { Thirst }\r
 477    22:begin PStat:=PStat+[6];RL(5)end;\r
 478    11:RL(6);\r
 479    4:begin Bor(4,7);RL(7)end;\r
 480    1:begin RL(125);DEAD;end\r
 481   end;\r
 482   case T[5] of { Sleep }\r
 483    32:begin PStat:=PStat+[5];RL(8)end;\r
 484    14:RL(9);\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
 491                     ' the ',FN(x),'!')\r
 492            end\r
 493          end\r
 494   end;\r
 495   case T[29] of { Laser Injury }\r
 496    9:RS(214);\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
 506       end\r
 507      end;\r
 508    1:begin RS(215);DEAD;end\r
 509   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
 516           begin RS(232);\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
 519           end\r
 520   end;\r
 521   Col(10,7);\r
 522   if(Prm in[81..88])and(T[30]<1)and(random(4)=0)then\r
 523    if 28 in Wear 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
 527     end\r
 528    else\r
 529     begin\r
 530      write('A small droid appears from the ');\r
 531      case Prm of\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
 537      delay(1500);DEAD\r
 538     end;\r
 539  end; { Time1 }\r
 540 \r
 541 procedure Time2A;\r
 542  begin col(10,7);  { Pre-Jungle Planet }\r
 543   case T[1] of\r
 544    19:MC(1,13,13,0);\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
 548    10:MC(1,8,9,3);\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
 552   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
 558    1:if en(10)then\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
 565   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
 573   case Prm of\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
 580      1:RL(596);\r
 581      2:RL(597);\r
 582      3,4:if RC>40 then begin if T[4]>10 then T[4]:=10;RL(598)end;\r
 583      end; {case}\r
 584    20:if random(4)=1 then RL(25);\r
 585   end; {case}\r
 586   if Prm=SinkRm then begin RL(85);L[Prm]:=L[Prm]+[79];end;\r
 587 end; { Time2A }\r
 588 \r
 589 procedure Time2B;\r
 590  begin col(10,7);  { Jungle Planet }\r
 591   Maze:=not(Maze);\r
 592   if Prm in[42..49]then\r
 593    begin writeln('Some of the walls shift positions.');Walls(4);end;\r
 594   case Prm of\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
 599      end;\r
 600    42..50:if random(7)=0 then RL(280);\r
 601   end; {case}\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
 609   if T[14]=1 then\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
 617  end; { Time2B }\r
 618 \r
 619 procedure Time2C;\r
 620  begin col(11,7);  { Inner Planet }\r
 621   if T[20]=1 then\r
 622    case Prm of 73:DClose(20);66:begin RL(337);play(105,50,20)end end;\r
 623   col(10,7);\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
 628    for x:=1 to 23 do\r
 629     begin\r
 630      for i:=450 to 999 do sounddelayed(i);\r
 631      for i:=999 downto 450 do sounddelayed(i);\r
 632     end;nosound\r
 633    end;\r
 634   case random(50) of\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
 639   end;\r
 640  end; { Time2C }\r
 641 \r
 642 procedure Time2D;  { Planetship }\r
 643   function Warn(Message,IfTime,Said:integer):boolean;\r
 644    begin Warn:=false;\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
 650      end\r
 651    end; {Warn}\r
 652  begin col(11,7);\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
 655   if T[21]=1 then\r
 656    case Prm of 91:DClose(20);86:begin RL(337);play(110,50,15)end end;\r
 657   col(10,7);\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
 663    end end;\r
 664   if T[22]=1 then\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
 672    end;\r
 673   case T[23] of\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
 689   end; {T[23]}\r
 690   if(T[23]>1)and(T[23]<4)and(Prm=91)then begin T[24]:=7;T[23]:=NULL;end;\r
 691   case T[24] of\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
 698       DClose(55)end;\r
 699      end;\r
 700   end; {T[24]}\r
 701   case T[25] of\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
 704   end; {T[25]}\r
 705   if en(64)then\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
 719  end; { Time2D }\r
 720 \r
 721 procedure Directory;\r
 722 var\r
 723   SM1Found  : boolean;\r
 724   Info      : TSearchRec;\r
 725 begin\r
 726   {ChDir(Drive+':');}\r
 727   SM1Found:=false;\r
 728   writeln;\r
 729   if FindFirst ('*',faAnyFile,Info)=0 then\r
 730     repeat\r
 731       if length(Info.Name)>4 then\r
 732        if copy(Info.Name,length(Info.Name)-2,3)='sm1' then\r
 733         begin\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
 737         SM1Found:=true;\r
 738         writeln('    * ',copy(Info.Name,1,length(Info.Name)-4));\r
 739        end;\r
 740     until FindNext(Info)<>0;\r
 741   \r
 742   FindClose(Info);\r
 743   writeln;\r
 744   if not SM1Found then\r
 745    begin\r
 746     writeln('There are not any SAVE/RESTORE files on the disk in drive ',\r
 747             up(Drive),':');writeln;\r
 748    end;\r
 749   Pause;{ChDir(Log+':');}\r
 750 end; {Directory}\r
 751 \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
 759  end;\r
 760 \r
 761 procedure Spaces(var I:Str130);\r
 762  begin I:=concat(' ',I,' ')end;\r
 763 \r
 764 procedure QFormat(var I:Str130);\r
 765  begin\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
 768  end;\r
 769 \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
 775   Spaces(I);\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
 794   QFormat(I);\r
 795   if(length(I)=0)then\r
 796    begin EFlag:=Null;\r
 797     case FFlag of\r
 798      2:RL(193);\r
 799      3:RL(186)\r
 800      else writeln('Pardon me?')\r
 801     end;\r
 802    end\r
 803  end; { PreFormat }\r
 804 \r
 805 procedure LowerCase(var I:Str130);\r
 806  begin\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
 811  end; { LowerCase }\r
 812 \r
 813 procedure ChopSeven(var I:Str130);\r
 814   var Word:Str130;\r
 815  begin\r
 816   if(length(I)>0)then\r
 817    begin\r
 818     I:=I+' '; x:=1;\r
 819      repeat\r
 820       Word:='';\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
 824        begin\r
 825         y:=pos(Word,I); x:=x+(7-length(Word));\r
 826         delete(I,y,length(Word)); delete(Word,8,130);\r
 827         insert(Word,I,y)\r
 828        end;\r
 829       x:=x+1;\r
 830      until(x-1)=length(I);\r
 831     delete(I,length(I),1)\r
 832    end\r
 833   end; { ChopSeven }\r
 834 \r
 835 procedure FindMood(var input:Str130;var Word:Str29;var Md:byte);\r
 836   var Temp1:Str53;\r
 837       Temp2:Str29;\r
 838       Counter:char;\r
 839  begin\r
 840   Spaces(input);x:=0;\r
 841   while x < AMax do\r
 842    begin x:=x+1;\r
 843     Counter:='1';\r
 844     Temp1:=A[x];\r
 845     while pos(Counter,Temp1)>0 do\r
 846      begin\r
 847       Temp2:=copy(Temp1,1,pos(Counter,Temp1)-1);\r
 848       if(pos(' '+Temp2+' ',input)>0)then\r
 849        begin\r
 850         Word:=Temp2;\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
 854        end;\r
 855       delete(Temp1,1,pos(Counter,Temp1));\r
 856       Counter:=succ(Counter);\r
 857      end;\r
 858    end;\r
 859   QFormat(input);\r
 860  end; { FindMood }\r
 861 \r
 862 function FN(VNP:byte) : Str29; { ( Finds first Noun ) }\r
 863   var Temp:Str29;\r
 864  begin SF;\r
 865   Temp:=n[VNP];\r
 866   FN:=copy(Temp,1,pos('\',Temp)-1);\r
 867  end; { FW }\r
 868 \r
 869 function Here(Obj:byte) : Boolean;\r
 870  begin Here:=false;\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
 875  end;\r
 876 \r
 877 function Present : Boolean;\r
 878   label JUMP;\r
 879  begin Present:=false; x:=0;\r
 880   if not(Vb in [17,18,37,39]) then\r
 881    if N1<>Null then\r
 882     if Here(N1) then\r
 883      if N2<>Null then\r
 884       if Here(N2) then Present:=true\r
 885       else writeln('You can''t see any ',FN(N2),' here.')\r
 886      else Present:=true\r
 887     else writeln('You can''t see any ',FN(N1),' here.')\r
 888    else Present:=true\r
 889   else\r
 890    begin JUMP: x:=x+1;\r
 891     if x<=NMax then\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
 895      else goto JUMP\r
 896     else Present:=true\r
 897    end\r
 898  end; { Present }\r
 899 \r
 900 procedure Convert(var n:byte;Max:byte);\r
 901  begin\r
 902   case Max of\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
 907      end;\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
 915      end;\r
 916    3:case n of                  { Prepositions }\r
 917        2:n:=1; 4:n:=3; 8:n:=7 ;\r
 918      end;\r
 919   end;\r
 920  end; { Convert }\r
 921 \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
 926   const Slash = '\';\r
 927   var j,ps:byte;\r
 928       Temp1,Temp2:Str29;\r
 929  begin\r
 930   QFormat(I); Spaces(I); J:=0;\r
 931   while (j<m[Max]) do\r
 932    begin\r
 933     j:=j+1;\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
 936     while ps>0 do\r
 937      begin\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
 941         VNP:=j;\r
 942         Convert(VNP,Max);\r
 943         Word:=Temp2;\r
 944         delete(I,1,length(Temp2)+1);\r
 945         case Max of 1:VStr:=Word; 2:NStr:=Word end;\r
 946         j:=m[Max];\r
 947         Temp1:='X';\r
 948        end;\r
 949       delete(Temp1,1,ps);\r
 950       ps:=pos(Slash,Temp1);\r
 951      end;\r
 952    end; { main loop }\r
 953   QFormat(I);\r
 954  end; { FindWord }\r
 955 \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
 960    begin\r
 961     if list=SkipList then list:=list+1\r
 962      else\r
 963       begin\r
 964        FindWord(input,VNP,Word,list);\r
 965        if(VNP<>Null)then\r
 966         begin EFlag:=IfFound;list:=list-1;StopLoopFlag:=0;end;\r
 967        list:=list+1;\r
 968       end\r
 969    end;\r
 970   if(EFlag<>IfFound)then\r
 971   begin\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
 976     EFlag:=IfFound\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
 979    QFormat(input);\r
 980   end;\r
 981  end; { Dictionary }\r
 982 \r
 983 procedure RL(Pointer:Integer);\r
 984  begin SF;\r
 985   if(pointer<>StoreL)then\r
 986    begin StoreL:=pointer;\r
 987     seek(L1,pointer);\r
 988     read(L1,Text3)\r
 989    end;\r
 990   writeln(Text3);\r
 991  end; { Read Line }\r
 992 \r
 993 procedure RS(Pointer:Integer);\r
 994  begin SF;\r
 995   if(pointer<>StoreS)then\r
 996    begin StoreS:=pointer;\r
 997     seek(S1,pointer);\r
 998     read(S1,Text4)\r
 999    end;\r
1000   writeln(Text4);\r
1001  end; { Read Special }\r
1002 \r
1003 procedure RR(Pointer:integer);\r
1004  begin SF;\r
1005   if(pointer<>StoreR)then\r
1006    begin StoreR:=pointer;\r
1007     seek(R1,pointer);\r
1008     seek(R2,pointer);\r
1009     read(R1,Text1);\r
1010     read(R2,Text2);\r
1011    end;\r
1012   write(Text1);\r
1013   writeln(Text2);\r
1014  end; { Read Room }\r
1015 \r
1016 procedure RB(Pointer,Colour:byte);\r
1017   var Block:Str255;\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
1025   old:=Pointer+1;\r
1026   repeat readln(T1,Block) until Block=TStart;\r
1027   repeat\r
1028    readln(T1,Block);\r
1029    if(Block<>TStop)then writeln(Block)\r
1030   until Block=TStop; col(11,7);\r
1031  end;\r
1032 \r
1033 procedure RB2(Pointer,Colour:byte);\r
1034   var Block:Str255;\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
1042   old2:=Pointer+1;\r
1043   repeat readln(T2,Block) until Block=TStart;\r
1044   repeat\r
1045    readln(T2,Block);\r
1046    if(Block<>TStop)then writeln(Block)\r
1047   until Block=TStop; col(11,7);\r
1048  end;\r
1049 \r
1050 procedure Won;\r
1051   const W=800;H=400;Q=200;T=131;\r
1052   label JUMP;\r
1053  begin writeln;\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
1061   write('#                                      ',\r
1062         '                                      #');\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
1076   writeln;writeln;\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
1080   repeat\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
1086    tune(3,3,w);\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
1093    tune(3,1,w);\r
1094   until keypressed;\r
1095   JUMP: CFlag:=ReadKey;\r
1096   DoneScrKbd;\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
1099   HALT;\r
1100  end; { Won }\r
1101 \r
1102 procedure PlayerInput(var LINE:Str130);\r
1103   label JUMP;\r
1104   var Ch : Char;\r
1105       ExtCode : integer;\r
1106   procedure Key(k:Str19); begin Line:=Line+k;QFlag:=true;write(k)end;\r
1107  begin\r
1108  {with Result do begin}\r
1109   WRITELN; { Main Space In Game }\r
1110   if(length(Line)=0)then\r
1111    begin\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
1118     bak(7,7);\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
1140     Cur(1);\r
1141     col(14,7);gotoxy(3,19);\r
1142     QFlag:=false;\r
1143     repeat\r
1144      Ch:=Readkey;\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
1148      case Ch of\r
1149      ^h:begin\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
1154         end;\r
1155      ^m:QFlag:=true\r
1156      else\r
1157       begin\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
1161         begin\r
1162          case ExtCode of\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
1171           67:key('Wait');\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
1175           31:SoundTest;\r
1176          end;\r
1177         if Prm in[1..7] then\r
1178          case ExtCode of\r
1179           72:key('Fore'); 75:key('Port'); 77:key('Starboard'); 80:key('Aft')\r
1180          end\r
1181         else\r
1182          case ExtCode of\r
1183           72:key('North'); 75:key('West'); 77:key('East'); 80:key('South')\r
1184          end\r
1185        end\r
1186       end\r
1187      end; {case}\r
1188      until QFlag=true;\r
1189     Cur(3);\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
1195     Spaces(Line);\r
1196     while pos(' then ',Line)>0 do\r
1197      begin\r
1198       x:=pos(' then ',Line);delete(Line,x,5);insert('.',Line,x)\r
1199      end;\r
1200     ChopSeven(Line);\r
1201     PreFormat(Line);\r
1202    end;\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
1208      PreFormat(input);\r
1209     end\r
1210    else\r
1211     begin\r
1212      input:=Line; Line:='';\r
1213     end; { END OF LINE SEPERATION }\r
1214    Spaces(input);\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
1218     end;\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
1222     end;\r
1223    QFormat(input);\r
1224    col(11,7);\r
1225    JUMP:\r
1226  {end;} { of with statement }\r
1227  end; { PlayerInput }\r
1228 \r
1229 procedure Title;\r
1230 {$IFDEF UNIX}\r
1231  var win:pwindow;\r
1232 {$ENDIF}\r
1233  begin\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
1242   end\r
1243   else\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
1249    end;\r
1250   clrscr;textmode(BW80);\r
1251   Cur(3);\r
1252 \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
1258   gotoxy(1,5);\r
1259   cn('APOGEE SOFTWARE PRODUCTIONS');\r
1260   writeln;\r
1261   Col(11,7);\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
1264   writeln;\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
1269   writeln;\r
1270   Col(14,15);\r
1271   writeln('Please make checks payable to:  Scott Miller');\r
1272   writeln;\r
1273   writeln('Scott Miller      (214) 240-0614');\r
1274   writeln('4206 Mayflower Drive');\r
1275   writeln('Garland, TX 75043');\r
1276   writeln;\r
1277   writeln('Also call for help:  Terry Nagy  (214) 271-3065');\r
1278   writeln;\r
1279   Col(11,7);delay(7000);\r
1280   cn('Thanks, enjoy the game...');\r
1281 \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
1286 \r
1287   Bor(1,0);Col(15,15);Bak(4,0);\r
1288 {$IFDEF UNIX}\r
1289   nWindow(win,1,1,80,24);\r
1290   nFrame(win);\r
1291 {$ELSE}\r
1292   for x:=1 to 80 do\r
1293    begin gotoxy(x,1);write(chr(205));gotoxy(x,24);write(chr(205))end;\r
1294   for y:=1 to 24 do\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
1298 {$ENDIF}\r
1299   Bak(1,0);\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
1307   repeat\r
1308    gotoxy(32,8);\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
1312    delay(1);\r
1313   until keypressed;\r
1314   CFlag:=ReadKey;\r
1315 {$IFDEF UNIX}\r
1316   nStop;\r
1317   nDelWindow(win);\r
1318   nSetActiveWin(stdscr);\r
1319   clrscr;\r
1320   nStart;\r
1321 {$ENDIF}\r
1322   if Color then textmode(C80)else textmode(BW80);\r
1323  end; { Title }\r
1324 \r
1325 procedure Init1;\r
1326   label Abort;\r
1327  begin ABORT:\r
1328   Bor(0,0);bak(0,0);clrscr;nosound;\r
1329   Cur(3);randomize;\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
1340 {$IFDEF UNIX}\r
1341    nRefresh(stdscr);\r
1342 {$ENDIF}\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
1349   else begin\r
1350    col(25,31);Bor(4,7);Cn('IDENTITY CODE REJECTED--ABORTING SEQUENCE')end;\r
1351   LowerCase(Identity);ChopSeven(Identity);\r
1352   delay(1500);\r
1353   if Identity='' then goto ABORT;\r
1354   assign(L1,'L1');\r
1355   assign(C1,'C1');\r
1356   assign(S1,'S1');\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
1361  end; { Init1 }\r
1362 \r
1363 procedure Init2;\r
1364  begin\r
1365   col(7,15);bak(1,7);\r
1366 {$IFDEF UNIX}\r
1367   nFrame(stdscr);\r
1368   nWriteAC(stdscr,1,4,TextAttr,nLT);\r
1369   nWriteAC(stdscr,nCols(stdScr),4,TextAttr,nRT);\r
1370   nrefresh(stdscr);\r
1371 {$ELSE}\r
1372   for x:=1 to 80 do\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
1376   for x:=2 to 24 do\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
1381 {$ENDIF}\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
1392 {$IFDEF UNIX}\r
1393   gotoxy(1,3);whLine(win1,nHL,nCols(stdScr)-2);\r
1394   nRefresh(win1);\r
1395 {$ENDIF}\r
1396   nSetActiveWin(win2);\r
1397   bak(0,0);\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
1406   writeln;\r
1407  end; { Init2 }\r
1408 \r
1409 procedure Init3;\r
1410  begin\r
1411   Line    :='';\r
1412   Again   :='z';\r
1413   LastNoun:='mug';\r
1414   Vb      :=Null;\r
1415   Prm     :=8;\r
1416   Sc      :=0;\r
1417   Tic     :=0;\r
1418   PStat   :=[6];\r
1419   Events  :=[];\r
1420   for o   :=1 to MMax do r[o]:=Null;\r
1421   Inv     :=[3,8];\r
1422   Mov     :=[1..29];\r
1423   AlienRm :=Null;\r
1424   FriendRm:=91;\r
1425   Brief   :=[];\r
1426   Wear    :=[];\r
1427   MugCon  :=99;\r
1428   FoodCon :=4;\r
1429   SatchCon:=6;\r
1430   HolstCon:=Null;\r
1431   NicheCon:=Null;\r
1432   SinkRm  :=Null;\r
1433   PyraCon :=Null;\r
1434   Serum   :=Null;\r
1435   HingeCon:=9;\r
1436   PodumCon:=18;\r
1437   RobotCon:=12;\r
1438   Socket  :=[22..25];\r
1439   CodeSet :=7;\r
1440   ScrnSet :=1;\r
1441   Floor   :=1;\r
1442   Region  :=1;\r
1443   TFlag   :=1;\r
1444   Old     :=250;\r
1445   Old2    :=Old;\r
1446   Maze    :=true;\r
1447   Drive   :='A';\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
1454   T[2]    :=0;\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
1464  end; { Init3 }\r
1465 \r
1466 procedure Save;\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
1471   gotoxy(1,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
1476   gotoxy(1,5);\r
1477   writeln('Make sure your SAVE/RESTORE disk is in disk drive ',up(Drive),':');\r
1478   writeln;writeln;\r
1479   write('SAVE under what file name (''',up('/'),''' aborts SAVE)? ');\r
1480   buflen:=8;col(14,15);readline(input);col(11,7);\r
1481   Cur(3);\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
1487   LowerCase(input);\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
1493   { don't put Drive\r
1494   input:=Drive+':'+input;}\r
1495   assign(Objects,input+'.sm1');\r
1496   rewrite(Objects);\r
1497   for x:=0 to RMax do write(Objects,L[x]);\r
1498   close(Objects);\r
1499   assign(Things,input+'.sm2');\r
1500   rewrite(Things);\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
1505   close(Things);\r
1506   assign(Timers,input+'.sm3');\r
1507   rewrite(Timers);\r
1508   write(Timers,Tic,Sc,RC,Floor);\r
1509   for x:=1 to TMax do write(Timers,T[x]);\r
1510   close(Timers);\r
1511   with SetSave do\r
1512    begin aInv:=Inv;aPStat:=PStat;aEvents:=Events;\r
1513     aSocket:=Socket;aWear:=Wear;end;\r
1514   assign(Sets,input+'.sm4');\r
1515   rewrite(Sets);\r
1516   write(Sets,SetSave);\r
1517   close(Sets);\r
1518   writeln;writeln;delete(input,1,2);\r
1519   writeln('Your present game location is now SAVED under the name ',\r
1520            up(input),'.');\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
1526   {$I-}\r
1527   {reset(DiskTest);}\r
1528   {$I+}\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
1534  end; { SAVE }\r
1535 \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
1541   gotoxy(1,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
1546   gotoxy(1,5);\r
1547   writeln('Make sure your SAVE/RESTORE disk is in disk drive ',up(Drive),':');\r
1548   writeln;writeln;\r
1549   write('RESTORE from what file name (''',up('/'),''' aborts RESTORE)? ');\r
1550   buflen:=8;col(14,15);readline(input);col(11,7);\r
1551   Cur(3);\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
1557   LowerCase(input);\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
1563   { Don't put Drive\r
1564   input:=Drive+':'+input;}\r
1565   assign(Objects,input+'.sm1');\r
1566   {$I-}\r
1567   reset(Objects);\r
1568   {$I+}\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
1574    end;\r
1575   reset(Objects);\r
1576   for x:=0 to RMax do read(Objects,L[x]);\r
1577   close(Objects);\r
1578   assign(Things,input+'.sm2');\r
1579   reset(Things);\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
1584   close(Things);\r
1585   assign(Timers,input+'.sm3');\r
1586   reset(Timers);\r
1587   read(Timers,Tic,Sc,RC,Floor);\r
1588   for x:=1 to TMax do read(Timers,T[x]);\r
1589   close(Timers);\r
1590   assign(Sets,input+'.sm4');\r
1591   reset(Sets);\r
1592   read(Sets,SetSave);\r
1593   close(Sets);\r
1594   with SetSave do\r
1595    begin Inv:=aInv;PStat:=aPStat;Events:=aEvents;\r
1596     Socket:=aSocket;Wear:=aWear;end;\r
1597   Add(126);\r
1598   writeln;writeln;delete(input,1,2);\r
1599   writeln('Your present game location is now RESTORED from the name ',\r
1600            up(input),'.');\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
1606   {$I-}\r
1607   {reset(DiskTest);}\r
1608   {$I+}\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
1612   Bor(0,0);\r
1613   case Region of 4:sound(20);5:sound(60)end;\r
1614   if Region>1 then\r
1615    begin\r
1616     n[84]:='reactor regulat\';\r
1617     n[126]:='hinged mouth\mouth\hinge\';\r
1618    end\r
1619    else\r
1620     begin\r
1621      n[84]:='middle table\middle\';\r
1622      n[126]:='bar\';\r
1623     end;\r
1624   if en(34)then n[18]:='glass ball\ball\glass\'\r
1625    else n[18]:='dusty ball\ball\dusty\';\r
1626   if Prm>79 then\r
1627    begin\r
1628     n[40]:='sockets\socket\';\r
1629     n[82]:='laser beam\beam\laser\';\r
1630     n[110]:='speaker\';\r
1631    end else\r
1632    begin\r
1633     n[40]:='cyan button\cyan\';\r
1634     n[82]:='solar map\map\solar\drawing\';\r
1635     n[110]:='keyhole\';\r
1636    end;\r
1637    Min(128);Line:='l';\r
1638  end; { RESTORE }\r
1639 \r
1640 procedure MoreThanOne;\r
1641  begin\r
1642   if((N1=58)or(58 in NounSet)or(N2=58))and Here(3) and Here(4) then\r
1643    begin Cur(2);\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
1650    end;\r
1651   if((N1=86)or(86 in NounSet)or(N2=86))and(Prm=8)then\r
1652    begin Cur(2);\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
1660    end;\r
1661   if((N1=44)or(44 in NounSet)or(N2=44))and(Prm in[1,70])and(Vb<>28)then\r
1662    begin Cur(2);\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
1670    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
1680 \r
1681 \r
1682 function Print(Word:Str29):Str1;\r
1683  begin Print:='';writeln('--you can''t use the word ',Up(Word),' here.')end;\r
1684 \r
1685 procedure Parser_Syntax(var Input:Str130);\r
1686    label JUMP1, JUMP2;\r
1687 begin\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
1693  EFlag:=Null;\r
1694  FindMood(input,Word,Md);\r
1695  if(length(input)>0)then\r
1696   begin\r
1697    FindMood(input,Word,Num);\r
1698    if(Num=Null)then\r
1699     begin\r
1700      FindWord(input,Vb,Word,1);\r
1701      if(Vb<>Null)then\r
1702       if(length(input)=0)then\r
1703        begin\r
1704         if(Vb in NoNounOnly)or(Vb in OneNounMaybe)then EFlag:=Legal;\r
1705         if EFlag<>Legal then\r
1706          begin\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
1712          end\r
1713        end\r
1714       else\r
1715        if(Vb in NoNounOnly)then Dictionary(3,9)\r
1716        else\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
1719           begin\r
1720            if(Vb<>FFlag)then FindWord(input,N1,Word,2);\r
1721            if(N1<>Null)then LastNoun:=FN(N1);\r
1722            if(N1<>Null)then\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
1732                else EFlag:=15\r
1733               else EFlag:=Legal\r
1734              else\r
1735               if(Vb in ToNounMaybe)or(Vb in ToNounOnly)then\r
1736                begin\r
1737                 FindWord(input,Pr,Word,3);\r
1738                 if(Pr<>Null)then\r
1739                  if(length(input)=0)then\r
1740                    if(Vb=50)and(Pr in[1,9])then EFlag:=Legal\r
1741                    else EFlag:=6\r
1742                  else\r
1743                   if(Vb<>50)then  { branch for turning dials }\r
1744                    begin\r
1745                     FindWord(input,N2,Word,2);\r
1746                     if(N2<>Null)then\r
1747                      if(Word<>'all')then\r
1748                       if(length(input)=0)then EFlag:=Legal\r
1749                       else Dictionary(12,9)\r
1750                      else EFlag:=16\r
1751                     else Dictionary(11,2)\r
1752                    end\r
1753                   else\r
1754                    begin\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
1758                    end\r
1759                 else Dictionary(9,3)\r
1760                end\r
1761               else\r
1762                begin Dictionary(3,9);if(List=2)then EFlag:=8;end\r
1763              else EFlag:=16\r
1764            else Dictionary(10,2)\r
1765           end\r
1766          else { Special case for TYPE, characters, etc. }\r
1767           begin\r
1768            QFormat(input);\r
1769            EFlag:=Legal\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
1773           begin N1:=Null;\r
1774            FindWord(input,N1,Word,2);\r
1775            if(N1<>Null)then LastNoun:=FN(N1);\r
1776            if(N1<>Null)then\r
1777             if not(N1 in NounSet)then\r
1778              begin\r
1779               NounSet:=NounSet+[N1];\r
1780               if(length(input)=0)then EFlag:=Legal\r
1781              end\r
1782             else EFlag:=13\r
1783            else Dictionary(10,2)\r
1784           end { of Special case for GET and DROP }\r
1785      else Dictionary(7,1)\r
1786     end\r
1787    else EFlag:=2\r
1788   end\r
1789  else EFlag:=1;\r
1790  if EFlag<>Legal then\r
1791   begin Line:='';play(199,199,55);delay(70);play(60,60,55)end;\r
1792  case EFlag of\r
1793  1:RL(186);\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
1797    else\r
1798     begin\r
1799      write('Noun missing--');\r
1800      case Vb of\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
1804      end;\r
1805      PlayerInput(line);\r
1806      if(length(input)>0)then goto JUMP1;\r
1807     end;\r
1808  5:if(length(Word)>1)then\r
1809     writeln('The word ',up(Word),' is not used in this adventure.')\r
1810    else\r
1811     writeln('The letter ',up(Word),' is not used as shorthand in this parser.');\r
1812  6:begin\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
1817    end;\r
1818  7:write('Verb missing',Print(Word));\r
1819  8:RL(188);\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
1826  15:begin\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
1830      if Vb=49 then\r
1831       begin Pr:=1;\r
1832        writeln('who do you want to ',up(VStr),' the ',up(NStr),' to?')end\r
1833      else begin Pr:=6;\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
1837     end;\r
1838  16:RL(189);\r
1839  17:RL(576)\r
1840  end;\r
1841 end; { Parser Syntax }\r
1842 \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
1848  begin\r
1849   if(Prm=WatchRoom)then RS(MessageNum);\r
1850   case WhichChar of     { 1 = Aliens,  2 = Scientist }\r
1851    1:begin\r
1852       L[AlienRm]:=L[AlienRm]-[124];AlienRm:=ToRoom;\r
1853       L[AlienRm]:=L[AlienRm]+[124]\r
1854      end;\r
1855    2:begin\r
1856       L[FriendRm]:=L[FriendRm]-[123];FriendRm:=ToRoom;\r
1857       L[FriendRm]:=L[FriendRm]+[123]\r
1858      end\r
1859   end;\r
1860   SFlag:=false;\r
1861  end;\r
1862 \r
1863 procedure Van(o:byte);\r
1864  begin\r
1865   Inv:=Inv-[o];\r
1866   r[o]:=Null;\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
1880  end;\r
1881 \r
1882 procedure Crazy;\r
1883  begin SF; RL(random(7)+127)end;\r
1884 \r
1885 procedure NoSense;\r
1886  begin RL(190) end;\r
1887 \r
1888 procedure Say(What1,What2:Str29);\r
1889  begin SF; writeln('The ',What1,' is already ',What2,'.') end;\r
1890 \r
1891 {******************* END OF PARSER AND MISC. PROCEDURES *********************}\r