home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1994 March / Source_Code_CD-ROM_Walnut_Creek_March_1994.iso / compsrcs / games / vmsnet / tetris / part03 < prev    next >
Text File  |  1992-07-01  |  29KB  |  1,052 lines
  1. Path: uunet!caen!kuhub.cc.ukans.edu!nrlvx1.nrl.navy.mil!koffley
  2. Newsgroups: vmsnet.sources.games
  3. Subject: TETRIS_VMS.03_OF_05
  4. Message-ID: <1992Jul2.123936.744@nrlvx1.nrl.navy.mil>
  5. From: koffley@nrlvx1.nrl.navy.mil
  6. Date: 2 Jul 92 12:39:36 -0400
  7. Organization: NRL SPACE SYSTEMS DIVISION
  8. Lines: 1042
  9.  
  10. -+-+-+-+-+-+-+-+ START OF PART 3 -+-+-+-+-+-+-+-+
  11. XX
  12. XXif choice <> '@' then
  13. XXbegin
  14. XX  highscores(score,level,Htable,scores,gotin);
  15. XX  if gotin then viewscores(Htable,scores,key,chan)
  16. XXend
  17. XXend;
  18. XV`7B************************************************************************
  19. V*****
  20. XX*`7D
  21. XV`7B************************************************************************
  22. V*****
  23. XX*`7D
  24. XX
  25. XV`7B************************************************************************
  26. V*****
  27. XX*`7D
  28. XV`7B************************************************************************
  29. V*****
  30. XX*`7D
  31. XXProcedure RESTORE;
  32. XX
  33. XXvar
  34. XX  I:integer;
  35. XX
  36. XXbegin
  37. XX  cls;
  38. XX  writeln('                    Restore saved game option');
  39. XX  usernum(userid);
  40. XX  if (userid = 'CADP02  ') or
  41. XX     (userid = 'CADP03  ') then`20
  42. XX  begin
  43. XX    write('Enter username, MAX 8 letters, RETURN for default: ');
  44. XX    userid:='        ';
  45. XX    readln(userid);
  46. XX    if userid`5B1`5D = ' ' then usernum(userid);
  47. XX  end;
  48. XX  restored:=false;
  49. XX  open(Save,Savefile,history:=readonly);
  50. XX  reset(save);
  51. XX  for I:=1 to 100 do
  52. XX  begin
  53. XX    read(save,peeps`5BI`5D);
  54. XX    if peeps`5BI`5D.user = userid then
  55. XX    begin
  56. XX      cls;
  57. XX      writeln('Restoring...');
  58. XX      lines:=peeps`5BI`5D.lines;
  59. XX      position:=peeps`5BI`5D.position;
  60. XX      x:=peeps`5BI`5D.x;
  61. XX      y:=peeps`5BI`5D.y;
  62. XX      shape:=peeps`5BI`5D.shape;
  63. XX      screen:=peeps`5BI`5D.outp;
  64. XX      score:=peeps`5BI`5D.num;
  65. XX      level:=peeps`5BI`5D.level;
  66. XX      peeps`5BI`5D.user:='UNUSED  ';
  67. XX      restored:=true;
  68. XX    end;
  69. XX  end;
  70. XX  close(save);
  71. XX  open(save,savefile,history:=old);
  72. XX  rewrite(save);
  73. XX  for I:=1 to 100 do
  74. XX    write(save,peeps`5BI`5D);
  75. XX  close(save);
  76. XX  if restored = true then
  77. XX  begin
  78. XX    writeln('Restored.');
  79. XX    writeln('Press any key for main screen');
  80. XX    waitkey(key,chan);
  81. XX    MAINGAME(left,right,rotleft,rotright,speed,quitkey,redraw,level,cheat);
  82. XX  end
  83. XX  else
  84. XX  begin
  85. XX    writeln('Data file not found.');
  86. XX    writeln('Press any key to return to main menu.');
  87. XX    waitkey(key,chan);
  88. XX  end;
  89. XXend;
  90. XX
  91. XV`7B************************************************************************
  92. V*****
  93. XX*`7D
  94. XV`7B************************************************************************
  95. V*****
  96. XX*`7D
  97. XX
  98. XX`7B*******************************************************************`7D
  99. XXbegin `7BSHAPES`7D
  100. XX  cls;
  101. XX  MAKECHAN(chan);
  102. XX  HP := FALSE;
  103. XX  flag:=true;
  104. XX  flag2:=false;
  105. XX  cheat:=false;
  106. XX  left:='z';right:='x';rotleft:='o';rotright:='p';speed:='`5B';quitkey:='q'
  107. V;
  108. XX  factor:=0.15;
  109. XX  redraw:='r';
  110. XX  levelmin:=1;
  111. XX  for I:=1 to 22 do
  112. XX    begin `7Bfor`7D
  113. XX    for J:=1 to 10 do
  114. XX      screen`5BI,J`5D:=0;
  115. XX    end; `7Bfor`7D
  116. XX  repeat
  117. XX    MENUPRINT;
  118. XX    repeat
  119. XX      if chr(key) = 'c' then flagA:=true;
  120. XX      if chr(key) = 'a' then
  121. XX      begin
  122. XX        if flagA = true then flagB:=true
  123. XX        else flagB:=false;
  124. XX      end;
  125. XX      if chr(key) = 'd' then
  126. XX      begin
  127. XX        if flagB = true then flagC:=true
  128. XX        else flagC:=false;
  129. XX      end;
  130. XX      if chr(key) = 'p' then
  131. XX      begin
  132. XX        if flagC = true then flagD:=true
  133. XX        else flagD:=false;
  134. XX      end;
  135. XX      if (chr(key) <> 'c') and (chr(key) <> 'a') and
  136. XX         (chr(key) <> 'd') and (chr(key) <> 'p') then
  137. XX      begin
  138. XX        flagA:=false;
  139. XX        flagB:=false;
  140. XX        flagC:=false;
  141. XX        flagD:=false;
  142. XX      end;
  143. XX      waitkey(key,chan);
  144. XX    until chr(key) in `5B'0'..'8'`5D;`20
  145. XX    level:=levelmin;
  146. XX    if chr(key) <> '8' then flagD:=false;
  147. XX    if chr(key)='1' then
  148. XX      MAINGAME(left,right,rotleft,rotright,speed,quitkey,redraw,level,cheat
  149. V);
  150. XV    if chr(key)='2' then KEYDEFINE(left,right,rotleft,rotright,speed,quitke
  151. Vy,r
  152. XXedraw);
  153. XX    if chr(key)='3' then VIEWSCORES(Htable,scores,key,chan);
  154. XX    if chr(key)='4' then INSTRUCTIONS;
  155. XX    if chr(key)='5' then flag:=not(flag);
  156. XX    if chr(key)='6' then flag2:=not(flag2);
  157. XX    if chr(key)='7' then RESTORE;
  158. XX    if flagD then
  159. XX    begin
  160. XX      cheat:=true;
  161. XX      write('level??: ');
  162. XX      readln(levelmin);
  163. XX      write('reset savefile??: ');
  164. XX      readln(answer);
  165. XX      if (answer = 'y') or (answer = 'Y') then
  166. XX      begin
  167. XX        blank.user:='UNUSED  ';
  168. XX        open(Save,Savefile,history:=unknown);
  169. XX        rewrite(save);
  170. XX        for I:=1 to 100 do
  171. XX          write(save,blank);
  172. XX        close(save);
  173. XX      end;
  174. XX      write('reset scoreboard??: ');
  175. XX      readln(answer);
  176. XX      if (answer='y') or (answer ='Y') then
  177. XX      begin
  178. XX        open (Htable , Htablefile ,
  179. XX`60009  history := unknown);
  180. XX        rewrite(Htable);
  181. XX        for A:= 1 to 10 do
  182. XX        begin
  183. XX          scores`5BA`5D.num:=0;
  184. XX          scores`5BA`5D.name:='                                        ';
  185. XX          scores`5BA`5D.level:=1;
  186. XX          scores`5BA`5D.id:='        ';
  187. XX        end;
  188. XX        for A:=1 to 10 do
  189. XX          write(Htable,scores`5BA`5D);
  190. XX        close(Htable);
  191. XX      end;
  192. XX    end;
  193. XX  until (chr(key)='0');
  194. XX  cls;
  195. XX    writeln('There now, that didn''t hurt much did it??');
  196. XX    writeln('Byeeeeeeeeee........');
  197. XXend. `7BSHAPES`7D
  198. XX`7B*******************************************************************`7D
  199. XX
  200. X$GoSub Convert_File
  201. X$Exit
  202. $ CALL UNPACK TETRIS_BUILD.COM;1 728168150
  203. $ create 'f'
  204. Xprogram Shapes(input,output,Htable,Save);
  205. X
  206. X
  207. X`7B*************************************************************************
  208. V******
  209. X   Copyright 1989,1990 by Colin Cowie, Glasgow, Scotland.
  210. X
  211. X                        All Rights Reserved
  212. X
  213. X   Permission to use, copy, modify, and distribute this software and its`20
  214. X   documentation for any purpose and without fee is hereby granted,`20
  215. X   provided that the above copyright notice appear in all copies and that
  216. X   both that copyright notice and this permission notice appear in`20
  217. X   supporting documentation.
  218. X****************************************************************************
  219. V***`7D
  220. X
  221. X
  222. X
  223. Xconst
  224. X  Htablefile='my$root:`5Brcd.tetris`5DHtable.dat';
  225. X  Savefile='my$root:`5Brcd.tetris`5Dsave.dat';
  226. X
  227. Xtype
  228. X  string = packed array`5B1..8`5D of char;
  229. X  scorerec = record
  230. X      num:integer;
  231. X     name:packed array`5B1..40`5D of char;
  232. X     level:integer;
  233. X     id:string;
  234. X     end;
  235. X  recfile = file of scorerec;
  236. X  scorearray = array`5B1..10`5D of scorerec;
  237. X  screenarray = array`5B1..22,1..10`5D of integer;
  238. X  timearray = packed array`5B1..11`5D of char;
  239. X  datestr = packed array `5B1..11`5D of char;
  240. X  saverec = record
  241. X     num:integer;
  242. X     level:integer;
  243. X     outp:screenarray;
  244. X     x:integer;
  245. X     y:integer;
  246. X     shape:integer;
  247. X     position:integer;
  248. X     lines:integer;
  249. X     user:string;
  250. X     current:datestr;
  251. X      end;
  252. X  saverecfile = file of saverec;
  253. X  savearray = array`5B1..100`5D of saverec;
  254. X
  255. Xvar
  256. X  restored:boolean;
  257. X  blank:saverec;
  258. X  peeps:savearray;
  259. X  HP:boolean;
  260. X  factor:real;
  261. X  curr:timearray;
  262. X  flag,
  263. X  flag2:boolean;
  264. X  answer:char;
  265. X  del:boolean;
  266. X  userid:string;
  267. X  flagA,
  268. X  flagB,
  269. X  flagC,
  270. X  flagD:boolean;
  271. X  chan:integer;
  272. X  key:integer;
  273. X  xchrhigh,
  274. X  xchrlow,
  275. X  ychrhigh,
  276. X  ychrlow:char;
  277. X  score,
  278. X  shape,
  279. X  position:integer;
  280. X  cheat:boolean;
  281. X  currd:datestr;
  282. X  I,J,A:integer;
  283. X  x,y:integer;
  284. X  scores:scorearray;
  285. X  OTT:boolean;
  286. X  Htable:recfile;
  287. X  Save,
  288. X  Saver:saverecfile;
  289. X  level:integer;
  290. X  levelmin:integer;
  291. X  screen:screenarray;
  292. X  left,
  293. X  right,
  294. X  rotleft,
  295. X  rotright,
  296. X  speed,
  297. X  redraw,
  298. X  quitkey:char;
  299. X  lines:integer;
  300. X
  301. X`7B*****************************************************************`7D
  302. Xprocedure CLS;
  303. Xbegin `7BCLS`7D
  304. Xwrite(chr(27),'`5BH');
  305. Xwriteln(chr(27),'`5B2J');
  306. Xend; `7BCLS`7D
  307. X`7B*****************************************************************`7D
  308. X
  309. X`7B*****************************************************************`7D
  310. X`7B*************************************************************************
  311. V****`7D
  312. Xprocedure makechan(%REF chan:integer);external;
  313. X
  314. Xprocedure readkey(%REF key,chan:integer);external;
  315. X
  316. Xprocedure waitkey(%REF key,chan:integer);external;
  317. X
  318. Xprocedure waitx(%REF factor:real);external;
  319. X
  320. Xprocedure spawn;external;
  321. X
  322. Xprocedure RANDOMISE;fortran;
  323. X
  324. Xfunction RANDOM(min,max:integer):integer;fortran;
  325. X
  326. Xprocedure USERNUM(%stdescr userid:string);fortran;
  327. X`7B*****************************************************************`7D
  328. X
  329. X
  330. X`7B******************************************************************`7D
  331. Xprocedure highscores(score:integer; bit:integer; var Htable:recfile;
  332. X var scores:scorearray; var gotin:boolean);
  333. X
  334. X
  335. Xvar
  336. X  I,J:integer;
  337. X  newscore:scorerec;
  338. X  A:integer;
  339. X  two:boolean;
  340. X
  341. Xbegin
  342. X  gotin:=false;
  343. X  cls;
  344. X  writeln('You scored: ',score,' points!!');
  345. X  I:=1;
  346. X  open (Htable, Htablefile,
  347. X        history:=readonly);
  348. X  reset(Htable);
  349. X  while (not eof(Htable)) and (I <=10) do
  350. X  begin
  351. X    read(Htable,scores`5BI`5D);
  352. X    I:=I+1;
  353. X  end;
  354. X  close(Htable);
  355. X  for A:= I to 10 do
  356. X  begin
  357. X    scores`5BA`5D.num:=0;
  358. X    scores`5BA`5D.name:='                                        ';
  359. X    scores`5BA`5D.level:=1;
  360. X    scores`5BA`5D.id:='        ';
  361. X  end;
  362. X  if score > scores`5B10`5D.num then
  363. X  begin
  364. X    two := true;
  365. X    usernum(userid);
  366. X    if (userid='CADP03  ') or
  367. X       (userid='CADP02  ') or
  368. X       (userid='CRAA30  ') or
  369. X       (userid='CRAA38  ') then
  370. X    begin
  371. X      writeln('Enter usernum, maximum 8 chars (RETURN for default):');
  372. X      write(':');
  373. X      userid:='        ';
  374. X      readln(userid);
  375. X      if userid`5B1`5D=' ' then usernum(userid);
  376. X    end;
  377. X
  378. X    for I := 10 downto 1 do
  379. X    begin
  380. X      if userid = scores`5BI`5D.id then
  381. X      begin`20
  382. X       if score > scores`5BI`5D.num then
  383. X        begin
  384. X          for J := I to 9 do
  385. X            scores`5BJ`5D := scores`5BJ+1`5D;
  386. X          if I = 9 then
  387. X            scores`5B9`5D := scores`5B10`5D;
  388. X          scores`5B10`5D.num:=0;
  389. X          scores`5B10`5D.name:='                                       ';
  390. X          scores`5B10`5D.level:=1;
  391. X          scores`5B10`5D.id:='        ';
  392. X        end
  393. X        else
  394. X        begin
  395. X          two := false;
  396. X        end;
  397. X      end;
  398. X    end;
  399. X    if two = true then
  400. X    begin
  401. X      gotin:=true;
  402. X      writeln('Well done, yu have made it into the top ten!!');
  403. X      for A:=1 to 20 do
  404. X        newscore.name`5BA`5D:=' ';
  405. X      Writeln('Enter name, maximum 40 chars:');
  406. X      write(':');
  407. X      readln(newscore.name);
  408. X      usernum(userid);
  409. X      if (userid='CADP03  ') or`20
  410. X         (userid='CADP02  ') or`20
  411. X         (userid='CRAA30  ') or
  412. X         (userid='CHBS08  ') then
  413. X      begin
  414. X        writeln('Enter usernum, maximum 8 chars (RETURN for default):');
  415. X        write(':');
  416. X        userid:='        ';
  417. X        readln(userid);
  418. X        if userid`5B1`5D=' ' then usernum(userid);
  419. X      end;
  420. X      newscore.num:=score;
  421. X      newscore.level:=bit;
  422. X      newscore.id:=userid;
  423. X      I:=1;
  424. X      while newscore.num < scores`5BI`5D.num do
  425. X        I:=I+1;
  426. X      for A:=10 downto I+1 do
  427. X        scores`5BA`5D:=scores`5BA-1`5D;   `20
  428. X      scores`5BI`5D:=newscore;
  429. X      open (Htable , Htablefile ,
  430. X  `09history := old);
  431. X      rewrite(Htable);
  432. X      for I:=1 to 10 do
  433. X        write(Htable,scores`5BI`5D);
  434. X      close (Htable);
  435. X      writeln('Press any key to view high-score table');
  436. X    end
  437. X    else
  438. X    begin
  439. X      writeln('One entry only per usernum in the high score table!!');
  440. X      writeln('Press any key to return to main menu');
  441. X    end;
  442. X  end
  443. X  else
  444. X  begin
  445. X    writeln('Sorry, yu didnt make the high score table!!!!!!');
  446. X    writeln('Press any key to return to main menu');
  447. X  end;
  448. X  waitkey(key,chan);
  449. Xend;
  450. X`7B*************************************************************`7D
  451. X
  452. X
  453. X`7B*************************************************************`7D
  454. Xprocedure viewscores(var Htable:recfile; scores:scorearray; key,chan:integer
  455. V);
  456. X
  457. Xvar
  458. X  score:scorerec;
  459. X  I,
  460. X  A:integer;
  461. X
  462. Xbegin
  463. X  cls;
  464. X  open (Htable, Htablefile,
  465. X        history:=readonly);
  466. X  reset(Htable);
  467. X  I:=1;
  468. X  while (not eof(Htable)) and (I <=10) do`20
  469. X  begin
  470. X    read(Htable,score);
  471. X    scores`5BI`5D:=score;
  472. X    I:=I+1;
  473. X  end;
  474. X  close (Htable);
  475. X  for A:= I to 10 do
  476. X  begin
  477. X    scores`5BI`5D.num:=0;
  478. X    scores`5BI`5D.name:='                                        ';
  479. X    scores`5BI`5D.level:=1;
  480. X    scores`5BI`5D.id:='        ';
  481. X  end;
  482. X  Writeln('                       Shapes HIGH SCORE TABLE');
  483. X  writeln;writeln;
  484. X  writeln('          score              name                           level
  485. V  userid');
  486. X  for I:=1 to 10 do
  487. X  begin
  488. X    writeln(I:2,'. ',scores`5BI`5D.num,'     ',scores`5BI`5D.name,'  ',
  489. X            scores`5BI`5D.level:2,'    ',scores`5BI`5D.id);
  490. X  end;
  491. Xwriteln;writeln;
  492. Xwriteln('                         Press any key to return to main menu');
  493. Xwaitkey(key,chan);
  494. Xend;
  495. X
  496. X`7B***********************************************************`7D
  497. X
  498. X
  499. X`7B************************************************************`7D
  500. Xprocedure INTOCHAR(var xchrhigh,xchrlow,
  501. X                       ychrhigh,ychrlow:char; x,y:integer);
  502. X
  503. Xbegin `7BINTOCHAR`7D
  504. X  xchrhigh`09:= chr(ord('0') + x div 10) ;
  505. X  xchrlow`09:= chr(ord('0') + x mod 10) ;
  506. X
  507. X  ychrhigh`09:= chr(ord('0') + y div 10) ;
  508. X  ychrlow`09:= chr(ord('0') + y mod 10) ;
  509. X
  510. Xend; `7BINTOCHAR`7D
  511. X`7B*********************************************************************`7D
  512. X
  513. X
  514. X`7B*****************************************************************`7D
  515. Xprocedure MENUPRINT;
  516. X
  517. Xbegin
  518. X  CLS;
  519. X  writeln(chr(27),'#3               Shapes');
  520. X  writeln(chr(27),'#4               Shapes');
  521. X  writeln(chr(27),'`5B22;25HCopyright 1989,1990 LokiSoft Ltd.');
  522. X  writeln(chr(27),'`5B09;31H1. Play Shapes');
  523. X  writeln(chr(27),'`5B10;31H2. Redefine Keys');
  524. X  writeln(chr(27),'`5B11;31H3. View Score Board');
  525. X  writeln(chr(27),'`5B12;31H4. Instructions');
  526. X  write(chr(27),'`5B13;31H5. Print Next Shape');
  527. X  if flag then writeln('  (YES)') else writeln('  (NO) ');
  528. X  write(chr(27),'`5B14;31H6. Slow Down Game');
  529. X  if flag2 then writeln('   (YES)') else writeln('   (NO) ');
  530. X  writeln(chr(27),'`5B15;31H7. Restore Saved Game');
  531. X  writeln(chr(27),'`5B17;31H0. Exit from game');
  532. X  writeln(chr(27),'`5B19;31HEnter choice from options above');
  533. X  writeln;
  534. Xend;
  535. X`7B**********************************************************************`7D
  536. X`7B*****************************`7D
  537. Xprocedure Instructions;
  538. Xbegin
  539. Xcls;
  540. Xwriteln('Hi Guys, here''s another offering from the LokiSoft label,');
  541. Xwriteln('except this one''s good!!!!');
  542. Xwriteln;
  543. Xwriteln('This game is based on a certain arcade game which you may have ');
  544. Xwriteln('played at sometime or other, but I aint mentioning which one cos');
  545. Xwriteln('this is a blatant rip-off of it so its really dead obvious!!');
  546. Xwriteln;
  547. Xwriteln('Anyway, its like this: there are these seven different shapes:-');
  548. Xwriteln;
  549. Xwriteln('@@        @        @        @        @        @        @');
  550. Xwriteln('@@        @        @        @@      @@        @@       @');
  551. Xwriteln('          @@      @@         @      @         @        @');
  552. Xwriteln('                                                       @');
  553. Xwriteln('And these shapes fall from the top of the screen to the bottom,');
  554. Xwriteln('piling on top of one another.');
  555. Xwriteln('You can rotate each shape, and move it left or right, the ');
  556. Xwriteln('object being to get complete unbroken lines of "@@@@@@@@@@" at ');
  557. Xwriteln('the bottom of the screen.');
  558. Xwriteln('when this happens, that line is deleted, and the pile drops down');
  559. Xwriteln('and you are given points depending on which level you are on');
  560. Xwriteln;
  561. Xwriteln('                           Press any key for next page');
  562. Xwaitkey(key,chan);
  563. Xcls;
  564. Xwriteln;
  565. Xwriteln('If you are fortunate enough to get more than one completed line at'
  566. V);
  567. Xwriteln('a time, you receive a bonus dependent on the level you are on and t
  568. Vhe');
  569. Xwriteln('number of lines completed.');
  570. Xwriteln('After completing 5 lines, you move on to level 2 where you have to'
  571. V);
  572. Xwriteln('complete 10 lines,..15 for level 3, and so on.');
  573. Xwriteln('There is a bonus at the end of each level depending on which level'
  574. V);
  575. Xwriteln('you are on, and how low the pile of bricks is,..the lower the pile,
  576. V');
  577. Xwriteln('the higher the bonus');
  578. Xwriteln('For each level, the number of points per completed line, and potent
  579. Vial');
  580. Xwriteln('bonus per level is increased, and there are an infinite number');
  581. Xwriteln('of levels in the game.');
  582. Xwriteln;
  583. Xwriteln('The default keys are: z - left, x - right,');
  584. Xwriteln('                o - rotate left, p - rotate right,');
  585. Xwriteln('     `5B - move shape to bottom, r - redraw screen, q - quit');
  586. Xwriteln('     ! - to spawn to dcl, @ - to save game');
  587. Xwriteln;
  588. Xwriteln('                           Press any key for next page');
  589. Xwaitkey(key,chan);
  590. Xcls;
  591. Xwriteln('Note on Saving game:-');
  592. Xwriteln;
  593. Xwriteln('It is only possible for any user to have one saved game at a time,'
  594. V);
  595. Xwriteln('and if you attempt to save a game when you already have one stored,
  596. V');
  597. Xwriteln('the stored game will be written over!!!');
  598. Xwriteln('Stored games will automatically be deleted when restored.');
  599. Xwriteln;
  600. Xwriteln('There is total space on the save-file for 100 games, and when it is
  601. V');
  602. Xwriteln('full, whenever anyone attempts to save their game, the oldest previ
  603. Vous');
  604. Xwriteln('saved game is written over!');
  605. Xwriteln;
  606. Xwriteln('Note on Slowing down game option:-');
  607. Xwriteln;
  608. Xwriteln('This option is intended only for people using workstations or simil
  609. Var');
  610. Xwriteln('which vastly speed up the screen printing, thereby making the game'
  611. V);
  612. Xwriteln('unplayable. The slow down option negates this problem.');
  613. Xwriteln;
  614. Xwriteln('Now I''ll take this opportunity to wish you happy playing and good'
  615. V);
  616. Xwriteln('luck, you''ll need it!!!!');
  617. Xwriteln(chr(27),'`5B22;30HPress any key for main menu');
  618. Xwaitkey(key,chan);
  619. Xend;
  620. X`7B*****************************`7D
  621. X
  622. X
  623. X
  624. X`7B*******************************************************************`7D `2
  625. V0
  626. Xprocedure KEYDEFINE(var left,right,rotleft,rotright,speed,quitkey,redraw:cha
  627. Vr);
  628. X
  629. Xvar
  630. X
  631. X  redrawint,
  632. X  null,
  633. X  leftint,
  634. X  rightint,
  635. X  rotleftint,
  636. X  rotrightint,
  637. X  speedint,
  638. X  stopint:integer;
  639. X  quitint:integer;
  640. X
  641. Xbegin `7BKEYDEFINE`7D
  642. X  CLS;
  643. X  writeln('         Defining Keys For SHAPES ');
  644. X  writeln;
  645. X  writeln;
  646. X  writeln;
  647. X  writeln;
  648. X  writeln('Press key for movement LEFT: ');
  649. X  waitkey(leftint,chan);
  650. X  left:=chr(leftint);
  651. X  writeln(left);
  652. X  writeln('press key for movement RIGHT: ');
  653. X  waitkey(rightint,chan);
  654. X  while (rightint=leftint) do
  655. X    waitkey(rightint,chan);
  656. X  right:=chr(rightint);
  657. X  writeln(right);
  658. X  writeln('Press key for rotation ANTICLOCKWISE: ');
  659. X  waitkey(rotleftint,chan);
  660. X  while (rotleftint=leftint) or
  661. X        (rotleftint=rightint) do
  662. X    waitkey(rotleftint,chan);
  663. X  rotleft:=chr(rotleftint);
  664. X  writeln(rotleft);
  665. X  writeln('press key for rotation CLOCKWISE: ');
  666. X  waitkey(rotrightint,chan);
  667. X  while (rotrightint=rightint) or
  668. X        (rotrightint=rotleftint) or
  669. X        (rotrightint=leftint) do
  670. X    waitkey(rotrightint,chan);
  671. X  rotright:=chr(rotrightint);
  672. X  writeln(rotright);
  673. X  writeln('press key to move shape to bottom: ');
  674. X  waitkey(speedint,chan);
  675. X  while (speedint=rightint) or`20
  676. X        (speedint=leftint) or`20
  677. X        (speedint=rotleftint) or
  678. X        (speedint=rotrightint) do
  679. X    waitkey(speedint,chan);
  680. X  speed:=chr(speedint);
  681. X  writeln(speed);
  682. X  writeln('press key to quit game: ');
  683. X  waitkey(quitint,chan);
  684. X  while (quitint=rightint) or`20
  685. X        (quitint=leftint) or`20
  686. X        (quitint=rotleftint) or
  687. X        (quitint=rotrightint) or
  688. X        (quitint=speedint) do
  689. X    waitkey(quitint,chan);
  690. X  quitkey:=chr(quitint);
  691. X  writeln(quitkey);
  692. X  writeln('press key to redraw screen');
  693. X  waitkey(redrawint,chan);
  694. X  while (redrawint=rightint) or
  695. X        (redrawint=leftint) or
  696. X        (redrawint=rotrightint) or
  697. X        (redrawint=rotleftint) or
  698. X        (redrawint=quitint) do
  699. X    waitkey(redrawint,chan);
  700. X  redraw:=chr(redrawint);
  701. X  writeln(redraw);
  702. X  writeln;
  703. X  writeln;
  704. X  writeln;
  705. X  writeln('    Press any key to continue ');
  706. X  waitkey(null,chan);
  707. Xend; `7BKEYDEFINE`7D
  708. X`7B*******************************************************************`7D
  709. X
  710. X
  711. X
  712. X`7B***********************************************************************`7
  713. VD
  714. Xprocedure Shapestuff(shape,position,y,x:integer; var screen:screenarray;
  715. X                     n:integer);
  716. Xbegin
  717. X  screen`5By,x`5D:=n;
  718. X  if shape = 1 then
  719. X  begin
  720. X    screen`5By,x+1`5D:=n;
  721. X    screen`5By+1,x`5D:=n;
  722. X    screen`5By+1,x+1`5D:=n;
  723. X  end
  724. X  else
  725. X  if shape = 2 then
  726. X  begin
  727. X    if position = 1 then
  728. X    begin
  729. X      screen`5By-1,x`5D:=n;
  730. X      screen`5By+1,x`5D:=n;
  731. X      screen`5By+1,x+1`5D:=n;
  732. X    end
  733. X    else
  734. X    if position = 2 then
  735. X    begin
  736. X      screen`5By,x+1`5D:=n;
  737. X      screen`5By,x-1`5D:=n;
  738. X      screen`5By+1,x-1`5D:=n;
  739. X    end
  740. X    else
  741. X    if position = 3 then
  742. X    begin
  743. X      screen`5By+1,x`5D:=n;
  744. X      screen`5By-1,x`5D:=n;
  745. X      screen`5By-1,x-1`5D:=n;
  746. X    end
  747. X    else
  748. X    if position = 4 then
  749. X    begin
  750. X      screen`5By,x-1`5D:=n;
  751. X      screen`5By,x+1`5D:=n;
  752. X      screen`5By-1,x+1`5D:=n;
  753. X    end;
  754. X  end
  755. X  else
  756. X  if shape = 3 then
  757. X  begin
  758. X    if position = 1 then
  759. X    begin
  760. X      screen`5By-1,x`5D:=n;
  761. X      screen`5By+1,x`5D:=n;
  762. X      screen`5By+1,x-1`5D:=n;
  763. X    end
  764. X    else
  765. X    if position = 2 then
  766. X    begin
  767. X      screen`5By,x+1`5D:=n;
  768. X      screen`5By,x-1`5D:=n;
  769. X      screen`5By-1,x-1`5D:=n;
  770. X    end
  771. X    else
  772. X    if position = 3 then
  773. X    begin
  774. X      screen`5By-1,x`5D:=n;
  775. X      screen`5By+1,x`5D:=n;
  776. X      screen`5By-1,x+1`5D:=n;
  777. X    end
  778. X    else
  779. X    if position = 4 then
  780. X    begin
  781. X      screen`5By,x-1`5D:=n;
  782. X      screen`5By,x+1`5D:=n;
  783. X      screen`5By+1,x+1`5D:=n;
  784. X    end;
  785. X  end
  786. X  else
  787. X  if shape = 4 then
  788. X  begin
  789. X    if position = 1 then
  790. X    begin
  791. X      screen`5By-1,x`5D:=n;
  792. X      screen`5By+1,x`5D:=n;
  793. X      screen`5By,x+1`5D:=n;
  794. X    end
  795. X    else
  796. X    if position = 2 then
  797. X    begin
  798. X      screen`5By+1,x`5D:=n;
  799. X      screen`5By,x-1`5D:=n;
  800. X      screen`5By,x+1`5D:=n;
  801. X    end
  802. X    else
  803. X    if position = 3 then
  804. X    begin
  805. X      screen`5By-1,x`5D:=n;
  806. X      screen`5By+1,x`5D:=n;
  807. X      screen`5By,x-1`5D:=n;
  808. X    end
  809. X    else
  810. X    if position = 4 then
  811. X    begin
  812. X      screen`5By-1,x`5D:=n;
  813. X      screen`5By,x-1`5D:=n;
  814. X      screen`5By,x+1`5D:=n;
  815. X    end;
  816. X  end
  817. X  else
  818. X  if shape = 5 then
  819. X  begin
  820. X    if (position = 1) or (position = 3) then
  821. X    begin
  822. X      screen`5By+1,x`5D:=n;
  823. X      screen`5By,x+1`5D:=n;
  824. X      screen`5By-1,x+1`5D:=n;
  825. X    end
  826. X    else
  827. X    if (position = 2) or (position = 4) then
  828. X    begin
  829. X      screen`5By,x-1`5D:=n;
  830. X      screen`5By+1,x`5D:=n;
  831. X      screen`5By+1,x+1`5D:=n;
  832. X    end;
  833. X  end
  834. X  else
  835. X  if shape = 6 then
  836. X  begin
  837. X    if (position = 1) or (position = 3) then
  838. X    begin
  839. X      screen`5By-1,x`5D:=n;
  840. X      screen`5By,x+1`5D:=n;
  841. X      screen`5By+1,x+1`5D:=n;
  842. X    end
  843. X    else
  844. X    if (position = 2) or (position = 4) then
  845. X    begin
  846. X      screen`5By,x+1`5D:=n;
  847. X      screen`5By+1,x`5D:=n;
  848. X      screen`5By+1,x-1`5D:=n;
  849. X    end;
  850. X  end
  851. X  else
  852. X  if shape = 7 then
  853. X  begin
  854. X    if (position = 1) or (position = 3) then
  855. X    begin
  856. X      screen`5By-1,x`5D:=n;
  857. X      screen`5By+1,x`5D:=n;
  858. X      screen`5By+2,x`5D:=n;
  859. X    end
  860. X    else
  861. X    if (position = 2) or (position = 4) then
  862. X    begin
  863. X      screen`5By,x-2`5D:=n;
  864. X      screen`5By,x-1`5D:=n;
  865. X      screen`5By,x+1`5D:=n;
  866. X    end;
  867. X  end;
  868. Xend;
  869. X`7B*************************************************************************
  870. V***`7D
  871. X
  872. X
  873. X`7B***********************************************************************`7
  874. VD
  875. Xprocedure Check(shape,position,y,x:integer; var change:boolean);
  876. X
  877. Xbegin
  878. X  change:=true;
  879. X  if shape = 2 then
  880. X  begin
  881. X    if position = 1 then
  882. X    begin
  883. X      if screen`5By-1,x`5D=1 then change:= false
  884. X    else
  885. X      if screen`5By+1,x`5D=1 then change:= false
  886. X    else
  887. X      if screen`5By+1,x+1`5D=1 then change:= false;
  888. X    end
  889. X    else
  890. X    if position = 2 then
  891. X    begin
  892. X      if screen`5By,x+1`5D=1 then change:= false else
  893. X      if screen`5By,x-1`5D=1 then change:= false else
  894. X      if screen`5By+1,x-1`5D=1 then change:= false;
  895. X    end
  896. X    else
  897. X    if position = 3 then
  898. X    begin
  899. X      if screen`5By+1,x`5D=1 then change:= false else
  900. X      if screen`5By-1,x`5D=1 then change:= false else
  901. X      if screen`5By-1,x-1`5D=1 then change:= false;
  902. X    end
  903. X    else
  904. X    if position = 4 then
  905. X    begin
  906. X      if screen`5By,x-1`5D=1 then change:= false else
  907. X      if screen`5By,x+1`5D=1 then change:= false else
  908. X      if screen`5By-1,x+1`5D=1 then change:= false;
  909. X    end;
  910. X  end
  911. X  else
  912. X  if shape = 3 then
  913. X  begin
  914. X    if position = 1 then
  915. X    begin
  916. X      if screen`5By-1,x`5D=1 then change:= false else
  917. X      if screen`5By+1,x`5D=1 then change:= false else
  918. X      if screen`5By+1,x-1`5D=1 then change:= false;
  919. X    end
  920. X    else
  921. X    if position = 2 then
  922. X    begin
  923. X      if screen`5By,x+1`5D=1 then change:= false else
  924. X      if screen`5By,x-1`5D=1 then change:= false else
  925. X      if screen`5By-1,x-1`5D=1 then change:= false;
  926. X    end
  927. X    else
  928. X    if position = 3 then
  929. X    begin
  930. X      if screen`5By-1,x`5D=1 then change:= false else
  931. X      if screen`5By+1,x`5D=1 then change:= false else
  932. X      if screen`5By-1,x+1`5D=1 then change:= false;
  933. X    end
  934. X    else
  935. X    if position = 4 then
  936. X    begin
  937. X      if screen`5By,x-1`5D=1 then change:= false else
  938. X      if screen`5By,x+1`5D=1 then change:= false else
  939. X      if screen`5By+1,x+1`5D=1 then change:= false;
  940. X    end;
  941. X  end
  942. X  else
  943. X  if shape = 4 then
  944. X  begin
  945. X    if position = 1 then
  946. X    begin
  947. X      if screen`5By-1,x`5D=1 then change:= false else
  948. X      if screen`5By+1,x`5D=1 then change:= false else
  949. X      if screen`5By,x+1`5D=1 then change:= false;
  950. X    end
  951. X    else
  952. X    if position = 2 then
  953. X    begin
  954. X      if screen`5By+1,x`5D=1 then change:= false else
  955. X      if screen`5By,x-1`5D=1 then change:= false else
  956. X      if screen`5By,x+1`5D=1 then change:= false;
  957. X    end
  958. X    else
  959. X    if position = 3 then
  960. X    begin
  961. X      if screen`5By-1,x`5D=1 then change:= false else
  962. X      if screen`5By+1,x`5D=1 then change:= false else
  963. X      if screen`5By,x-1`5D=1 then change:= false;
  964. X    end
  965. X    else
  966. X    if position = 4 then
  967. X    begin
  968. X      if screen`5By-1,x`5D=1 then change:= false else
  969. X      if screen`5By,x-1`5D=1 then change:= false else
  970. X      if screen`5By,x+1`5D=1 then change:= false;
  971. X    end;
  972. X  end
  973. X  else
  974. X  if shape = 5 then
  975. X  begin
  976. X    if (position = 1) or (position = 3) then
  977. X    begin
  978. X      if screen`5By+1,x`5D=1 then change:= false else
  979. X      if screen`5By,x+1`5D=1 then change:= false else
  980. X      if screen`5By-1,x+1`5D=1 then change:= false;
  981. X    end
  982. X    else
  983. X    if (position = 2) or (position = 4) then
  984. X    begin
  985. X      if screen`5By,x-1`5D=1 then change:= false else
  986. X      if screen`5By+1,x`5D=1 then change:= false else
  987. X      if screen`5By+1,x+1`5D=1 then change:= false;
  988. X    end;
  989. X  end
  990. X  else
  991. X  if shape = 6 then
  992. X  begin
  993. X    if (position = 1) or (position = 3) then
  994. X    begin
  995. X      if screen`5By-1,x`5D=1 then change:= false else
  996. X      if screen`5By,x+1`5D=1 then change:= false else
  997. X      if screen`5By+1,x+1`5D=1 then change:= false;
  998. X    end
  999. X    else
  1000. X    if (position = 2) or (position = 4) then
  1001. X    begin
  1002. X      if screen`5By,x+1`5D=1 then change:= false else
  1003. X      if screen`5By+1,x`5D=1 then change:= false else
  1004. X      if screen`5By+1,x-1`5D=1 then change:= false;
  1005. X    end;
  1006. X  end
  1007. X  else
  1008. X  if shape = 7 then
  1009. X  begin
  1010. X    if (position = 1) or (position = 3) then
  1011. X    begin
  1012. X      if screen`5By-1,x`5D=1 then change:= false else
  1013. X      if screen`5By+1,x`5D=1 then change:= false else
  1014. X      if screen`5By+2,x`5D=1 then change:= false;
  1015. X    end
  1016. X    else
  1017. X    if (position = 2) or (position = 4) then
  1018. X    begin
  1019. X      if screen`5By,x-2`5D=1 then change:= false else
  1020. X      if screen`5By,x-1`5D=1 then change:= false else
  1021. X      if screen`5By,x+1`5D=1 then change:= false;
  1022. X    end;
  1023. X  end;
  1024. Xend;
  1025. X`7B*************************************************************************
  1026. V***`7D
  1027. X
  1028. X
  1029. X`7B*************************************************************************
  1030. V***`7D
  1031. Xprocedure Create(var shape,position,y,x:integer);
  1032. X
  1033. Xvar
  1034. X  shapenum:integer;
  1035. X
  1036. Xbegin
  1037. X  shapenum:=random(1,23);
  1038. X  if shapenum < 4 then shape:=1
  1039. X  else
  1040. X  if shapenum < 7 then shape:=2
  1041. X  else
  1042. X  if shapenum < 11 then shape:=3
  1043. X  else
  1044. +-+-+-+-+-+-+-+-  END  OF PART 3 +-+-+-+-+-+-+-+-
  1045. -- 
  1046. \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
  1047. < Joe Koffley                        KOFFLEY@NRLVAX.NRL.NAVY.MIL             >
  1048. < Naval Research Laboratory          KOFFLEY@SMOVAX.NRL.NAVY.MIL             >
  1049. < Space Systems Division             AT&T  :  202-767-0894                   >
  1050. \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
  1051.  
  1052.