home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1994 March / Source_Code_CD-ROM_Walnut_Creek_March_1994.iso / compsrcs / games / vmsnet / tetris / part02 < prev    next >
Encoding:
Internet Message Format  |  1992-07-01  |  28.5 KB
  1. Path: uunet!caen!kuhub.cc.ukans.edu!nrlvx1.nrl.navy.mil!koffley
  2. Newsgroups: vmsnet.sources.games
  3. Subject: TETRIS_VMS.02_OF_05
  4. Message-ID: <1992Jul2.123900.743@nrlvx1.nrl.navy.mil>
  5. From: koffley@nrlvx1.nrl.navy.mil
  6. Date: 2 Jul 92 12:39:00 -0400
  7. Organization: NRL SPACE SYSTEMS DIVISION
  8. Lines: 1113
  9.  
  10. -+-+-+-+-+-+-+-+ START OF PART 2 -+-+-+-+-+-+-+-+
  11. XX  rotright:=chr(rotrightint);
  12. XX  writeln(rotright);
  13. XX  writeln('press key to move shape to bottom: ');
  14. XX  waitkey(speedint,chan);
  15. XX  while (speedint=rightint) or`20
  16. XX        (speedint=leftint) or`20
  17. XX        (speedint=rotleftint) or
  18. XX        (speedint=rotrightint) do
  19. XX    waitkey(speedint,chan);
  20. XX  speed:=chr(speedint);
  21. XX  writeln(speed);
  22. XX  writeln('press key to quit game: ');
  23. XX  waitkey(quitint,chan);
  24. XX  while (quitint=rightint) or`20
  25. XX        (quitint=leftint) or`20
  26. XX        (quitint=rotleftint) or
  27. XX        (quitint=rotrightint) or
  28. XX        (quitint=speedint) do
  29. XX    waitkey(quitint,chan);
  30. XX  quitkey:=chr(quitint);
  31. XX  writeln(quitkey);
  32. XX  writeln('press key to redraw screen');
  33. XX  waitkey(redrawint,chan);
  34. XX  while (redrawint=rightint) or
  35. XX        (redrawint=leftint) or
  36. XX        (redrawint=rotrightint) or
  37. XX        (redrawint=rotleftint) or
  38. XX        (redrawint=quitint) do
  39. XX    waitkey(redrawint,chan);
  40. XX  redraw:=chr(redrawint);
  41. XX  writeln(redraw);
  42. XX  writeln;
  43. XX  writeln;
  44. XX  writeln;
  45. XX  writeln('    Press any key to continue ');
  46. XX  waitkey(null,chan);
  47. XXend; `7BKEYDEFINE`7D
  48. XX`7B*******************************************************************`7D
  49. XX
  50. XX
  51. XX
  52. XX`7B***********************************************************************`
  53. V7D
  54. XXprocedure Shapestuff(shape,position,y,x:integer; var screen:screenarray;
  55. XX                     n:integer);
  56. XXbegin
  57. XX  screen`5By,x`5D:=n;
  58. XX  if shape = 1 then
  59. XX  begin
  60. XX    screen`5By,x+1`5D:=n;
  61. XX    screen`5By+1,x`5D:=n;
  62. XX    screen`5By+1,x+1`5D:=n;
  63. XX  end
  64. XX  else
  65. XX  if shape = 2 then
  66. XX  begin
  67. XX    if position = 1 then
  68. XX    begin
  69. XX      screen`5By-1,x`5D:=n;
  70. XX      screen`5By+1,x`5D:=n;
  71. XX      screen`5By+1,x+1`5D:=n;
  72. XX    end
  73. XX    else
  74. XX    if position = 2 then
  75. XX    begin
  76. XX      screen`5By,x+1`5D:=n;
  77. XX      screen`5By,x-1`5D:=n;
  78. XX      screen`5By+1,x-1`5D:=n;
  79. XX    end
  80. XX    else
  81. XX    if position = 3 then
  82. XX    begin
  83. XX      screen`5By+1,x`5D:=n;
  84. XX      screen`5By-1,x`5D:=n;
  85. XX      screen`5By-1,x-1`5D:=n;
  86. XX    end
  87. XX    else
  88. XX    if position = 4 then
  89. XX    begin
  90. XX      screen`5By,x-1`5D:=n;
  91. XX      screen`5By,x+1`5D:=n;
  92. XX      screen`5By-1,x+1`5D:=n;
  93. XX    end;
  94. XX  end
  95. XX  else
  96. XX  if shape = 3 then
  97. XX  begin
  98. XX    if position = 1 then
  99. XX    begin
  100. XX      screen`5By-1,x`5D:=n;
  101. XX      screen`5By+1,x`5D:=n;
  102. XX      screen`5By+1,x-1`5D:=n;
  103. XX    end
  104. XX    else
  105. XX    if position = 2 then
  106. XX    begin
  107. XX      screen`5By,x+1`5D:=n;
  108. XX      screen`5By,x-1`5D:=n;
  109. XX      screen`5By-1,x-1`5D:=n;
  110. XX    end
  111. XX    else
  112. XX    if position = 3 then
  113. XX    begin
  114. XX      screen`5By-1,x`5D:=n;
  115. XX      screen`5By+1,x`5D:=n;
  116. XX      screen`5By-1,x+1`5D:=n;
  117. XX    end
  118. XX    else
  119. XX    if position = 4 then
  120. XX    begin
  121. XX      screen`5By,x-1`5D:=n;
  122. XX      screen`5By,x+1`5D:=n;
  123. XX      screen`5By+1,x+1`5D:=n;
  124. XX    end;
  125. XX  end
  126. XX  else
  127. XX  if shape = 4 then
  128. XX  begin
  129. XX    if position = 1 then
  130. XX    begin
  131. XX      screen`5By-1,x`5D:=n;
  132. XX      screen`5By+1,x`5D:=n;
  133. XX      screen`5By,x+1`5D:=n;
  134. XX    end
  135. XX    else
  136. XX    if position = 2 then
  137. XX    begin
  138. XX      screen`5By+1,x`5D:=n;
  139. XX      screen`5By,x-1`5D:=n;
  140. XX      screen`5By,x+1`5D:=n;
  141. XX    end
  142. XX    else
  143. XX    if position = 3 then
  144. XX    begin
  145. XX      screen`5By-1,x`5D:=n;
  146. XX      screen`5By+1,x`5D:=n;
  147. XX      screen`5By,x-1`5D:=n;
  148. XX    end
  149. XX    else
  150. XX    if position = 4 then
  151. XX    begin
  152. XX      screen`5By-1,x`5D:=n;
  153. XX      screen`5By,x-1`5D:=n;
  154. XX      screen`5By,x+1`5D:=n;
  155. XX    end;
  156. XX  end
  157. XX  else
  158. XX  if shape = 5 then
  159. XX  begin
  160. XX    if (position = 1) or (position = 3) then
  161. XX    begin
  162. XX      screen`5By+1,x`5D:=n;
  163. XX      screen`5By,x+1`5D:=n;
  164. XX      screen`5By-1,x+1`5D:=n;
  165. XX    end
  166. XX    else
  167. XX    if (position = 2) or (position = 4) then
  168. XX    begin
  169. XX      screen`5By,x-1`5D:=n;
  170. XX      screen`5By+1,x`5D:=n;
  171. XX      screen`5By+1,x+1`5D:=n;
  172. XX    end;
  173. XX  end
  174. XX  else
  175. XX  if shape = 6 then
  176. XX  begin
  177. XX    if (position = 1) or (position = 3) then
  178. XX    begin
  179. XX      screen`5By-1,x`5D:=n;
  180. XX      screen`5By,x+1`5D:=n;
  181. XX      screen`5By+1,x+1`5D:=n;
  182. XX    end
  183. XX    else
  184. XX    if (position = 2) or (position = 4) then
  185. XX    begin
  186. XX      screen`5By,x+1`5D:=n;
  187. XX      screen`5By+1,x`5D:=n;
  188. XX      screen`5By+1,x-1`5D:=n;
  189. XX    end;
  190. XX  end
  191. XX  else
  192. XX  if shape = 7 then
  193. XX  begin
  194. XX    if (position = 1) or (position = 3) then
  195. XX    begin
  196. XX      screen`5By-1,x`5D:=n;
  197. XX      screen`5By+1,x`5D:=n;
  198. XX      screen`5By+2,x`5D:=n;
  199. XX    end
  200. XX    else
  201. XX    if (position = 2) or (position = 4) then
  202. XX    begin
  203. XX      screen`5By,x-2`5D:=n;
  204. XX      screen`5By,x-1`5D:=n;
  205. XX      screen`5By,x+1`5D:=n;
  206. XX    end;
  207. XX  end;
  208. XXend;
  209. XX`7B************************************************************************
  210. V****`7D
  211. XX
  212. XX
  213. XX`7B***********************************************************************`
  214. V7D
  215. XXprocedure Check(shape,position,y,x:integer; var change:boolean);
  216. XX
  217. XXbegin
  218. XX  change:=true;
  219. XX  if shape = 2 then
  220. XX  begin
  221. XX    if position = 1 then
  222. XX    begin
  223. XX      if screen`5By-1,x`5D=1 then change:= false
  224. XX    else
  225. XX      if screen`5By+1,x`5D=1 then change:= false
  226. XX    else
  227. XX      if screen`5By+1,x+1`5D=1 then change:= false;
  228. XX    end
  229. XX    else
  230. XX    if position = 2 then
  231. XX    begin
  232. XX      if screen`5By,x+1`5D=1 then change:= false else
  233. XX      if screen`5By,x-1`5D=1 then change:= false else
  234. XX      if screen`5By+1,x-1`5D=1 then change:= false;
  235. XX    end
  236. XX    else
  237. XX    if position = 3 then
  238. XX    begin
  239. XX      if screen`5By+1,x`5D=1 then change:= false else
  240. XX      if screen`5By-1,x`5D=1 then change:= false else
  241. XX      if screen`5By-1,x-1`5D=1 then change:= false;
  242. XX    end
  243. XX    else
  244. XX    if position = 4 then
  245. XX    begin
  246. XX      if screen`5By,x-1`5D=1 then change:= false else
  247. XX      if screen`5By,x+1`5D=1 then change:= false else
  248. XX      if screen`5By-1,x+1`5D=1 then change:= false;
  249. XX    end;
  250. XX  end
  251. XX  else
  252. XX  if shape = 3 then
  253. XX  begin
  254. XX    if position = 1 then
  255. XX    begin
  256. XX      if screen`5By-1,x`5D=1 then change:= false else
  257. XX      if screen`5By+1,x`5D=1 then change:= false else
  258. XX      if screen`5By+1,x-1`5D=1 then change:= false;
  259. XX    end
  260. XX    else
  261. XX    if position = 2 then
  262. XX    begin
  263. XX      if screen`5By,x+1`5D=1 then change:= false else
  264. XX      if screen`5By,x-1`5D=1 then change:= false else
  265. XX      if screen`5By-1,x-1`5D=1 then change:= false;
  266. XX    end
  267. XX    else
  268. XX    if position = 3 then
  269. XX    begin
  270. XX      if screen`5By-1,x`5D=1 then change:= false else
  271. XX      if screen`5By+1,x`5D=1 then change:= false else
  272. XX      if screen`5By-1,x+1`5D=1 then change:= false;
  273. XX    end
  274. XX    else
  275. XX    if position = 4 then
  276. XX    begin
  277. XX      if screen`5By,x-1`5D=1 then change:= false else
  278. XX      if screen`5By,x+1`5D=1 then change:= false else
  279. XX      if screen`5By+1,x+1`5D=1 then change:= false;
  280. XX    end;
  281. XX  end
  282. XX  else
  283. XX  if shape = 4 then
  284. XX  begin
  285. XX    if position = 1 then
  286. XX    begin
  287. XX      if screen`5By-1,x`5D=1 then change:= false else
  288. XX      if screen`5By+1,x`5D=1 then change:= false else
  289. XX      if screen`5By,x+1`5D=1 then change:= false;
  290. XX    end
  291. XX    else
  292. XX    if position = 2 then
  293. XX    begin
  294. XX      if screen`5By+1,x`5D=1 then change:= false else
  295. XX      if screen`5By,x-1`5D=1 then change:= false else
  296. XX      if screen`5By,x+1`5D=1 then change:= false;
  297. XX    end
  298. XX    else
  299. XX    if position = 3 then
  300. XX    begin
  301. XX      if screen`5By-1,x`5D=1 then change:= false else
  302. XX      if screen`5By+1,x`5D=1 then change:= false else
  303. XX      if screen`5By,x-1`5D=1 then change:= false;
  304. XX    end
  305. XX    else
  306. XX    if position = 4 then
  307. XX    begin
  308. XX      if screen`5By-1,x`5D=1 then change:= false else
  309. XX      if screen`5By,x-1`5D=1 then change:= false else
  310. XX      if screen`5By,x+1`5D=1 then change:= false;
  311. XX    end;
  312. XX  end
  313. XX  else
  314. XX  if shape = 5 then
  315. XX  begin
  316. XX    if (position = 1) or (position = 3) then
  317. XX    begin
  318. XX      if screen`5By+1,x`5D=1 then change:= false else
  319. XX      if screen`5By,x+1`5D=1 then change:= false else
  320. XX      if screen`5By-1,x+1`5D=1 then change:= false;
  321. XX    end
  322. XX    else
  323. XX    if (position = 2) or (position = 4) then
  324. XX    begin
  325. XX      if screen`5By,x-1`5D=1 then change:= false else
  326. XX      if screen`5By+1,x`5D=1 then change:= false else
  327. XX      if screen`5By+1,x+1`5D=1 then change:= false;
  328. XX    end;
  329. XX  end
  330. XX  else
  331. XX  if shape = 6 then
  332. XX  begin
  333. XX    if (position = 1) or (position = 3) then
  334. XX    begin
  335. XX      if screen`5By-1,x`5D=1 then change:= false else
  336. XX      if screen`5By,x+1`5D=1 then change:= false else
  337. XX      if screen`5By+1,x+1`5D=1 then change:= false;
  338. XX    end
  339. XX    else
  340. XX    if (position = 2) or (position = 4) then
  341. XX    begin
  342. XX      if screen`5By,x+1`5D=1 then change:= false else
  343. XX      if screen`5By+1,x`5D=1 then change:= false else
  344. XX      if screen`5By+1,x-1`5D=1 then change:= false;
  345. XX    end;
  346. XX  end
  347. XX  else
  348. XX  if shape = 7 then
  349. XX  begin
  350. XX    if (position = 1) or (position = 3) then
  351. XX    begin
  352. XX      if screen`5By-1,x`5D=1 then change:= false else
  353. XX      if screen`5By+1,x`5D=1 then change:= false else
  354. XX      if screen`5By+2,x`5D=1 then change:= false;
  355. XX    end
  356. XX    else
  357. XX    if (position = 2) or (position = 4) then
  358. XX    begin
  359. XX      if screen`5By,x-2`5D=1 then change:= false else
  360. XX      if screen`5By,x-1`5D=1 then change:= false else
  361. XX      if screen`5By,x+1`5D=1 then change:= false;
  362. XX    end;
  363. XX  end;
  364. XXend;
  365. XX`7B************************************************************************
  366. V****`7D
  367. XX
  368. XX
  369. XX`7B************************************************************************
  370. V****`7D
  371. XXprocedure Create(var shape,position,y,x:integer);
  372. XX
  373. XXvar
  374. XX  shapenum:integer;
  375. XX
  376. XXbegin
  377. XX  shapenum:=random(1,23);
  378. XX  if shapenum < 4 then shape:=1
  379. XX  else
  380. XX  if shapenum < 7 then shape:=2
  381. XX  else
  382. XX  if shapenum < 11 then shape:=3
  383. XX  else
  384. XX  if shapenum < 14 then shape:=4
  385. XX  else
  386. XX  if shapenum < 17 then shape:=5
  387. XX  else
  388. XX  if shapenum < 20 then shape:=6
  389. XX  else`20
  390. XX  if shapenum < 23 then shape:=7
  391. XX  else
  392. XX  shape:=8;
  393. XX  position:=1;
  394. XX  y:=2;
  395. XX  x:=5;
  396. XXend;
  397. XX`7B************************************************************************
  398. V**`7D
  399. XX
  400. XX
  401. XX`7B***********************************************`7D
  402. XXprocedure PrintLines(screen:screenarray; b:integer);
  403. XX
  404. XXvar
  405. XX  a,
  406. XX  c:integer;
  407. XX  noline:boolean;
  408. XX
  409. XXbegin
  410. XX  a:=b;
  411. XX  repeat
  412. XX    noline:=true;
  413. XX    for c:=1 to 10 do
  414. XX    begin
  415. XX      if screen`5Ba,c`5D = 1 then noline:=false;
  416. XX      intochar(xchrhigh,xchrlow,ychrhigh,ychrlow,c+30,a);
  417. XX      if screen`5Ba,c`5D = 1 then
  418. XX        writeln(chr(27),'`5B',ychrhigh,ychrlow,';',xchrhigh,xchrlow,'H#');
  419. XX      if screen`5Ba,c`5D = 0 then
  420. XX        writeln(chr(27),'`5B',ychrhigh,ychrlow,';',xchrhigh,xchrlow,'H ');
  421. XX    end;
  422. XX    a:=a-1;
  423. XX  until (noline) or (a = 1);
  424. XXend;
  425. XX`7B************************************************`7D
  426. XX`7B******************************************************`7D
  427. XXprocedure LineDelete(var screen:screenarray; b:integer; var score:integer;
  428. XX                         level:integer; var lines:integer);
  429. XX
  430. XXvar
  431. XX  a,
  432. XX  c:integer;
  433. XX
  434. XXbegin
  435. XX  for a:= b downto 2 do
  436. XX    for c:=1 to 10 do
  437. XX      screen`5Ba,c`5D:=screen`5Ba-1,c`5D;
  438. XX  printlines(screen,b);
  439. XX  if not(flag) then
  440. XX    score:=score+(150*level)
  441. XX  else
  442. XX    score:=score+(100*level);
  443. XX  lines:=lines+1;
  444. XX  writeln(chr(27),'`5B14;7H',((5*level)-lines):2);
  445. XX  writeln(chr(27),'`5B10;7H',score:1);
  446. XXend;
  447. XX`7B***************************************************`7D
  448. XX`7B************************************************************************
  449. V****`7D
  450. XXprocedure LineStuff(var screen:screenarray; var lines:integer;
  451. XX                    level:integer; var score:integer);
  452. XX
  453. XXvar
  454. XX  A,
  455. XX  B:integer;
  456. XX  line,
  457. XX  nothing:boolean;
  458. XX  linenum:integer;
  459. XX  bounty:integer;
  460. XX
  461. XXbegin
  462. XX  linenum:=lines;
  463. XX  b:=22;
  464. XX  bounty:=0;
  465. XX  repeat
  466. XX    line:=true;
  467. XX    for a:=1 to 10 do
  468. XX      if screen`5Bb,a`5D=0 then line:=false;
  469. XX    nothing:=true;
  470. XX    for a:=1 to 10 do
  471. XX      if screen`5Bb,a`5D=1 then nothing:=false;
  472. XX    if line then
  473. XX    begin
  474. XX      LineDelete(screen,b,score,level,lines);
  475. XX      b:=b+1;
  476. XX    end;
  477. XX    b:=b-1;
  478. XX  until (nothing = true) or (b = 0);
  479. XX  linenum:=lines-linenum;
  480. XX  if linenum > 1 then  bounty:=((linenum-1) * 200 * level);
  481. XX  score:=score+bounty;
  482. XX  writeln(chr(27),'`5B10;7H',score:1);
  483. XXend;
  484. XX`7B**********************************************************************`7
  485. VD
  486. XX
  487. XX
  488. XX`7B**********************************************************************`7
  489. VD
  490. XXprocedure bonus(var score:integer; screen:screenarray; level:integer);
  491. XX
  492. XXvar
  493. XX  a,
  494. XX  b:integer;
  495. XX  noline:boolean;
  496. XX
  497. XX
  498. XXbegin
  499. XX  a:=22;
  500. XX  b:=1;
  501. XX  repeat
  502. XX    noline:=true;
  503. XX    for b:=1 to 10 do
  504. XX      if screen`5Ba,b`5D = 1 then noline:=false;
  505. XX    a:=a-1;
  506. XX  until (a = 0) or (noline = true);
  507. XX
  508. XX  if noline then
  509. XX    score:=score+(100*a*level);
  510. XXend;
  511. XX`7B******************************************************************`7D
  512. XX
  513. XX`7B*************************************`7D
  514. XXprocedure Printshape(screen:screenarray; y,x:integer);
  515. XX
  516. XXvar
  517. XX  a,
  518. XX  b,
  519. XX  i,
  520. XX  j:integer;
  521. XX  stuff:packed array`5B1..10`5D of char;
  522. XX
  523. XXbegin
  524. XX  if flag2 = TRUE then
  525. XX  begin
  526. XX    waitx(factor);
  527. XX  end;
  528. XX  for a:= y-2 to y+3 do
  529. XX    begin
  530. XX      if (a < 23) and (a > 1) then
  531. XX      begin
  532. XX        intochar(xchrhigh,xchrlow,ychrhigh,ychrlow,31,a);    `20
  533. XX        for b:=1 to 10 do
  534. XX        begin
  535. XX          if screen`5Ba,b`5D = 1 then stuff`5Bb`5D:='#'
  536. XX          else
  537. XX          if screen`5Ba,b`5D = 2 then stuff`5Bb`5D:='@'
  538. XX          else
  539. XX            stuff`5Bb`5D:=' ';`20
  540. XX        end;
  541. XX        writeln(chr(27),'`5B',ychrhigh,ychrlow,';31H',stuff)
  542. XX       end;
  543. XX    end;
  544. XXend;
  545. XX`7B*************************************`7D
  546. XX
  547. XX`7B**********************************************************************`7
  548. VD
  549. XXprocedure printnext(shape:integer);
  550. XX
  551. XXbegin
  552. XX  writeln(chr(27),'`5B07;50H  ');
  553. XX  writeln(chr(27),'`5B08;50H  ');
  554. XX  if shape = 1 then
  555. XX  begin
  556. XX    writeln(chr(27),'`5B05;50H@@');
  557. XX    writeln(chr(27),'`5B06;50H@@');
  558. XX  end
  559. XX  else
  560. XX  if shape = 2 then
  561. XX  begin
  562. XX    writeln(chr(27),'`5B05;50H@ ');
  563. XX    writeln(chr(27),'`5B06;50H@ ');
  564. XX    writeln(chr(27),'`5B07;50H@@');
  565. XX  end
  566. XX  else
  567. XX  if shape = 3 then
  568. XX  begin
  569. XX    writeln(chr(27),'`5B05;50H @');
  570. XX    writeln(chr(27),'`5B06;50H @');
  571. XX    writeln(chr(27),'`5B07;50H@@');
  572. XX  end
  573. XX  else
  574. XX  if shape = 4 then
  575. XX  begin
  576. XX    writeln(chr(27),'`5B05;50H@ ');
  577. XX    writeln(chr(27),'`5B06;50H@@');
  578. XX    writeln(chr(27),'`5B07;50H@ ');
  579. XX  end
  580. XX  else
  581. XX  if shape = 5 then
  582. XX  begin
  583. XX    writeln(chr(27),'`5B05;50H @');
  584. XX    writeln(chr(27),'`5B06;50H@@');
  585. XX    writeln(chr(27),'`5B07;50H@ ');
  586. XX  end
  587. XX  else
  588. XX  if shape = 6 then
  589. XX  begin
  590. XX    writeln(chr(27),'`5B05;50H@ ');
  591. XX    writeln(chr(27),'`5B06;50H@@');
  592. XX    writeln(chr(27),'`5B07;50H @');
  593. XX  end
  594. XX  else
  595. XX  if shape = 7 then
  596. XX  begin
  597. XX    writeln(chr(27),'`5B05;50H@ ');
  598. XX    writeln(chr(27),'`5B06;50H@ ');
  599. XX    writeln(chr(27),'`5B07;50H@ ');
  600. XX    writeln(chr(27),'`5B08;50H@ ');
  601. XX  end;
  602. XXend;
  603. XX`7B**********************************************************************`7
  604. VD
  605. XX
  606. XX
  607. XX`7B**********************************************************************`7
  608. VD
  609. XVprocedure Rotation(var screen:screenarray; shape:integer; var position:inte
  610. Vger
  611. XX;
  612. XX                       rotint:integer;  var y,x:integer);
  613. XX
  614. XXvar
  615. XX  newposition:integer;
  616. XX  ax:integer;
  617. XX  change:boolean;
  618. XX
  619. XXbegin
  620. XX  if shape = 7 then
  621. XX  begin
  622. XX    ax:=x;
  623. XX    if x = 10 then ax:=9;
  624. XX    if x = 1 then ax:=3;
  625. XX    if x = 2 then ax:=3;
  626. XX  end
  627. XX  else
  628. XX    if x =1 then ax:=2
  629. XX  else
  630. XX    if x =10 then ax:=9
  631. XX  else
  632. XX    ax:=x;
  633. XX
  634. XX
  635. XX  if rotint = -1 then
  636. XX  begin
  637. XX    if position = 1 then newposition:=4
  638. XX    else
  639. XX      newposition:=position -1;
  640. XX  end
  641. XX  else
  642. XX  if rotint = 1 then
  643. XX  begin
  644. XX    if position = 4 then newposition:=1
  645. XX    else
  646. XX      newposition:=position +1;
  647. XX  end;
  648. XX
  649. XX
  650. XX  check(shape,newposition,y,ax,change);
  651. XX  if change = true then
  652. XX  begin
  653. XX    shapestuff(shape,position,y,x,screen,0);
  654. XX    position:=newposition;
  655. XX    x:=ax;
  656. XX    shapestuff(shape,position,y,x,screen,2);
  657. XX    printshape(screen,y,x);
  658. XX  end;
  659. XXend;
  660. XV`7B************************************************************************
  661. V*****
  662. XX`7D
  663. XX
  664. XX
  665. XV`7B************************************************************************
  666. V*****
  667. XX`7D
  668. XXprocedure Movement(var screen:screenarray; shape,position:integer;
  669. XX                   var y,x:integer; d:integer);
  670. XX
  671. XX
  672. XXvar
  673. XX  move:boolean;
  674. XX  a,
  675. XX  b:integer;
  676. XXbegin
  677. XX  move:=true;
  678. XX  if d = 1 then
  679. XX  begin
  680. XX    for a:= x+2 downto x-2 do
  681. XX      for b:=y+2 downto y-1 do
  682. XX        if (a >1) and (a<11) and (b > 1) and (b < 23) then
  683. XX        begin
  684. XX          if (a = 10) and (screen`5Bb,a`5D = 2) then move:=false;
  685. XX          if (screen`5Bb,a`5D = 1) and (screen`5Bb,a-1`5D = 2) then move:=f
  686. Valse;
  687. XX        end;`20
  688. XX  end
  689. XX  else
  690. XX  if d = -1 then
  691. XX  begin
  692. XX    for a:=x-3 to x+1 do
  693. XX      for b:=y-1 to y+2 do
  694. XX        if (a >0) and (a<9) and (b>1) and (b<23) then
  695. XX        begin
  696. XX          if (a = 1) and (screen`5Bb,a`5D = 2) then move:=false;
  697. XX          if (screen`5Bb,a`5D = 1) and (screen`5Bb,a+1`5D = 2) then move:=f
  698. Valse;
  699. XX        end;
  700. XX  end;`20
  701. XX  if move = true then
  702. XX  begin
  703. XX    shapestuff(shape,position,y,x,screen,0);
  704. XX    x:=x+d;
  705. XX    shapestuff(shape,position,y,x,screen,2);
  706. XX    printshape(screen,y,x);
  707. XX  end;
  708. XXend;
  709. XX`7B************************************************************************
  710. V`7D
  711. XV`7B************************************************************************
  712. V*****
  713. XX`7D
  714. XVprocedure Down(var screen:screenarray; shape,position:integer; var y,x:inte
  715. Vger
  716. XX;
  717. XX               var fast:boolean);
  718. XX
  719. XX
  720. XXvar
  721. XX  move:boolean;
  722. XX  a,
  723. XX  b:integer;
  724. XX
  725. XXbegin
  726. XX  move:=true;
  727. XX  for b:=y+3 downto y-1 do
  728. XX    for a:= x+2 downto x-2 do
  729. XX      if (a >0) and (a<11) and (b > 1) and (b < 23) then
  730. XX      begin
  731. XX        if (b = 22) and (screen`5Bb,a`5D = 2) then move:=false;
  732. XX        if (screen`5Bb,a`5D = 1) and (screen`5Bb-1,a`5D = 2) then move:=fal
  733. Vse;
  734. XX      end;`20
  735. XX  if move = true then
  736. XX  begin
  737. XX    if fast = true then
  738. XX    begin
  739. XX      y:=y+1;
  740. XX      shapestuff(shape,position,y-1,x,screen,0);
  741. XX      printshape(screen,y,x);
  742. XX      shapestuff(shape,position,y,x,screen,2);
  743. XX      repeat
  744. XX        move:=true;
  745. XX        for b:=y+3 downto y-1 do
  746. XX          for a:= x+2 downto x-2 do
  747. XX            if (a >0) and (a<11) and (b > 1) and (b < 23) then
  748. XX            begin
  749. XX              if (b = 22) and (screen`5Bb,a`5D = 2) then move:=false;
  750. XX              if (screen`5Bb,a`5D = 1) and (screen`5Bb-1,a`5D = 2 ) then mo
  751. Vve:=false;
  752. XX            end;
  753. XX         if move = true then
  754. XX         begin
  755. XX           y:=y+1;
  756. XX           shapestuff(shape,position,y-1,x,screen,0);
  757. XX           shapestuff(shape,position,y,x,screen,2);
  758. XX         end;
  759. XX       until move=false;
  760. XX       printshape(screen,y,x);
  761. XX    end
  762. XX    else
  763. XX    begin
  764. XX      y:=y+1;
  765. XX      screen`5By-1,x`5D:=0;
  766. XX      screen`5By,x`5D:=2;
  767. XX      shapestuff(shape,position,y-1,x,screen,0);
  768. XX      shapestuff(shape,position,y,x,screen,2);
  769. XX      printshape(screen,y,x);
  770. XX    end;
  771. XX  end;
  772. XX  fast:=false;
  773. XXend;
  774. XX`7B************************************************************************
  775. V`7D
  776. XX
  777. XXprocedure printall(screen:screenarray; score,lines,level:integer);
  778. XX
  779. XX
  780. XXvar
  781. XX  a,
  782. XX  b:integer;
  783. XX  g,
  784. XX  h,
  785. XX  xchrhigh,
  786. XX  xchrlow,
  787. XX  ychrhigh,
  788. XX  ychrlow:char;
  789. XX  stuff:packed array`5B1..10`5D of char;
  790. XX
  791. XXbegin
  792. XX `20
  793. XX  cls;
  794. XX  for I:=1 to 22 do
  795. XX  begin
  796. XX    intochar(g,h,ychrhigh,ychrlow,1,I);
  797. XX    writeln(chr(27),'`5B',ychrhigh,ychrlow,';30H`7C          `7C');
  798. XX  end;
  799. XX  writeln(chr(27),'`5B23;30H------------');
  800. XX  if flag then writeln(chr(27),'`5B03;49HNEXT');
  801. XX  writeln(chr(27),'`5B10;1HSCORE:',score:1);
  802. XX  writeln(chr(27),'`5B12;1HLEVEL:',level:1);
  803. XX  writeln(chr(27),'`5B14;1HLINES:',((5*level)-lines):2);
  804. XX  for a:=1 to 22 do
  805. XX  begin
  806. XX    intochar(xchrhigh,xchrlow,ychrhigh,ychrlow,31,a);
  807. XX    for b:=1 to 10 do
  808. XX    begin
  809. XX      if screen`5Ba,b`5D = 1 then stuff`5Bb`5D:='#'
  810. XX      else
  811. XX        stuff`5Bb`5D:=' ';
  812. XX    end;
  813. XX    writeln(chr(27),'`5B',ychrhigh,ychrlow,';31H',stuff);
  814. XX  end;
  815. XXend;
  816. XV`7B************************************************************************
  817. V*****
  818. XX*`7D
  819. XX
  820. XV`7B************************************************************************
  821. V*****
  822. XX*`7D
  823. XXprocedure editshape(key:integer; var nshape:integer);
  824. XX
  825. XX
  826. XXbegin
  827. XX  nshape:=key-48;
  828. XX  printnext(nshape);
  829. XXend;
  830. XV`7B************************************************************************
  831. V*****
  832. XX*`7D
  833. XX`7B***********************************************`7D
  834. XXprocedure getyearday(inp:datestr; var year,day:integer);
  835. XX
  836. XXvar
  837. XX  digit1,
  838. XX  digit2,
  839. XX  digit3,
  840. XX  digit4:integer;
  841. XX  offset:integer;
  842. XX
  843. XXbegin
  844. XX  offset:= ord('1') + 1;
  845. XX  digit1:= ord(inp`5B8`5D) - offset;
  846. XX  digit2:= ord(inp`5B9`5D) - offset;
  847. XX  digit3:= ord(inp`5B10`5D) - offset;
  848. XX  digit4:= ord(inp`5B11`5D) - offset;
  849. XX  year:= digit4 + (10*digit3) + (100*digit2) + (1000*digit1);
  850. XX  digit1:= ord(inp`5B1`5D) - offset;
  851. XX  digit2:= ord(inp`5B2`5D) - offset;
  852. XX  day:= digit2 + (10*digit1);
  853. XXend;
  854. XX`7B************************************************`7D
  855. XX
  856. XX`7B**********************************************`7D
  857. XXprocedure getmonth(inp:datestr; var month:integer);
  858. XX
  859. XXbegin
  860. XX `20
  861. XX  if (inp`5B4`5D = 'J') and (inp`5B5`5D = 'A') then month:=1
  862. XX  else
  863. XX  if (inp`5B4`5D = 'F') then month:=2
  864. XX  else
  865. XX  if (inp`5B4`5D = 'M') and (inp`5B6`5D = 'R') then month:=3
  866. XX  else
  867. XX  if (inp`5B4`5D = 'A') and (inp`5B5`5D = 'P') then month:=4
  868. XX  else
  869. XX  if (inp`5B4`5D = 'M') and (inp`5B6`5D = 'Y') then month:=5
  870. XX  else
  871. XX  if (inp`5B4`5D = 'J') and (inp`5B6`5D = 'N') then month:=7
  872. XX  else
  873. XX  if (inp`5B4`5D = 'J') then month:=6
  874. XX  else
  875. XX  if (inp`5B4`5D = 'A') and (inp`5B5`5D = 'U') then month:=8
  876. XX  else
  877. XX  if (inp`5B4`5D = 'S') then month:=9
  878. XX  else
  879. XX  if (inp`5B4`5D = 'O') then month:=10
  880. XX  else
  881. XX  if (inp`5B4`5D = 'N') then month:=11
  882. XX  else
  883. XX  if (inp`5B4`5D = 'D') then month:=12;
  884. XXend;
  885. XX
  886. XV`7B************************************************************************
  887. V*****
  888. XX*`7D
  889. XV`7B************************************************************************
  890. V*****
  891. XX*`7D
  892. XXfunction older(one,two:datestr):boolean;
  893. XX
  894. XX
  895. XXvar
  896. XX  oneyear,
  897. XX  twoyear,
  898. XX  onemonth,
  899. XX  twomonth,
  900. XX  oneday,
  901. XX  twoday:integer;
  902. XX
  903. XXbegin
  904. XX  getyearday(one,oneyear,oneday);
  905. XX  getyearday(two,twoyear,twoday);
  906. XX  getmonth(one,onemonth);
  907. XX  getmonth(two,twomonth);
  908. XX  if oneyear < twoyear then older:=true
  909. XX  else
  910. XX    if onemonth < twomonth then older:=true
  911. XX    else
  912. XX      if oneday < twoday then older:=true
  913. XX      else
  914. XX        older:=false;
  915. XXend;
  916. XV`7B************************************************************************
  917. V*****
  918. XX*`7D
  919. XV`7B************************************************************************
  920. V*****
  921. XX*`7D
  922. XX
  923. XX
  924. XV`7B************************************************************************
  925. V*****
  926. XX*`7D
  927. XV`7B************************************************************************
  928. V*****
  929. XX*`7D
  930. XXProcedure MainGame(left,right,rotleft,rotright,speed,quitkey,redraw:char;
  931. XX                   level:integer; cheat:boolean);
  932. XX
  933. XXvar
  934. XX  oldest:integer;
  935. XX  saved,
  936. XX  saving:saverec;
  937. XX  count:integer;
  938. XX  quit:boolean;
  939. XX  a,b:integer;
  940. XX  height:integer;
  941. XX  choice:char;
  942. XX  nx,
  943. XX  ny,
  944. XX  nshape,
  945. XX  nposition:integer;
  946. XX  fast:boolean;
  947. XX  gotin:boolean;
  948. XX
  949. XXbegin
  950. XX
  951. XXrandomise;
  952. XXif restored = false then
  953. XXbegin
  954. XX  for a:=1 to 22 do
  955. XX    for b:=1 to 10 do
  956. XX      screen`5Ba,b`5D:=0;
  957. XX  score:=0;
  958. XX  position:=1;
  959. XX  create(shape,position,y,x);
  960. XX  lines:=0;
  961. XX  shapestuff(shape,position,y,x,screen,2);
  962. XXend;
  963. XXcreate(nshape,nposition,ny,nx);
  964. XXcount:=0;
  965. XXfast:=false;
  966. XXquit:=false;
  967. XXott:=false;
  968. XXcls;
  969. XX
  970. XXprintshape(screen,y,x);
  971. XXprintall(screen,score,lines,level);
  972. XXif restored then`20
  973. XX  writeln(chr(27),'`5B10;49HPress any key to continue game')
  974. XXelse
  975. XX  writeln(chr(27),'`5B10;49HPress any key to play game');
  976. XXwaitkey(key,chan);
  977. XXwriteln(chr(27),'`5B10;49H                                ');
  978. XXrestored:=false;
  979. XXif flag then printnext(nshape);
  980. XXrepeat
  981. XX  readkey(key,chan);
  982. XX  choice:=chr(key);
  983. XX  if choice = left then Movement(screen,shape,position,y,x,-1)
  984. XX  else
  985. XX  if choice = right then movement(screen,shape,position,y,x,1)
  986. XX  else
  987. XX  if choice = rotleft then Rotation(screen,shape,position,-1,y,x)
  988. XX  else
  989. XX  if choice = rotright then Rotation(screen,shape,position,1,y,x)
  990. XX  else
  991. XX  if choice = speed then fast:=true
  992. XX  else
  993. XX  if  (choice in `5B'1'..'7'`5D) and (cheat = true) then editshape(key,nsha
  994. Vpe)
  995. XX  else
  996. XX  if choice = redraw then
  997. XX  begin
  998. XX    printall(screen,score,lines,level);
  999. XX    if flag then printnext(nshape);
  1000. XX  end
  1001. XX  else
  1002. XX    if choice = quitkey then ott:=true
  1003. XX  else
  1004. XX    if choice = '!' then`20
  1005. XX    begin
  1006. XX      cls;
  1007. XX      writeln('%DCL-I-SPAWN, Type eoj to return to Shapes');
  1008. XX      spawn;
  1009. XX      printall(screen,score,lines,level);
  1010. XX      if flag then printnext(nshape);
  1011. XX      writeln(chr(27),'`5B10;49HPress any key to continue Shapes');
  1012. XX      waitkey(key,chan);
  1013. XX      writeln(chr(27),'`5B10;49H                                ');
  1014. XX    end
  1015. XX  else
  1016. XX    if choice = '@' then
  1017. XX    begin
  1018. XX      cls;
  1019. XX      Writeln(                      'Save game option');
  1020. XX      usernum(userid);
  1021. XX      if (userid = 'CADP02  ') or
  1022. XX         (userid = 'CADP03  ') then`20
  1023. XX      begin`20
  1024. XX        write('Enter username, MAX 8 letters, RETURN for default: ');
  1025. XX        userid:='        ';
  1026. XX        readln(userid);
  1027. XX        if userid`5B1`5D = ' ' then usernum(userid);
  1028. XX      end;
  1029. XX      saving.num:=score;
  1030. XX      saving.level:=level;
  1031. XX      saving.outp:=screen;
  1032. XX      saving.lines:=lines;
  1033. XX      saving.x:=x;
  1034. XX      saving.y:=y;
  1035. XX      saving.shape:=shape;
  1036. XX      saving.position:=position;
  1037. XX      saving.user:=userid;
  1038. XX      DATE(saving.current);
  1039. XX      open(Save,Savefile,history:=readonly);
  1040. XX      reset(save);
  1041. XX      del:=false;
  1042. XX      for I:=1 to 100 do
  1043. XX      begin
  1044. XX        read(save,peeps`5BI`5D);
  1045. XX        if (del = true) and (peeps`5BI`5D.user = saving.user) then
  1046. XX          peeps`5BI`5D.user:='UNUSED  ';
  1047. XX        if (del = false) and (peeps`5BI`5D.user = 'UNUSED  ') then
  1048. XX        begin
  1049. XX          peeps`5BI`5D:=saving;
  1050. XX          del:=true;
  1051. XX        end;
  1052. XX        if (del = false) and (peeps`5BI`5D.user = saving.user) then
  1053. XX        begin
  1054. XX          del:=true;
  1055. XX          peeps`5BI`5D:=saving;
  1056. XX        end;
  1057. XX      end;
  1058. XX      if del = false then
  1059. XX      begin
  1060. XX        reset(save);
  1061. XX        read(save,peeps`5B1`5D);
  1062. XX        oldest:=1;
  1063. XX        for I:=2 to 100 do
  1064. XX        begin
  1065. XX          read(save,peeps`5BI`5D);
  1066. XX          if older(peeps`5BI-1`5D.current,peeps`5BI`5D.current) = false the
  1067. Vn`20
  1068. XX            oldest:=I;
  1069. XX        end;
  1070. XX        peeps`5Boldest`5D:=saving;
  1071. XX      end;
  1072. XX      close(save);
  1073. XX      open(Save,Savefile,history:=old);
  1074. XX      rewrite(save);
  1075. XX      for I:=1 to 100 do
  1076. XX        write(save,peeps`5BI`5D);
  1077. XX      close(save);
  1078. XX      ott:=true;
  1079. XX      del:=false;
  1080. XX      writeln('Game saved.');
  1081. XX      writeln('Press any key for main menu.');
  1082. XX      waitkey(key,chan);
  1083. XX    end;
  1084. XX  if count = 3 then
  1085. XX  begin
  1086. XX    height:=y;
  1087. XX    Down(screen,shape,position,y,x,fast);
  1088. XX    if height = y then
  1089. XX    begin
  1090. XX      for a:=1 to 10 do
  1091. XX        if screen`5B1,a`5D=2 then ott:=true;
  1092. XX      shapestuff(shape,position,y,x,screen,1);
  1093. XX      printshape(screen,y,x);
  1094. XX      linestuff(screen,lines,level,score);
  1095. XX      shape:=Nshape;
  1096. XX      position:=Nposition;
  1097. XX      y:=Ny;
  1098. XX      x:=Nx;
  1099. XX      create(nshape,nposition,ny,nx);
  1100. XX      if flag then printnext(nshape);
  1101. XX      shapestuff(shape,position,y,x,screen,2);
  1102. XX      if lines >= 5*level then
  1103. XX      begin
  1104. XX        level:=level+1;
  1105. XX        bonus(score,screen,level);
  1106. XX        lines:=0;
  1107. XX        printall(screen,score,lines,level);
  1108. XX        if flag then printnext(nshape);
  1109. XX      end;
  1110. XX    end;
  1111. XX    count:=0;
  1112. XX  end;
  1113. XX  count:=count+1;
  1114. XXuntil OTT = true;
  1115. +-+-+-+-+-+-+-+-  END  OF PART 2 +-+-+-+-+-+-+-+-
  1116. -- 
  1117. \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
  1118. < Joe Koffley                        KOFFLEY@NRLVAX.NRL.NAVY.MIL             >
  1119. < Naval Research Laboratory          KOFFLEY@SMOVAX.NRL.NAVY.MIL             >
  1120. < Space Systems Division             AT&T  :  202-767-0894                   >
  1121. \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
  1122.  
  1123.