home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1994 March / Source_Code_CD-ROM_Walnut_Creek_March_1994.iso / compsrcs / games / vmsnet / tetris / part04 < 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.04_OF_05
  4. Message-ID: <1992Jul2.124010.745@nrlvx1.nrl.navy.mil>
  5. From: koffley@nrlvx1.nrl.navy.mil
  6. Date: 2 Jul 92 12:40:10 -0400
  7. Organization: NRL SPACE SYSTEMS DIVISION
  8. Lines: 1090
  9.  
  10. -+-+-+-+-+-+-+-+ START OF PART 4 -+-+-+-+-+-+-+-+
  11. X  if shapenum < 14 then shape:=4
  12. X  else
  13. X  if shapenum < 17 then shape:=5
  14. X  else
  15. X  if shapenum < 20 then shape:=6
  16. X  else`20
  17. X  if shapenum < 23 then shape:=7
  18. X  else
  19. X  shape:=8;
  20. X  position:=1;
  21. X  y:=2;
  22. X  x:=5;
  23. Xend;
  24. X`7B*************************************************************************
  25. V*`7D
  26. X
  27. X
  28. X`7B***********************************************`7D
  29. Xprocedure PrintLines(screen:screenarray; b:integer);
  30. X
  31. Xvar
  32. X  a,
  33. X  c:integer;
  34. X  noline:boolean;
  35. X
  36. Xbegin
  37. X  a:=b;
  38. X  repeat
  39. X    noline:=true;
  40. X    for c:=1 to 10 do
  41. X    begin
  42. X      if screen`5Ba,c`5D = 1 then noline:=false;
  43. X      intochar(xchrhigh,xchrlow,ychrhigh,ychrlow,c+30,a);
  44. X      if screen`5Ba,c`5D = 1 then
  45. X        writeln(chr(27),'`5B',ychrhigh,ychrlow,';',xchrhigh,xchrlow,'H#');
  46. X      if screen`5Ba,c`5D = 0 then
  47. X        writeln(chr(27),'`5B',ychrhigh,ychrlow,';',xchrhigh,xchrlow,'H ');
  48. X    end;
  49. X    a:=a-1;
  50. X  until (noline) or (a = 1);
  51. Xend;
  52. X`7B************************************************`7D
  53. X`7B******************************************************`7D
  54. Xprocedure LineDelete(var screen:screenarray; b:integer; var score:integer;
  55. X                         level:integer; var lines:integer);
  56. X
  57. Xvar
  58. X  a,
  59. X  c:integer;
  60. X
  61. Xbegin
  62. X  for a:= b downto 2 do
  63. X    for c:=1 to 10 do
  64. X      screen`5Ba,c`5D:=screen`5Ba-1,c`5D;
  65. X  printlines(screen,b);
  66. X  if not(flag) then
  67. X    score:=score+(150*level)
  68. X  else
  69. X    score:=score+(100*level);
  70. X  lines:=lines+1;
  71. X  writeln(chr(27),'`5B14;7H',((5*level)-lines):2);
  72. X  writeln(chr(27),'`5B10;7H',score:1);
  73. Xend;
  74. X`7B***************************************************`7D
  75. X`7B*************************************************************************
  76. V***`7D
  77. Xprocedure LineStuff(var screen:screenarray; var lines:integer;
  78. X                    level:integer; var score:integer);
  79. X
  80. Xvar
  81. X  A,
  82. X  B:integer;
  83. X  line,
  84. X  nothing:boolean;
  85. X  linenum:integer;
  86. X  bounty:integer;
  87. X
  88. Xbegin
  89. X  linenum:=lines;
  90. X  b:=22;
  91. X  bounty:=0;
  92. X  repeat
  93. X    line:=true;
  94. X    for a:=1 to 10 do
  95. X      if screen`5Bb,a`5D=0 then line:=false;
  96. X    nothing:=true;
  97. X    for a:=1 to 10 do
  98. X      if screen`5Bb,a`5D=1 then nothing:=false;
  99. X    if line then
  100. X    begin
  101. X      LineDelete(screen,b,score,level,lines);
  102. X      b:=b+1;
  103. X    end;
  104. X    b:=b-1;
  105. X  until (nothing = true) or (b = 0);
  106. X  linenum:=lines-linenum;
  107. X  if linenum > 1 then  bounty:=((linenum-1) * 200 * level);
  108. X  score:=score+bounty;
  109. X  writeln(chr(27),'`5B10;7H',score:1);
  110. Xend;
  111. X`7B**********************************************************************`7D
  112. X
  113. X
  114. X`7B**********************************************************************`7D
  115. Xprocedure bonus(var score:integer; screen:screenarray; level:integer);
  116. X
  117. Xvar
  118. X  a,
  119. X  b:integer;
  120. X  noline:boolean;
  121. X
  122. X
  123. Xbegin
  124. X  a:=22;
  125. X  b:=1;
  126. X  repeat
  127. X    noline:=true;
  128. X    for b:=1 to 10 do
  129. X      if screen`5Ba,b`5D = 1 then noline:=false;
  130. X    a:=a-1;
  131. X  until (a = 0) or (noline = true);
  132. X
  133. X  if noline then
  134. X    score:=score+(100*a*level);
  135. Xend;
  136. X`7B******************************************************************`7D
  137. X
  138. X`7B*************************************`7D
  139. Xprocedure Printshape(screen:screenarray; y,x:integer);
  140. X
  141. Xvar
  142. X  a,
  143. X  b,
  144. X  i,
  145. X  j:integer;
  146. X  stuff:packed array`5B1..10`5D of char;
  147. X
  148. Xbegin
  149. X  if flag2 = TRUE then
  150. X  begin
  151. X    waitx(factor);
  152. X  end;
  153. X  for a:= y-2 to y+3 do
  154. X    begin
  155. X      if (a < 23) and (a > 1) then
  156. X      begin
  157. X        intochar(xchrhigh,xchrlow,ychrhigh,ychrlow,31,a);    `20
  158. X        for b:=1 to 10 do
  159. X        begin
  160. X          if screen`5Ba,b`5D = 1 then stuff`5Bb`5D:='#'
  161. X          else
  162. X          if screen`5Ba,b`5D = 2 then stuff`5Bb`5D:='@'
  163. X          else
  164. X            stuff`5Bb`5D:=' ';`20
  165. X        end;
  166. X        writeln(chr(27),'`5B',ychrhigh,ychrlow,';31H',stuff)
  167. X       end;
  168. X    end;
  169. Xend;
  170. X`7B*************************************`7D
  171. X
  172. X`7B**********************************************************************`7D
  173. Xprocedure printnext(shape:integer);
  174. X
  175. Xbegin
  176. X  writeln(chr(27),'`5B07;50H  ');
  177. X  writeln(chr(27),'`5B08;50H  ');
  178. X  if shape = 1 then
  179. X  begin
  180. X    writeln(chr(27),'`5B05;50H@@');
  181. X    writeln(chr(27),'`5B06;50H@@');
  182. X  end
  183. X  else
  184. X  if shape = 2 then
  185. X  begin
  186. X    writeln(chr(27),'`5B05;50H@ ');
  187. X    writeln(chr(27),'`5B06;50H@ ');
  188. X    writeln(chr(27),'`5B07;50H@@');
  189. X  end
  190. X  else
  191. X  if shape = 3 then
  192. X  begin
  193. X    writeln(chr(27),'`5B05;50H @');
  194. X    writeln(chr(27),'`5B06;50H @');
  195. X    writeln(chr(27),'`5B07;50H@@');
  196. X  end
  197. X  else
  198. X  if shape = 4 then
  199. X  begin
  200. X    writeln(chr(27),'`5B05;50H@ ');
  201. X    writeln(chr(27),'`5B06;50H@@');
  202. X    writeln(chr(27),'`5B07;50H@ ');
  203. X  end
  204. X  else
  205. X  if shape = 5 then
  206. X  begin
  207. X    writeln(chr(27),'`5B05;50H @');
  208. X    writeln(chr(27),'`5B06;50H@@');
  209. X    writeln(chr(27),'`5B07;50H@ ');
  210. X  end
  211. X  else
  212. X  if shape = 6 then
  213. X  begin
  214. X    writeln(chr(27),'`5B05;50H@ ');
  215. X    writeln(chr(27),'`5B06;50H@@');
  216. X    writeln(chr(27),'`5B07;50H @');
  217. X  end
  218. X  else
  219. X  if shape = 7 then
  220. X  begin
  221. X    writeln(chr(27),'`5B05;50H@ ');
  222. X    writeln(chr(27),'`5B06;50H@ ');
  223. X    writeln(chr(27),'`5B07;50H@ ');
  224. X    writeln(chr(27),'`5B08;50H@ ');
  225. X  end;
  226. Xend;
  227. X`7B**********************************************************************`7D
  228. X
  229. X
  230. X`7B**********************************************************************`7D
  231. Xprocedure Rotation(var screen:screenarray; shape:integer; var position:integ
  232. Ver;
  233. X                       rotint:integer;  var y,x:integer);
  234. X
  235. Xvar
  236. X  newposition:integer;
  237. X  ax:integer;
  238. X  change:boolean;
  239. X
  240. Xbegin
  241. X  if shape = 7 then
  242. X  begin
  243. X    ax:=x;
  244. X    if x = 10 then ax:=9;
  245. X    if x = 1 then ax:=3;
  246. X    if x = 2 then ax:=3;
  247. X  end
  248. X  else
  249. X    if x =1 then ax:=2
  250. X  else
  251. X    if x =10 then ax:=9
  252. X  else
  253. X    ax:=x;
  254. X
  255. X
  256. X  if rotint = -1 then
  257. X  begin
  258. X    if position = 1 then newposition:=4
  259. X    else
  260. X      newposition:=position -1;
  261. X  end
  262. X  else
  263. X  if rotint = 1 then
  264. X  begin
  265. X    if position = 4 then newposition:=1
  266. X    else
  267. X      newposition:=position +1;
  268. X  end;
  269. X
  270. X
  271. X  check(shape,newposition,y,ax,change);
  272. X  if change = true then
  273. X  begin
  274. X    shapestuff(shape,position,y,x,screen,0);
  275. X    position:=newposition;
  276. X    x:=ax;
  277. X    shapestuff(shape,position,y,x,screen,2);
  278. X    printshape(screen,y,x);
  279. X  end;
  280. Xend;
  281. X`7B*************************************************************************
  282. V****`7D
  283. X
  284. X
  285. X`7B*************************************************************************
  286. V****`7D
  287. Xprocedure Movement(var screen:screenarray; shape,position:integer;
  288. X                   var y,x:integer; d:integer);
  289. X
  290. X
  291. Xvar
  292. X  move:boolean;
  293. X  a,
  294. X  b:integer;
  295. Xbegin
  296. X  move:=true;
  297. X  if d = 1 then
  298. X  begin
  299. X    for a:= x+2 downto x-2 do
  300. X      for b:=y+2 downto y-1 do
  301. X        if (a >1) and (a<11) and (b > 1) and (b < 23) then
  302. X        begin
  303. X          if (a = 10) and (screen`5Bb,a`5D = 2) then move:=false;
  304. X          if (screen`5Bb,a`5D = 1) and (screen`5Bb,a-1`5D = 2) then move:=fa
  305. Vlse;
  306. X        end;`20
  307. X  end
  308. X  else
  309. X  if d = -1 then
  310. X  begin
  311. X    for a:=x-3 to x+1 do
  312. X      for b:=y-1 to y+2 do
  313. X        if (a >0) and (a<9) and (b>1) and (b<23) then
  314. X        begin
  315. X          if (a = 1) and (screen`5Bb,a`5D = 2) then move:=false;
  316. X          if (screen`5Bb,a`5D = 1) and (screen`5Bb,a+1`5D = 2) then move:=fa
  317. Vlse;
  318. X        end;
  319. X  end;`20
  320. X  if move = true then
  321. X  begin
  322. X    shapestuff(shape,position,y,x,screen,0);
  323. X    x:=x+d;
  324. X    shapestuff(shape,position,y,x,screen,2);
  325. X    printshape(screen,y,x);
  326. X  end;
  327. Xend;
  328. X`7B************************************************************************`
  329. V7D
  330. X`7B*************************************************************************
  331. V****`7D
  332. Xprocedure Down(var screen:screenarray; shape,position:integer; var y,x:integ
  333. Ver;
  334. X               var fast:boolean);
  335. X
  336. X
  337. Xvar
  338. X  move:boolean;
  339. X  a,
  340. X  b:integer;
  341. X
  342. Xbegin
  343. X  move:=true;
  344. X  for b:=y+3 downto y-1 do
  345. X    for a:= x+2 downto x-2 do
  346. X      if (a >0) and (a<11) and (b > 1) and (b < 23) then
  347. X      begin
  348. X        if (b = 22) and (screen`5Bb,a`5D = 2) then move:=false;
  349. X        if (screen`5Bb,a`5D = 1) and (screen`5Bb-1,a`5D = 2) then move:=fals
  350. Ve;
  351. X      end;`20
  352. X  if move = true then
  353. X  begin
  354. X    if fast = true then
  355. X    begin
  356. X      y:=y+1;
  357. X      shapestuff(shape,position,y-1,x,screen,0);
  358. X      printshape(screen,y,x);
  359. X      shapestuff(shape,position,y,x,screen,2);
  360. X      repeat
  361. X        move:=true;
  362. X        for b:=y+3 downto y-1 do
  363. X          for a:= x+2 downto x-2 do
  364. X            if (a >0) and (a<11) and (b > 1) and (b < 23) then
  365. X            begin
  366. X              if (b = 22) and (screen`5Bb,a`5D = 2) then move:=false;
  367. X              if (screen`5Bb,a`5D = 1) and (screen`5Bb-1,a`5D = 2 ) then mov
  368. Ve:=false;
  369. X            end;
  370. X         if move = true then
  371. X         begin
  372. X           y:=y+1;
  373. X           shapestuff(shape,position,y-1,x,screen,0);
  374. X           shapestuff(shape,position,y,x,screen,2);
  375. X         end;
  376. X       until move=false;
  377. X       printshape(screen,y,x);
  378. X    end
  379. X    else
  380. X    begin
  381. X      y:=y+1;
  382. X      screen`5By-1,x`5D:=0;
  383. X      screen`5By,x`5D:=2;
  384. X      shapestuff(shape,position,y-1,x,screen,0);
  385. X      shapestuff(shape,position,y,x,screen,2);
  386. X      printshape(screen,y,x);
  387. X    end;
  388. X  end;
  389. X  fast:=false;
  390. Xend;
  391. X`7B************************************************************************`
  392. V7D
  393. X
  394. Xprocedure printall(screen:screenarray; score,lines,level:integer);
  395. X
  396. X
  397. Xvar
  398. X  a,
  399. X  b:integer;
  400. X  g,
  401. X  h,
  402. X  xchrhigh,
  403. X  xchrlow,
  404. X  ychrhigh,
  405. X  ychrlow:char;
  406. X  stuff:packed array`5B1..10`5D of char;
  407. X
  408. Xbegin
  409. X `20
  410. X  cls;
  411. X  for I:=1 to 22 do
  412. X  begin
  413. X    intochar(g,h,ychrhigh,ychrlow,1,I);
  414. X    writeln(chr(27),'`5B',ychrhigh,ychrlow,';30H`7C          `7C');
  415. X  end;
  416. X  writeln(chr(27),'`5B23;30H------------');
  417. X  if flag then writeln(chr(27),'`5B03;49HNEXT');
  418. X  writeln(chr(27),'`5B10;1HSCORE:',score:1);
  419. X  writeln(chr(27),'`5B12;1HLEVEL:',level:1);
  420. X  writeln(chr(27),'`5B14;1HLINES:',((5*level)-lines):2);
  421. X  for a:=1 to 22 do
  422. X  begin
  423. X    intochar(xchrhigh,xchrlow,ychrhigh,ychrlow,31,a);
  424. X    for b:=1 to 10 do
  425. X    begin
  426. X      if screen`5Ba,b`5D = 1 then stuff`5Bb`5D:='#'
  427. X      else
  428. X        stuff`5Bb`5D:=' ';
  429. X    end;
  430. X    writeln(chr(27),'`5B',ychrhigh,ychrlow,';31H',stuff);
  431. X  end;
  432. Xend;
  433. X`7B*************************************************************************
  434. V*****`7D
  435. X
  436. X`7B*************************************************************************
  437. V*****`7D
  438. Xprocedure editshape(key:integer; var nshape:integer);
  439. X
  440. X
  441. Xbegin
  442. X  nshape:=key-48;
  443. X  printnext(nshape);
  444. Xend;
  445. X`7B*************************************************************************
  446. V*****`7D
  447. X`7B***********************************************`7D
  448. Xprocedure getyearday(inp:datestr; var year,day:integer);
  449. X
  450. Xvar
  451. X  digit1,
  452. X  digit2,
  453. X  digit3,
  454. X  digit4:integer;
  455. X  offset:integer;
  456. X
  457. Xbegin
  458. X  offset:= ord('1') + 1;
  459. X  digit1:= ord(inp`5B8`5D) - offset;
  460. X  digit2:= ord(inp`5B9`5D) - offset;
  461. X  digit3:= ord(inp`5B10`5D) - offset;
  462. X  digit4:= ord(inp`5B11`5D) - offset;
  463. X  year:= digit4 + (10*digit3) + (100*digit2) + (1000*digit1);
  464. X  digit1:= ord(inp`5B1`5D) - offset;
  465. X  digit2:= ord(inp`5B2`5D) - offset;
  466. X  day:= digit2 + (10*digit1);
  467. Xend;
  468. X`7B************************************************`7D
  469. X
  470. X`7B**********************************************`7D
  471. Xprocedure getmonth(inp:datestr; var month:integer);
  472. X
  473. Xbegin
  474. X `20
  475. X  if (inp`5B4`5D = 'J') and (inp`5B5`5D = 'A') then month:=1
  476. X  else
  477. X  if (inp`5B4`5D = 'F') then month:=2
  478. X  else
  479. X  if (inp`5B4`5D = 'M') and (inp`5B6`5D = 'R') then month:=3
  480. X  else
  481. X  if (inp`5B4`5D = 'A') and (inp`5B5`5D = 'P') then month:=4
  482. X  else
  483. X  if (inp`5B4`5D = 'M') and (inp`5B6`5D = 'Y') then month:=5
  484. X  else
  485. X  if (inp`5B4`5D = 'J') and (inp`5B6`5D = 'N') then month:=7
  486. X  else
  487. X  if (inp`5B4`5D = 'J') then month:=6
  488. X  else
  489. X  if (inp`5B4`5D = 'A') and (inp`5B5`5D = 'U') then month:=8
  490. X  else
  491. X  if (inp`5B4`5D = 'S') then month:=9
  492. X  else
  493. X  if (inp`5B4`5D = 'O') then month:=10
  494. X  else
  495. X  if (inp`5B4`5D = 'N') then month:=11
  496. X  else
  497. X  if (inp`5B4`5D = 'D') then month:=12;
  498. Xend;
  499. X
  500. X`7B*************************************************************************
  501. V*****`7D
  502. X`7B*************************************************************************
  503. V*****`7D
  504. Xfunction older(one,two:datestr):boolean;
  505. X
  506. X
  507. Xvar
  508. X  oneyear,
  509. X  twoyear,
  510. X  onemonth,
  511. X  twomonth,
  512. X  oneday,
  513. X  twoday:integer;
  514. X
  515. Xbegin
  516. X  getyearday(one,oneyear,oneday);
  517. X  getyearday(two,twoyear,twoday);
  518. X  getmonth(one,onemonth);
  519. X  getmonth(two,twomonth);
  520. X  if oneyear < twoyear then older:=true
  521. X  else
  522. X    if onemonth < twomonth then older:=true
  523. X    else
  524. X      if oneday < twoday then older:=true
  525. X      else
  526. X        older:=false;
  527. Xend;
  528. X`7B*************************************************************************
  529. V*****`7D
  530. X`7B*************************************************************************
  531. V*****`7D
  532. X
  533. X
  534. X`7B*************************************************************************
  535. V*****`7D
  536. X`7B*************************************************************************
  537. V*****`7D
  538. XProcedure MainGame(left,right,rotleft,rotright,speed,quitkey,redraw:char;
  539. X                   level:integer; cheat:boolean);
  540. X
  541. Xvar
  542. X  oldest:integer;
  543. X  saved,
  544. X  saving:saverec;
  545. X  count:integer;
  546. X  quit:boolean;
  547. X  a,b:integer;
  548. X  height:integer;
  549. X  choice:char;
  550. X  nx,
  551. X  ny,
  552. X  nshape,
  553. X  nposition:integer;
  554. X  fast:boolean;
  555. X  gotin:boolean;
  556. X
  557. Xbegin
  558. X
  559. Xrandomise;
  560. Xif restored = false then
  561. Xbegin
  562. X  for a:=1 to 22 do
  563. X    for b:=1 to 10 do
  564. X      screen`5Ba,b`5D:=0;
  565. X  score:=0;
  566. X  position:=1;
  567. X  create(shape,position,y,x);
  568. X  lines:=0;
  569. X  shapestuff(shape,position,y,x,screen,2);
  570. Xend;
  571. Xcreate(nshape,nposition,ny,nx);
  572. Xcount:=0;
  573. Xfast:=false;
  574. Xquit:=false;
  575. Xott:=false;
  576. Xcls;
  577. X
  578. Xprintshape(screen,y,x);
  579. Xprintall(screen,score,lines,level);
  580. Xif restored then`20
  581. X  writeln(chr(27),'`5B10;49HPress any key to continue game')
  582. Xelse
  583. X  writeln(chr(27),'`5B10;49HPress any key to play game');
  584. Xwaitkey(key,chan);
  585. Xwriteln(chr(27),'`5B10;49H                                ');
  586. Xrestored:=false;
  587. Xif flag then printnext(nshape);
  588. Xrepeat
  589. X  readkey(key,chan);
  590. X  choice:=chr(key);
  591. X  if choice = left then Movement(screen,shape,position,y,x,-1)
  592. X  else
  593. X  if choice = right then movement(screen,shape,position,y,x,1)
  594. X  else
  595. X  if choice = rotleft then Rotation(screen,shape,position,-1,y,x)
  596. X  else
  597. X  if choice = rotright then Rotation(screen,shape,position,1,y,x)
  598. X  else
  599. X  if choice = speed then fast:=true
  600. X  else
  601. X  if  (choice in `5B'1'..'7'`5D) and (cheat = true) then editshape(key,nshap
  602. Ve)
  603. X  else
  604. X  if choice = redraw then
  605. X  begin
  606. X    printall(screen,score,lines,level);
  607. X    if flag then printnext(nshape);
  608. X  end
  609. X  else
  610. X    if choice = quitkey then ott:=true
  611. X  else
  612. X    if choice = '!' then`20
  613. X    begin
  614. X      cls;
  615. X      writeln('%DCL-I-SPAWN, Type eoj to return to Shapes');
  616. X      spawn;
  617. X      printall(screen,score,lines,level);
  618. X      if flag then printnext(nshape);
  619. X      writeln(chr(27),'`5B10;49HPress any key to continue Shapes');
  620. X      waitkey(key,chan);
  621. X      writeln(chr(27),'`5B10;49H                                ');
  622. X    end
  623. X  else
  624. X    if choice = '@' then
  625. X    begin
  626. X      cls;
  627. X      Writeln(                      'Save game option');
  628. X      usernum(userid);
  629. X      if (userid = 'CADP02  ') or
  630. X         (userid = 'CADP03  ') then`20
  631. X      begin`20
  632. X        write('Enter username, MAX 8 letters, RETURN for default: ');
  633. X        userid:='        ';
  634. X        readln(userid);
  635. X        if userid`5B1`5D = ' ' then usernum(userid);
  636. X      end;
  637. X      saving.num:=score;
  638. X      saving.level:=level;
  639. X      saving.outp:=screen;
  640. X      saving.lines:=lines;
  641. X      saving.x:=x;
  642. X      saving.y:=y;
  643. X      saving.shape:=shape;
  644. X      saving.position:=position;
  645. X      saving.user:=userid;
  646. X      DATE(saving.current);
  647. X      open(Save,Savefile,history:=readonly);
  648. X      reset(save);
  649. X      del:=false;
  650. X      for I:=1 to 100 do
  651. X      begin
  652. X        read(save,peeps`5BI`5D);
  653. X        if (del = true) and (peeps`5BI`5D.user = saving.user) then
  654. X          peeps`5BI`5D.user:='UNUSED  ';
  655. X        if (del = false) and (peeps`5BI`5D.user = 'UNUSED  ') then
  656. X        begin
  657. X          peeps`5BI`5D:=saving;
  658. X          del:=true;
  659. X        end;
  660. X        if (del = false) and (peeps`5BI`5D.user = saving.user) then
  661. X        begin
  662. X          del:=true;
  663. X          peeps`5BI`5D:=saving;
  664. X        end;
  665. X      end;
  666. X      if del = false then
  667. X      begin
  668. X        reset(save);
  669. X        read(save,peeps`5B1`5D);
  670. X        oldest:=1;
  671. X        for I:=2 to 100 do
  672. X        begin
  673. X          read(save,peeps`5BI`5D);
  674. X          if older(peeps`5BI-1`5D.current,peeps`5BI`5D.current) = false then
  675. V`20
  676. X            oldest:=I;
  677. X        end;
  678. X        peeps`5Boldest`5D:=saving;
  679. X      end;
  680. X      close(save);
  681. X      open(Save,Savefile,history:=old);
  682. X      rewrite(save);
  683. X      for I:=1 to 100 do
  684. X        write(save,peeps`5BI`5D);
  685. X      close(save);
  686. X      ott:=true;
  687. X      del:=false;
  688. X      writeln('Game saved.');
  689. X      writeln('Press any key for main menu.');
  690. X      waitkey(key,chan);
  691. X    end;
  692. X  if count = 3 then
  693. X  begin
  694. X    height:=y;
  695. X    Down(screen,shape,position,y,x,fast);
  696. X    if height = y then
  697. X    begin
  698. X      for a:=1 to 10 do
  699. X        if screen`5B1,a`5D=2 then ott:=true;
  700. X      shapestuff(shape,position,y,x,screen,1);
  701. X      printshape(screen,y,x);
  702. X      linestuff(screen,lines,level,score);
  703. X      shape:=Nshape;
  704. X      position:=Nposition;
  705. X      y:=Ny;
  706. X      x:=Nx;
  707. X      create(nshape,nposition,ny,nx);
  708. X      if flag then printnext(nshape);
  709. X      shapestuff(shape,position,y,x,screen,2);
  710. X      if lines >= 5*level then
  711. X      begin
  712. X        level:=level+1;
  713. X        bonus(score,screen,level);
  714. X        lines:=0;
  715. X        printall(screen,score,lines,level);
  716. X        if flag then printnext(nshape);
  717. X      end;
  718. X    end;
  719. X    count:=0;
  720. X  end;
  721. X  count:=count+1;
  722. Xuntil OTT = true;
  723. X
  724. Xif choice <> '@' then
  725. Xbegin
  726. X  highscores(score,level,Htable,scores,gotin);
  727. X  if gotin then viewscores(Htable,scores,key,chan)
  728. Xend
  729. Xend;
  730. X`7B*************************************************************************
  731. V*****`7D
  732. X`7B*************************************************************************
  733. V*****`7D
  734. X
  735. X`7B*************************************************************************
  736. V*****`7D
  737. X`7B*************************************************************************
  738. V*****`7D
  739. XProcedure RESTORE;
  740. X
  741. Xvar
  742. X  I:integer;
  743. X
  744. Xbegin
  745. X  cls;
  746. X  writeln('                    Restore saved game option');
  747. X  usernum(userid);
  748. X  if (userid = 'CADP02  ') or
  749. X     (userid = 'CADP03  ') then`20
  750. X  begin
  751. X    write('Enter username, MAX 8 letters, RETURN for default: ');
  752. X    userid:='        ';
  753. X    readln(userid);
  754. X    if userid`5B1`5D = ' ' then usernum(userid);
  755. X  end;
  756. X  restored:=false;
  757. X  open(Save,Savefile,history:=readonly);
  758. X  reset(save);
  759. X  for I:=1 to 100 do
  760. X  begin
  761. X    read(save,peeps`5BI`5D);
  762. X    if peeps`5BI`5D.user = userid then
  763. X    begin
  764. X      cls;
  765. X      writeln('Restoring...');
  766. X      lines:=peeps`5BI`5D.lines;
  767. X      position:=peeps`5BI`5D.position;
  768. X      x:=peeps`5BI`5D.x;
  769. X      y:=peeps`5BI`5D.y;
  770. X      shape:=peeps`5BI`5D.shape;
  771. X      screen:=peeps`5BI`5D.outp;
  772. X      score:=peeps`5BI`5D.num;
  773. X      level:=peeps`5BI`5D.level;
  774. X      peeps`5BI`5D.user:='UNUSED  ';
  775. X      restored:=true;
  776. X    end;
  777. X  end;
  778. X  close(save);
  779. X  open(save,savefile,history:=old);
  780. X  rewrite(save);
  781. X  for I:=1 to 100 do
  782. X    write(save,peeps`5BI`5D);
  783. X  close(save);
  784. X  if restored = true then
  785. X  begin
  786. X    writeln('Restored.');
  787. X    writeln('Press any key for main screen');
  788. X    waitkey(key,chan);
  789. X    MAINGAME(left,right,rotleft,rotright,speed,quitkey,redraw,level,cheat);
  790. X  end
  791. X  else
  792. X  begin
  793. X    writeln('Data file not found.');
  794. X    writeln('Press any key to return to main menu.');
  795. X    waitkey(key,chan);
  796. X  end;
  797. Xend;
  798. X
  799. X`7B*************************************************************************
  800. V*****`7D
  801. X`7B*************************************************************************
  802. V*****`7D
  803. X
  804. X`7B*******************************************************************`7D
  805. Xbegin `7BSHAPES`7D
  806. X  cls;
  807. X  MAKECHAN(chan);
  808. X  HP := FALSE;
  809. X  flag:=true;
  810. X  flag2:=false;
  811. X  cheat:=false;
  812. X  left:='z';right:='x';rotleft:='o';rotright:='p';speed:='`5B';quitkey:='q';
  813. X  factor:=0.15;
  814. X  redraw:='r';
  815. X  levelmin:=1;
  816. X  for I:=1 to 22 do
  817. X    begin `7Bfor`7D
  818. X    for J:=1 to 10 do
  819. X      screen`5BI,J`5D:=0;
  820. X    end; `7Bfor`7D
  821. X  repeat
  822. X    MENUPRINT;
  823. X    repeat
  824. X      if chr(key) = 'c' then flagA:=true;
  825. X      if chr(key) = 'a' then
  826. X      begin
  827. X        if flagA = true then flagB:=true
  828. X        else flagB:=false;
  829. X      end;
  830. X      if chr(key) = 'd' then
  831. X      begin
  832. X        if flagB = true then flagC:=true
  833. X        else flagC:=false;
  834. X      end;
  835. X      if chr(key) = 'p' then
  836. X      begin
  837. X        if flagC = true then flagD:=true
  838. X        else flagD:=false;
  839. X      end;
  840. X      if (chr(key) <> 'c') and (chr(key) <> 'a') and
  841. X         (chr(key) <> 'd') and (chr(key) <> 'p') then
  842. X      begin
  843. X        flagA:=false;
  844. X        flagB:=false;
  845. X        flagC:=false;
  846. X        flagD:=false;
  847. X      end;
  848. X      waitkey(key,chan);
  849. X    until chr(key) in `5B'0'..'8'`5D;`20
  850. X    level:=levelmin;
  851. X    if chr(key) <> '8' then flagD:=false;
  852. X    if chr(key)='1' then
  853. X      MAINGAME(left,right,rotleft,rotright,speed,quitkey,redraw,level,cheat)
  854. V;
  855. X    if chr(key)='2' then KEYDEFINE(left,right,rotleft,rotright,speed,quitkey
  856. V,redraw);
  857. X    if chr(key)='3' then VIEWSCORES(Htable,scores,key,chan);
  858. X    if chr(key)='4' then INSTRUCTIONS;
  859. X    if chr(key)='5' then flag:=not(flag);
  860. X    if chr(key)='6' then flag2:=not(flag2);
  861. X    if chr(key)='7' then RESTORE;
  862. X    if flagD then
  863. X    begin
  864. X      cheat:=true;
  865. X      write('level??: ');
  866. X      readln(levelmin);
  867. X      write('reset savefile??: ');
  868. X      readln(answer);
  869. X      if (answer = 'y') or (answer = 'Y') then
  870. X      begin
  871. X        blank.user:='UNUSED  ';
  872. X        open(Save,Savefile,history:=unknown);
  873. X        rewrite(save);
  874. X        for I:=1 to 100 do
  875. X          write(save,blank);
  876. X        close(save);
  877. X      end;
  878. X      write('reset scoreboard??: ');
  879. X      readln(answer);
  880. X      if (answer='y') or (answer ='Y') then
  881. X      begin
  882. X        open (Htable , Htablefile ,
  883. X`09  history := unknown);
  884. X        rewrite(Htable);
  885. X        for A:= 1 to 10 do
  886. X        begin
  887. X          scores`5BA`5D.num:=0;
  888. X          scores`5BA`5D.name:='                                        ';
  889. X          scores`5BA`5D.level:=1;
  890. X          scores`5BA`5D.id:='        ';
  891. X        end;
  892. X        for A:=1 to 10 do
  893. X          write(Htable,scores`5BA`5D);
  894. X        close(Htable);
  895. X      end;
  896. X    end;
  897. X  until (chr(key)='0');
  898. X  cls;
  899. X    writeln('There now, that didn''t hurt much did it??');
  900. X    writeln('Byeeeeeeeeee........');
  901. Xend. `7BSHAPES`7D
  902. X`7B*******************************************************************`7D
  903. X
  904. $ CALL UNPACK SHAPES.PAS;2 493778005
  905. $ create 'f'
  906. X/***************************************************************************
  907. V****
  908. XCopyright 1989,1990 by Colin Cowie, Glasgow, Scotland.
  909. X
  910. X                        All Rights Reserved
  911. X
  912. XPermission to use, copy, modify, and distribute this software and its`20
  913. Xdocumentation for any purpose and without fee is hereby granted,`20
  914. Xprovided that the above copyright notice appear in all copies and that
  915. Xboth that copyright notice and this permission notice appear in
  916. Xsupporting documentation.
  917. X****************************************************************************
  918. V***/
  919. X
  920. X#include <string.h>
  921. X#include <jpidef.h>
  922. X#include <iodef.h>             `20
  923. X#include <descrip.h>
  924. X
  925. Xtypedef struct
  926. X`7B
  927. X`09unsigned short`09length ;
  928. X`09char`09`09dtype ;
  929. X`09char`09`09class ;
  930. X`09char`09`09*pntr ;
  931. X`7DDESCR ;
  932. X
  933. X#define stdescr(name,string) name.length = strlen(string);\
  934. X name.dtype = DSC$K_DTYPE_T; name.class = DSC$K_CLASS_S;\
  935. X name.pntr = string ;
  936. X
  937. X
  938. Xvoid makechan(chan)
  939. Xint *chan;
  940. X`7B
  941. X  DESCR term;
  942. X  int status;
  943. X  stdescr(term,"TT");
  944. X  status = sys$assign (&term,chan,0,0);
  945. X  if (status != 1) lib$STOP(status);
  946. X`7D
  947. X
  948. Xvoid readkey(key,chan)
  949. Xint *chan;
  950. Xint *key;
  951. X
  952. X`7B
  953. X  char inkey;                              `20
  954. X  int status;                   `20
  955. X  int func;
  956. X  inkey = (char) 0;
  957. X  func = IO$_READVBLK `7C IO$M_NOECHO `7C IO$M_TIMED;
  958. X  status = sys$qiow(0,*chan,func,0,0,0,&inkey,1,0,0,0,0);
  959. X  if (status != 1) lib$STOP(status);
  960. X  *key = (int) inkey;
  961. X`7D
  962. X
  963. Xvoid waitkey(key,chan)
  964. Xint *chan;
  965. Xint *key;
  966. X
  967. X`7B
  968. X  char inkey;                              `20
  969. X  int status;                   `20
  970. X  int func;
  971. X  inkey = (char) 0;
  972. X  func = IO$_READVBLK `7C IO$M_NOECHO `7C IO$M_PURGE;
  973. X  status=sys$qiow(0,*chan,func,0,0,0,&inkey,1,0,0,0,0);
  974. X  if (status != 1) lib$STOP(status);
  975. X  *key = (int) inkey;
  976. X`7D
  977. X
  978. Xvoid spawn()
  979. X`7B
  980. X  DESCR userid;
  981. X  stdescr(userid,"Shapes_Refugee");
  982. X  LIB$SPAWN(0,0,0,0,&userid,0,0,0,0,0,0,0);
  983. X`7D
  984. X
  985. Xparam(word)
  986. Xchar word`5B5`5D;
  987. X`7B
  988. X  DESCR inp;
  989. X  int length;
  990. X  stdescr(inp,"    ");
  991. X  LIB$GET_FOREIGN(&inp,0,&length,0); `20
  992. X  strcpy(word,inp.pntr);
  993. X`7D
  994. X
  995. Xvoid usernum(userid)
  996. Xchar userid`5B8`5D;
  997. X`7B
  998. X  DESCR u_name;
  999. X  int status;
  1000. X  stdescr(u_name,"        ");
  1001. X  lib$getjpi(&(JPI$_USERNAME),0,0,0,&u_name,0);
  1002. X  strcpy(userid,u_name.pntr);
  1003. X`7D
  1004. X
  1005. Xvoid waitx(tim)
  1006. Xfloat *tim;
  1007. X`7B
  1008. X  lib$wait(tim);
  1009. X`7D
  1010. $ CALL UNPACK INCLUDES.C;1 1613696431
  1011. $ create 'f'
  1012. XC---------------------------------------------------------------------
  1013. XC RND Function - Designed, Written and Programmed by Stephen Macdonald
  1014. XC Code is copyright 1988 Stephen Macdonald CHBS08 Software Consultants
  1015. XC---------------------------------------------------------------------
  1016. X`09SUBROUTINE Randomise
  1017. X`09INTEGER seed
  1018. X`09COMMON /seed/seed
  1019. X`09CHARACTER date*30
  1020. X`09CALL LIB$DATE_TIME(%DESCR(date))
  1021. X`09seed=(10000*(ICHAR(date(16:16))-ICHAR('0'))
  1022. X     +        +1000*(ICHAR(date(17:17))-ICHAR('0'))
  1023. X     +        + 100*(ICHAR(date(19:19))-ICHAR('0'))
  1024. X     +        +  10*(ICHAR(date(20:20))-ICHAR('0'))
  1025. X     +        +     (ICHAR(date(22:22))-ICHAR('0')))
  1026. X`09END
  1027. X
  1028. X
  1029. X`09INTEGER FUNCTION Random(min,max)
  1030. X`09INTEGER min,max,seed
  1031. X`09REAL rnd,realseed
  1032. X`09COMMON /seed/seed
  1033. X`09seed=(((seed+1)*75)-1).AND.65535
  1034. X`09realseed=seed
  1035. X`09rnd=(realseed/65536)*(max-min)+min
  1036. X`09random=rnd
  1037. X`09END         `20
  1038. XC---------------------------------------------------------------------
  1039. XC RND Function - Designed, Written and Programmed by Stephen Macdonald
  1040. XC Code is copyright 1988 Stephen Macdonald CHBS08 Software Consultants
  1041. XC---------------------------------------------------------------------
  1042. $ CALL UNPACK RAND.FOR;1 325473741
  1043. $ create 'f'
  1044. XThe game Shapes is based on the arcade game tetris, and follows roughly the
  1045. V same
  1046. Xrules, Full instructions are given in the game itself.
  1047. X
  1048. XThe game requires a VT100 compatible terminal, and a VAX running VMS version
  1049. V 4`20
  1050. Xor later (at any rate, 4 was the earliest version it was compiled under).
  1051. X
  1052. XThe source code consists of:-
  1053. X
  1054. X  Shapes.pas     -    The main source code for the game
  1055. X
  1056. X  Includes.c     -    Certain system calls, which were easier to write in 'C
  1057. V'
  1058. X
  1059. X  Rand.for       -    Random number generator, written by a friend, Stephen
  1060. X                      Macdonald, and borrowed by me, cos I couldnt be bother
  1061. Ved
  1062. X
  1063. X
  1064. XSetting up the game:-
  1065. X
  1066. XThe game shapes uses 2 data files, one for the high score table, and one for
  1067. Xany saved games which might exist. The destinations of these files should be
  1068. Xchanged in the source code "Shapes.pas" to point to wherever you want the
  1069. Xfiles.
  1070. X
  1071. XThe actual lines to change are:
  1072. X
  1073. X  Htablefile='disk18:`5Bcadp02.pascal.shapes`5DHtable.dat';
  1074. X  Savefile='disk18:`5Bcadp02.pascal.shapes`5Dsave.dat';
  1075. X
  1076. X
  1077. XTo compile this code, execute the command procedure "compile.com" which is
  1078. Xsupplied with this archive (e.g @compile )
  1079. X
  1080. XAfter compiling the code you need to create 2 empty data files, one for
  1081. Xthe saved games, and one for the high score table.
  1082. X
  1083. XThis is done from within the game itself, by entering the "Cheat" mode.
  1084. XTo do this, run the game, and when the menu comes up, type in the string
  1085. X"cadp8". This activates the cheat mode.
  1086. X
  1087. XYou are then asked for a level number. This would be what level you would
  1088. Xlike to start at, if you were going to play the game. At the moment we
  1089. Xare not interested in that, so type 1 and press return.
  1090. X
  1091. XYou are now prompted if you would like to reset the saved games file.
  1092. +-+-+-+-+-+-+-+-  END  OF PART 4 +-+-+-+-+-+-+-+-
  1093. -- 
  1094. \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
  1095. < Joe Koffley                        KOFFLEY@NRLVAX.NRL.NAVY.MIL             >
  1096. < Naval Research Laboratory          KOFFLEY@SMOVAX.NRL.NAVY.MIL             >
  1097. < Space Systems Division             AT&T  :  202-767-0894                   >
  1098. \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
  1099.  
  1100.