home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / usenet / altsrcs / 1 / 1790 < prev    next >
Internet Message Format  |  1990-12-28  |  45KB
  1. From: cadp02@vaxa.strath.ac.uk
  2. Newsgroups: alt.sources,vmsnet.sources.games
  3. Subject: shapes.shar2 (of 2)
  4. Message-ID: <247.26e7cf1c@vaxa.strath.ac.uk>
  5. Date: 7 Sep 90 16:47:24 GMT
  6.  
  7. This is part two of a two part poting of tetris for VAX's
  8.  
  9. Delete everything above the line showing "$Part4:", concatenate part 2 onto
  10. the end of part one and then "@shapes.shar1" to unarchive it
  11.  
  12.  
  13. !-----------------------------------------------------------------------------
  14. $Part4:
  15. $File_is="SHAPES.PAS"
  16. $Check_Sum_is=573653758
  17. $Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
  18. Xprogram Shapes(input,output,Htable,Save);
  19. X
  20. X
  21. V{*****************************************************************************
  22. X**
  23. X   Copyright 1989,1990 by Colin Cowie, Glasgow, Scotland.
  24. X
  25. X                        All Rights Reserved
  26. X
  27. X   Permission to use, copy, modify, and distribute this software and its 
  28. X   documentation for any purpose and without fee is hereby granted, 
  29. X   provided that the above copyright notice appear in all copies and that
  30. X   both that copyright notice and this permission notice appear in 
  31. X   supporting documentation.
  32. V******************************************************************************
  33. X*}
  34. X
  35. X
  36. X
  37. Xconst
  38. X  Htablefile='disk18:[cadp02.pascal.shapes]Htable.dat';
  39. X  Savefile='disk18:[cadp02.pascal.shapes]save.dat';
  40. X
  41. Xtype
  42. X  string = packed array[1..8] of char;
  43. X  scorerec = record
  44. X      num:integer;
  45. X     name:packed array[1..40] of char;
  46. X     level:integer;
  47. X     id:string;
  48. X     end;
  49. X  recfile = file of scorerec;
  50. X  scorearray = array[1..10] of scorerec;
  51. X  screenarray = array[1..22,1..10] of integer;
  52. X  timearray = packed array[1..11] of char;
  53. X  datestr = packed array [1..11] of char;
  54. X  saverec = record
  55. X     num:integer;
  56. X     level:integer;
  57. X     outp:screenarray;
  58. X     x:integer;
  59. X     y:integer;
  60. X     shape:integer;
  61. X     position:integer;
  62. X     lines:integer;
  63. X     user:string;
  64. X     current:datestr;
  65. X      end;
  66. X  saverecfile = file of saverec;
  67. X  savearray = array[1..100] of saverec;
  68. X
  69. Xvar
  70. X  restored:boolean;
  71. X  blank:saverec;
  72. X  peeps:savearray;
  73. X  HP:boolean;
  74. X  factor:real;
  75. X  curr:timearray;
  76. X  flag,
  77. X  flag2:boolean;
  78. X  answer:char;
  79. X  del:boolean;
  80. X  userid:string;
  81. X  flagA,
  82. X  flagB,
  83. X  flagC,
  84. X  flagD:boolean;
  85. X  chan:integer;
  86. X  key:integer;
  87. X  xchrhigh,
  88. X  xchrlow,
  89. X  ychrhigh,
  90. X  ychrlow:char;
  91. X  score,
  92. X  shape,
  93. X  position:integer;
  94. X  cheat:boolean;
  95. X  currd:datestr;
  96. X  I,J,A:integer;
  97. X  x,y:integer;
  98. X  scores:scorearray;
  99. X  OTT:boolean;
  100. X  Htable:recfile;
  101. X  Save,
  102. X  Saver:saverecfile;
  103. X  level:integer;
  104. X  levelmin:integer;
  105. X  screen:screenarray;
  106. X  left,
  107. X  right,
  108. X  rotleft,
  109. X  rotright,
  110. X  speed,
  111. X  redraw,
  112. X  quitkey:char;
  113. X  lines:integer;
  114. X
  115. X{*****************************************************************}
  116. Xprocedure CLS;
  117. Xbegin {CLS}
  118. Xwrite(chr(27),'[H');
  119. Xwriteln(chr(27),'[2J');
  120. Xend; {CLS}
  121. X{*****************************************************************}
  122. X
  123. X{*****************************************************************}
  124. V{*****************************************************************************
  125. X}
  126. Xprocedure makechan(%REF chan:integer);external;
  127. X
  128. Xprocedure readkey(%REF key,chan:integer);external;
  129. X
  130. Xprocedure waitkey(%REF key,chan:integer);external;
  131. X
  132. Xprocedure waitx(%REF factor:real);external;
  133. X
  134. Xprocedure spawn;external;
  135. X
  136. Xprocedure RANDOMISE;fortran;
  137. X
  138. Xfunction RANDOM(min,max:integer):integer;fortran;
  139. X
  140. Xprocedure USERNUM(%stdescr userid:string);fortran;
  141. X{*****************************************************************}
  142. X
  143. X
  144. X{******************************************************************}
  145. Xprocedure highscores(score:integer; bit:integer; var Htable:recfile;
  146. X var scores:scorearray; var gotin:boolean);
  147. X
  148. X
  149. Xvar
  150. X  I,J:integer;
  151. X  newscore:scorerec;
  152. X  A:integer;
  153. X  two:boolean;
  154. X
  155. Xbegin
  156. X  gotin:=false;
  157. X  cls;
  158. X  writeln('You scored: ',score,' points!!');
  159. X  I:=1;
  160. X  open (Htable, Htablefile,
  161. X        history:=readonly);
  162. X  reset(Htable);
  163. X  while (not eof(Htable)) and (I <=10) do
  164. X  begin
  165. X    read(Htable,scores[I]);
  166. X    I:=I+1;
  167. X  end;
  168. X  close(Htable);
  169. X  for A:= I to 10 do
  170. X  begin
  171. X    scores[A].num:=0;
  172. X    scores[A].name:='                                        ';
  173. X    scores[A].level:=1;
  174. X    scores[A].id:='        ';
  175. X  end;
  176. X  if score > scores[10].num then
  177. X  begin
  178. X    two := true;
  179. X    usernum(userid);
  180. X    if (userid='CADP03  ') or
  181. X       (userid='CADP02  ') or
  182. X       (userid='CRAA30  ') or
  183. X       (userid='CRAA38  ') then
  184. X    begin
  185. X      writeln('Enter usernum, maximum 8 chars (RETURN for default):');
  186. X      write(':');
  187. X      userid:='        ';
  188. X      readln(userid);
  189. X      if userid[1]=' ' then usernum(userid);
  190. X    end;
  191. X
  192. X    for I := 10 downto 1 do
  193. X    begin
  194. X      if userid = scores[I].id then
  195. X      begin 
  196. X       if score > scores[I].num then
  197. X        begin
  198. X          for J := I to 9 do
  199. X            scores[J] := scores[J+1];
  200. X          if I = 9 then
  201. X            scores[9] := scores[10];
  202. X          scores[10].num:=0;
  203. X          scores[10].name:='                                       ';
  204. X          scores[10].level:=1;
  205. X          scores[10].id:='        ';
  206. X        end
  207. X        else
  208. X        begin
  209. X          two := false;
  210. X        end;
  211. X      end;
  212. X    end;
  213. X    if two = true then
  214. X    begin
  215. X      gotin:=true;
  216. X      writeln('Well done, yu have made it into the top ten!!');
  217. X      for A:=1 to 20 do
  218. X        newscore.name[A]:=' ';
  219. X      Writeln('Enter name, maximum 40 chars:');
  220. X      write(':');
  221. X      readln(newscore.name);
  222. X      usernum(userid);
  223. X      if (userid='CADP03  ') or 
  224. X         (userid='CADP02  ') or 
  225. X         (userid='CRAA30  ') or
  226. X         (userid='CHBS08  ') then
  227. X      begin
  228. X        writeln('Enter usernum, maximum 8 chars (RETURN for default):');
  229. X        write(':');
  230. X        userid:='        ';
  231. X        readln(userid);
  232. X        if userid[1]=' ' then usernum(userid);
  233. X      end;
  234. X      newscore.num:=score;
  235. X      newscore.level:=bit;
  236. X      newscore.id:=userid;
  237. X      I:=1;
  238. X      while newscore.num < scores[I].num do
  239. X        I:=I+1;
  240. X      for A:=10 downto I+1 do
  241. X        scores[A]:=scores[A-1];    
  242. X      scores[I]:=newscore;
  243. X      open (Htable , Htablefile ,
  244. X  `009history := old);
  245. X      rewrite(Htable);
  246. X      for I:=1 to 10 do
  247. X        write(Htable,scores[I]);
  248. X      close (Htable);
  249. X      writeln('Press any key to view high-score table');
  250. X    end
  251. X    else
  252. X    begin
  253. X      writeln('One entry only per usernum in the high score table!!');
  254. X      writeln('Press any key to return to main menu');
  255. X    end;
  256. X  end
  257. X  else
  258. X  begin
  259. X    writeln('Sorry, yu didnt make the high score table!!!!!!');
  260. X    writeln('Press any key to return to main menu');
  261. X  end;
  262. X  waitkey(key,chan);
  263. Xend;
  264. X{*************************************************************}
  265. X
  266. X
  267. X{*************************************************************}
  268. Xprocedure viewscores(var Htable:recfile; scores:scorearray; key,chan:integer);
  269. X
  270. Xvar
  271. X  score:scorerec;
  272. X  I,
  273. X  A:integer;
  274. X
  275. Xbegin
  276. X  cls;
  277. X  open (Htable, Htablefile,
  278. X        history:=readonly);
  279. X  reset(Htable);
  280. X  I:=1;
  281. X  while (not eof(Htable)) and (I <=10) do 
  282. X  begin
  283. X    read(Htable,score);
  284. X    scores[I]:=score;
  285. X    I:=I+1;
  286. X  end;
  287. X  close (Htable);
  288. X  for A:= I to 10 do
  289. X  begin
  290. X    scores[I].num:=0;
  291. X    scores[I].name:='                                        ';
  292. X    scores[I].level:=1;
  293. X    scores[I].id:='        ';
  294. X  end;
  295. X  Writeln('                       Shapes HIGH SCORE TABLE');
  296. X  writeln;writeln;
  297. V  writeln('          score              name                           level  
  298. Xuserid');
  299. X  for I:=1 to 10 do
  300. X  begin
  301. X    writeln(I:2,'. ',scores[I].num,'     ',scores[I].name,'  ',
  302. X            scores[I].level:2,'    ',scores[I].id);
  303. X  end;
  304. Xwriteln;writeln;
  305. Xwriteln('                         Press any key to return to main menu');
  306. Xwaitkey(key,chan);
  307. Xend;
  308. X
  309. X{***********************************************************}
  310. X
  311. X
  312. X{************************************************************}
  313. Xprocedure INTOCHAR(var xchrhigh,xchrlow,
  314. X                       ychrhigh,ychrlow:char; x,y:integer);
  315. X
  316. Xbegin {INTOCHAR}
  317. X  xchrhigh`009:= chr(ord('0') + x div 10) ;
  318. X  xchrlow`009:= chr(ord('0') + x mod 10) ;
  319. X
  320. X  ychrhigh`009:= chr(ord('0') + y div 10) ;
  321. X  ychrlow`009:= chr(ord('0') + y mod 10) ;
  322. X
  323. Xend; {INTOCHAR}
  324. X{*********************************************************************}
  325. X
  326. X
  327. X{*****************************************************************}
  328. Xprocedure MENUPRINT;
  329. X
  330. Xbegin
  331. X  CLS;
  332. X  writeln(chr(27),'#3               Shapes');
  333. X  writeln(chr(27),'#4               Shapes');
  334. X  writeln(chr(27),'[22;25HCopyright 1989,1990 LokiSoft Ltd.');
  335. X  writeln(chr(27),'[09;31H1. Play Shapes');
  336. X  writeln(chr(27),'[10;31H2. Redefine Keys');
  337. X  writeln(chr(27),'[11;31H3. View Score Board');
  338. X  writeln(chr(27),'[12;31H4. Instructions');
  339. X  write(chr(27),'[13;31H5. Print Next Shape');
  340. X  if flag then writeln('  (YES)') else writeln('  (NO) ');
  341. X  write(chr(27),'[14;31H6. Slow Down Game');
  342. X  if flag2 then writeln('   (YES)') else writeln('   (NO) ');
  343. X  writeln(chr(27),'[15;31H7. Restore Saved Game');
  344. X  writeln(chr(27),'[17;31H0. Exit from game');
  345. X  writeln(chr(27),'[19;31HEnter choice from options above');
  346. X  writeln;
  347. Xend;
  348. X{**********************************************************************}
  349. X{*****************************}
  350. Xprocedure Instructions;
  351. Xbegin
  352. Xcls;
  353. Xwriteln('Hi Guys, here''s another offering from the LokiSoft label,');
  354. Xwriteln('except this one''s good!!!!');
  355. Xwriteln;
  356. Xwriteln('This game is based on a certain arcade game which you may have ');
  357. Xwriteln('played at sometime or other, but I aint mentioning which one cos');
  358. Xwriteln('this is a blatant rip-off of it so its really dead obvious!!');
  359. Xwriteln;
  360. Xwriteln('Anyway, its like this: there are these seven different shapes:-');
  361. Xwriteln;
  362. Xwriteln('@@        @        @        @        @        @        @');
  363. Xwriteln('@@        @        @        @@      @@        @@       @');
  364. Xwriteln('          @@      @@         @      @         @        @');
  365. Xwriteln('                                                       @');
  366. Xwriteln('And these shapes fall from the top of the screen to the bottom,');
  367. Xwriteln('piling on top of one another.');
  368. Xwriteln('You can rotate each shape, and move it left or right, the ');
  369. Xwriteln('object being to get complete unbroken lines of "@@@@@@@@@@" at ');
  370. Xwriteln('the bottom of the screen.');
  371. Xwriteln('when this happens, that line is deleted, and the pile drops down');
  372. Xwriteln('and you are given points depending on which level you are on');
  373. Xwriteln;
  374. Xwriteln('                           Press any key for next page');
  375. Xwaitkey(key,chan);
  376. Xcls;
  377. Xwriteln;
  378. Xwriteln('If you are fortunate enough to get more than one completed line at');
  379. Vwriteln('a time, you receive a bonus dependent on the level you are on and the
  380. X');
  381. Xwriteln('number of lines completed.');
  382. Xwriteln('After completing 5 lines, you move on to level 2 where you have to');
  383. Xwriteln('complete 10 lines,..15 for level 3, and so on.');
  384. Xwriteln('There is a bonus at the end of each level depending on which level');
  385. Vwriteln('you are on, and how low the pile of bricks is,..the lower the pile,')
  386. X;
  387. Xwriteln('the higher the bonus');
  388. Vwriteln('For each level, the number of points per completed line, and potentia
  389. Xl');
  390. Xwriteln('bonus per level is increased, and there are an infinite number');
  391. Xwriteln('of levels in the game.');
  392. Xwriteln;
  393. Xwriteln('The default keys are: z - left, x - right,');
  394. Xwriteln('                o - rotate left, p - rotate right,');
  395. Xwriteln('     [ - move shape to bottom, r - redraw screen, q - quit');
  396. Xwriteln('     ! - to spawn to dcl, @ - to save game');
  397. Xwriteln;
  398. Xwriteln('                           Press any key for next page');
  399. Xwaitkey(key,chan);
  400. Xcls;
  401. Xwriteln('Note on Saving game:-');
  402. Xwriteln;
  403. Xwriteln('It is only possible for any user to have one saved game at a time,');
  404. Vwriteln('and if you attempt to save a game when you already have one stored,')
  405. X;
  406. Xwriteln('the stored game will be written over!!!');
  407. Xwriteln('Stored games will automatically be deleted when restored.');
  408. Xwriteln;
  409. Vwriteln('There is total space on the save-file for 100 games, and when it is')
  410. X;
  411. Vwriteln('full, whenever anyone attempts to save their game, the oldest previou
  412. Xs');
  413. Xwriteln('saved game is written over!');
  414. Xwriteln;
  415. Xwriteln('Note on Slowing down game option:-');
  416. Xwriteln;
  417. Vwriteln('This option is intended only for people using workstations or similar
  418. X');
  419. Xwriteln('which vastly speed up the screen printing, thereby making the game');
  420. Xwriteln('unplayable. The slow down option negates this problem.');
  421. Xwriteln;
  422. Xwriteln('Now I''ll take this opportunity to wish you happy playing and good');
  423. Xwriteln('luck, you''ll need it!!!!');
  424. Xwriteln(chr(27),'[22;30HPress any key for main menu');
  425. Xwaitkey(key,chan);
  426. Xend;
  427. X{*****************************}
  428. X
  429. X
  430. X
  431. X{*******************************************************************}  
  432. Vprocedure KEYDEFINE(var left,right,rotleft,rotright,speed,quitkey,redraw:char)
  433. X;
  434. X
  435. Xvar
  436. X
  437. X  redrawint,
  438. X  null,
  439. X  leftint,
  440. X  rightint,
  441. X  rotleftint,
  442. X  rotrightint,
  443. X  speedint,
  444. X  stopint:integer;
  445. X  quitint:integer;
  446. X
  447. Xbegin {KEYDEFINE}
  448. X  CLS;
  449. X  writeln('         Defining Keys For SHAPES ');
  450. X  writeln;
  451. X  writeln;
  452. X  writeln;
  453. X  writeln;
  454. X  writeln('Press key for movement LEFT: ');
  455. X  waitkey(leftint,chan);
  456. X  left:=chr(leftint);
  457. X  writeln(left);
  458. X  writeln('press key for movement RIGHT: ');
  459. X  waitkey(rightint,chan);
  460. X  while (rightint=leftint) do
  461. X    waitkey(rightint,chan);
  462. X  right:=chr(rightint);
  463. X  writeln(right);
  464. X  writeln('Press key for rotation ANTICLOCKWISE: ');
  465. X  waitkey(rotleftint,chan);
  466. X  while (rotleftint=leftint) or
  467. X        (rotleftint=rightint) do
  468. X    waitkey(rotleftint,chan);
  469. X  rotleft:=chr(rotleftint);
  470. X  writeln(rotleft);
  471. X  writeln('press key for rotation CLOCKWISE: ');
  472. X  waitkey(rotrightint,chan);
  473. X  while (rotrightint=rightint) or
  474. X        (rotrightint=rotleftint) or
  475. X        (rotrightint=leftint) do
  476. X    waitkey(rotrightint,chan);
  477. X  rotright:=chr(rotrightint);
  478. X  writeln(rotright);
  479. X  writeln('press key to move shape to bottom: ');
  480. X  waitkey(speedint,chan);
  481. X  while (speedint=rightint) or 
  482. X        (speedint=leftint) or 
  483. X        (speedint=rotleftint) or
  484. X        (speedint=rotrightint) do
  485. X    waitkey(speedint,chan);
  486. X  speed:=chr(speedint);
  487. X  writeln(speed);
  488. X  writeln('press key to quit game: ');
  489. X  waitkey(quitint,chan);
  490. X  while (quitint=rightint) or 
  491. X        (quitint=leftint) or 
  492. X        (quitint=rotleftint) or
  493. X        (quitint=rotrightint) or
  494. X        (quitint=speedint) do
  495. X    waitkey(quitint,chan);
  496. X  quitkey:=chr(quitint);
  497. X  writeln(quitkey);
  498. X  writeln('press key to redraw screen');
  499. X  waitkey(redrawint,chan);
  500. X  while (redrawint=rightint) or
  501. X        (redrawint=leftint) or
  502. X        (redrawint=rotrightint) or
  503. X        (redrawint=rotleftint) or
  504. X        (redrawint=quitint) do
  505. X    waitkey(redrawint,chan);
  506. X  redraw:=chr(redrawint);
  507. X  writeln(redraw);
  508. X  writeln;
  509. X  writeln;
  510. X  writeln;
  511. X  writeln('    Press any key to continue ');
  512. X  waitkey(null,chan);
  513. Xend; {KEYDEFINE}
  514. X{*******************************************************************}
  515. X
  516. X
  517. X
  518. X{***********************************************************************}
  519. Xprocedure Shapestuff(shape,position,y,x:integer; var screen:screenarray;
  520. X                     n:integer);
  521. Xbegin
  522. X  screen[y,x]:=n;
  523. X  if shape = 1 then
  524. X  begin
  525. X    screen[y,x+1]:=n;
  526. X    screen[y+1,x]:=n;
  527. X    screen[y+1,x+1]:=n;
  528. X  end
  529. X  else
  530. X  if shape = 2 then
  531. X  begin
  532. X    if position = 1 then
  533. X    begin
  534. X      screen[y-1,x]:=n;
  535. X      screen[y+1,x]:=n;
  536. X      screen[y+1,x+1]:=n;
  537. X    end
  538. X    else
  539. X    if position = 2 then
  540. X    begin
  541. X      screen[y,x+1]:=n;
  542. X      screen[y,x-1]:=n;
  543. X      screen[y+1,x-1]:=n;
  544. X    end
  545. X    else
  546. X    if position = 3 then
  547. X    begin
  548. X      screen[y+1,x]:=n;
  549. X      screen[y-1,x]:=n;
  550. X      screen[y-1,x-1]:=n;
  551. X    end
  552. X    else
  553. X    if position = 4 then
  554. X    begin
  555. X      screen[y,x-1]:=n;
  556. X      screen[y,x+1]:=n;
  557. X      screen[y-1,x+1]:=n;
  558. X    end;
  559. X  end
  560. X  else
  561. X  if shape = 3 then
  562. X  begin
  563. X    if position = 1 then
  564. X    begin
  565. X      screen[y-1,x]:=n;
  566. X      screen[y+1,x]:=n;
  567. X      screen[y+1,x-1]:=n;
  568. X    end
  569. X    else
  570. X    if position = 2 then
  571. X    begin
  572. X      screen[y,x+1]:=n;
  573. X      screen[y,x-1]:=n;
  574. X      screen[y-1,x-1]:=n;
  575. X    end
  576. X    else
  577. X    if position = 3 then
  578. X    begin
  579. X      screen[y-1,x]:=n;
  580. X      screen[y+1,x]:=n;
  581. X      screen[y-1,x+1]:=n;
  582. X    end
  583. X    else
  584. X    if position = 4 then
  585. X    begin
  586. X      screen[y,x-1]:=n;
  587. X      screen[y,x+1]:=n;
  588. X      screen[y+1,x+1]:=n;
  589. X    end;
  590. X  end
  591. X  else
  592. X  if shape = 4 then
  593. X  begin
  594. X    if position = 1 then
  595. X    begin
  596. X      screen[y-1,x]:=n;
  597. X      screen[y+1,x]:=n;
  598. X      screen[y,x+1]:=n;
  599. X    end
  600. X    else
  601. X    if position = 2 then
  602. X    begin
  603. X      screen[y+1,x]:=n;
  604. X      screen[y,x-1]:=n;
  605. X      screen[y,x+1]:=n;
  606. X    end
  607. X    else
  608. X    if position = 3 then
  609. X    begin
  610. X      screen[y-1,x]:=n;
  611. X      screen[y+1,x]:=n;
  612. X      screen[y,x-1]:=n;
  613. X    end
  614. X    else
  615. X    if position = 4 then
  616. X    begin
  617. X      screen[y-1,x]:=n;
  618. X      screen[y,x-1]:=n;
  619. X      screen[y,x+1]:=n;
  620. X    end;
  621. X  end
  622. X  else
  623. X  if shape = 5 then
  624. X  begin
  625. X    if (position = 1) or (position = 3) then
  626. X    begin
  627. X      screen[y+1,x]:=n;
  628. X      screen[y,x+1]:=n;
  629. X      screen[y-1,x+1]:=n;
  630. X    end
  631. X    else
  632. X    if (position = 2) or (position = 4) then
  633. X    begin
  634. X      screen[y,x-1]:=n;
  635. X      screen[y+1,x]:=n;
  636. X      screen[y+1,x+1]:=n;
  637. X    end;
  638. X  end
  639. X  else
  640. X  if shape = 6 then
  641. X  begin
  642. X    if (position = 1) or (position = 3) then
  643. X    begin
  644. X      screen[y-1,x]:=n;
  645. X      screen[y,x+1]:=n;
  646. X      screen[y+1,x+1]:=n;
  647. X    end
  648. X    else
  649. X    if (position = 2) or (position = 4) then
  650. X    begin
  651. X      screen[y,x+1]:=n;
  652. X      screen[y+1,x]:=n;
  653. X      screen[y+1,x-1]:=n;
  654. X    end;
  655. X  end
  656. X  else
  657. X  if shape = 7 then
  658. X  begin
  659. X    if (position = 1) or (position = 3) then
  660. X    begin
  661. X      screen[y-1,x]:=n;
  662. X      screen[y+1,x]:=n;
  663. X      screen[y+2,x]:=n;
  664. X    end
  665. X    else
  666. X    if (position = 2) or (position = 4) then
  667. X    begin
  668. X      screen[y,x-2]:=n;
  669. X      screen[y,x-1]:=n;
  670. X      screen[y,x+1]:=n;
  671. X    end;
  672. X  end;
  673. Xend;
  674. X{****************************************************************************}
  675. X
  676. X
  677. X{***********************************************************************}
  678. Xprocedure Check(shape,position,y,x:integer; var change:boolean);
  679. X
  680. Xbegin
  681. X  change:=true;
  682. X  if shape = 2 then
  683. X  begin
  684. X    if position = 1 then
  685. X    begin
  686. X      if screen[y-1,x]=1 then change:= false
  687. X    else
  688. X      if screen[y+1,x]=1 then change:= false
  689. X    else
  690. X      if screen[y+1,x+1]=1 then change:= false;
  691. X    end
  692. X    else
  693. X    if position = 2 then
  694. X    begin
  695. X      if screen[y,x+1]=1 then change:= false else
  696. X      if screen[y,x-1]=1 then change:= false else
  697. X      if screen[y+1,x-1]=1 then change:= false;
  698. X    end
  699. X    else
  700. X    if position = 3 then
  701. X    begin
  702. X      if screen[y+1,x]=1 then change:= false else
  703. X      if screen[y-1,x]=1 then change:= false else
  704. X      if screen[y-1,x-1]=1 then change:= false;
  705. X    end
  706. X    else
  707. X    if position = 4 then
  708. X    begin
  709. X      if screen[y,x-1]=1 then change:= false else
  710. X      if screen[y,x+1]=1 then change:= false else
  711. X      if screen[y-1,x+1]=1 then change:= false;
  712. X    end;
  713. X  end
  714. X  else
  715. X  if shape = 3 then
  716. X  begin
  717. X    if position = 1 then
  718. X    begin
  719. X      if screen[y-1,x]=1 then change:= false else
  720. X      if screen[y+1,x]=1 then change:= false else
  721. X      if screen[y+1,x-1]=1 then change:= false;
  722. X    end
  723. X    else
  724. X    if position = 2 then
  725. X    begin
  726. X      if screen[y,x+1]=1 then change:= false else
  727. X      if screen[y,x-1]=1 then change:= false else
  728. X      if screen[y-1,x-1]=1 then change:= false;
  729. X    end
  730. X    else
  731. X    if position = 3 then
  732. X    begin
  733. X      if screen[y-1,x]=1 then change:= false else
  734. X      if screen[y+1,x]=1 then change:= false else
  735. X      if screen[y-1,x+1]=1 then change:= false;
  736. X    end
  737. X    else
  738. X    if position = 4 then
  739. X    begin
  740. X      if screen[y,x-1]=1 then change:= false else
  741. X      if screen[y,x+1]=1 then change:= false else
  742. X      if screen[y+1,x+1]=1 then change:= false;
  743. X    end;
  744. X  end
  745. X  else
  746. X  if shape = 4 then
  747. X  begin
  748. X    if position = 1 then
  749. X    begin
  750. X      if screen[y-1,x]=1 then change:= false else
  751. X      if screen[y+1,x]=1 then change:= false else
  752. X      if screen[y,x+1]=1 then change:= false;
  753. X    end
  754. X    else
  755. X    if position = 2 then
  756. X    begin
  757. X      if screen[y+1,x]=1 then change:= false else
  758. X      if screen[y,x-1]=1 then change:= false else
  759. X      if screen[y,x+1]=1 then change:= false;
  760. X    end
  761. X    else
  762. X    if position = 3 then
  763. X    begin
  764. X      if screen[y-1,x]=1 then change:= false else
  765. X      if screen[y+1,x]=1 then change:= false else
  766. X      if screen[y,x-1]=1 then change:= false;
  767. X    end
  768. X    else
  769. X    if position = 4 then
  770. X    begin
  771. X      if screen[y-1,x]=1 then change:= false else
  772. X      if screen[y,x-1]=1 then change:= false else
  773. X      if screen[y,x+1]=1 then change:= false;
  774. X    end;
  775. X  end
  776. X  else
  777. X  if shape = 5 then
  778. X  begin
  779. X    if (position = 1) or (position = 3) then
  780. X    begin
  781. X      if screen[y+1,x]=1 then change:= false else
  782. X      if screen[y,x+1]=1 then change:= false else
  783. X      if screen[y-1,x+1]=1 then change:= false;
  784. X    end
  785. X    else
  786. X    if (position = 2) or (position = 4) then
  787. X    begin
  788. X      if screen[y,x-1]=1 then change:= false else
  789. X      if screen[y+1,x]=1 then change:= false else
  790. X      if screen[y+1,x+1]=1 then change:= false;
  791. X    end;
  792. X  end
  793. X  else
  794. X  if shape = 6 then
  795. X  begin
  796. X    if (position = 1) or (position = 3) then
  797. X    begin
  798. X      if screen[y-1,x]=1 then change:= false else
  799. X      if screen[y,x+1]=1 then change:= false else
  800. X      if screen[y+1,x+1]=1 then change:= false;
  801. X    end
  802. X    else
  803. X    if (position = 2) or (position = 4) then
  804. X    begin
  805. X      if screen[y,x+1]=1 then change:= false else
  806. X      if screen[y+1,x]=1 then change:= false else
  807. X      if screen[y+1,x-1]=1 then change:= false;
  808. X    end;
  809. X  end
  810. X  else
  811. X  if shape = 7 then
  812. X  begin
  813. X    if (position = 1) or (position = 3) then
  814. X    begin
  815. X      if screen[y-1,x]=1 then change:= false else
  816. X      if screen[y+1,x]=1 then change:= false else
  817. X      if screen[y+2,x]=1 then change:= false;
  818. X    end
  819. X    else
  820. X    if (position = 2) or (position = 4) then
  821. X    begin
  822. X      if screen[y,x-2]=1 then change:= false else
  823. X      if screen[y,x-1]=1 then change:= false else
  824. X      if screen[y,x+1]=1 then change:= false;
  825. X    end;
  826. X  end;
  827. Xend;
  828. X{****************************************************************************}
  829. X
  830. X
  831. X{****************************************************************************}
  832. Xprocedure Create(var shape,position,y,x:integer);
  833. X
  834. Xvar
  835. X  shapenum:integer;
  836. X
  837. Xbegin
  838. X  shapenum:=random(1,23);
  839. X  if shapenum < 4 then shape:=1
  840. X  else
  841. X  if shapenum < 7 then shape:=2
  842. X  else
  843. X  if shapenum < 11 then shape:=3
  844. X  else
  845. X  if shapenum < 14 then shape:=4
  846. X  else
  847. X  if shapenum < 17 then shape:=5
  848. X  else
  849. X  if shapenum < 20 then shape:=6
  850. X  else 
  851. X  if shapenum < 23 then shape:=7
  852. X  else
  853. X  shape:=8;
  854. X  position:=1;
  855. X  y:=2;
  856. X  x:=5;
  857. Xend;
  858. X{**************************************************************************}
  859. X
  860. X
  861. X{***********************************************}
  862. Xprocedure PrintLines(screen:screenarray; b:integer);
  863. X
  864. Xvar
  865. X  a,
  866. X  c:integer;
  867. X  noline:boolean;
  868. X
  869. Xbegin
  870. X  a:=b;
  871. X  repeat
  872. X    noline:=true;
  873. X    for c:=1 to 10 do
  874. X    begin
  875. X      if screen[a,c] = 1 then noline:=false;
  876. X      intochar(xchrhigh,xchrlow,ychrhigh,ychrlow,c+30,a);
  877. X      if screen[a,c] = 1 then
  878. X        writeln(chr(27),'[',ychrhigh,ychrlow,';',xchrhigh,xchrlow,'H#');
  879. X      if screen[a,c] = 0 then
  880. X        writeln(chr(27),'[',ychrhigh,ychrlow,';',xchrhigh,xchrlow,'H ');
  881. X    end;
  882. X    a:=a-1;
  883. X  until (noline) or (a = 1);
  884. Xend;
  885. X{************************************************}
  886. X{******************************************************}
  887. Xprocedure LineDelete(var screen:screenarray; b:integer; var score:integer;
  888. X                         level:integer; var lines:integer);
  889. X
  890. Xvar
  891. X  a,
  892. X  c:integer;
  893. X
  894. Xbegin
  895. X  for a:= b downto 2 do
  896. X    for c:=1 to 10 do
  897. X      screen[a,c]:=screen[a-1,c];
  898. X  printlines(screen,b);
  899. X  if not(flag) then
  900. X    score:=score+(150*level)
  901. X  else
  902. X    score:=score+(100*level);
  903. X  lines:=lines+1;
  904. X  writeln(chr(27),'[14;7H',((5*level)-lines):2);
  905. X  writeln(chr(27),'[10;7H',score:1);
  906. Xend;
  907. X{***************************************************}
  908. X{****************************************************************************}
  909. Xprocedure LineStuff(var screen:screenarray; var lines:integer;
  910. X                    level:integer; var score:integer);
  911. X
  912. Xvar
  913. X  A,
  914. X  B:integer;
  915. X  line,
  916. X  nothing:boolean;
  917. X  linenum:integer;
  918. X  bounty:integer;
  919. X
  920. Xbegin
  921. X  linenum:=lines;
  922. X  b:=22;
  923. X  bounty:=0;
  924. X  repeat
  925. X    line:=true;
  926. X    for a:=1 to 10 do
  927. X      if screen[b,a]=0 then line:=false;
  928. X    nothing:=true;
  929. X    for a:=1 to 10 do
  930. X      if screen[b,a]=1 then nothing:=false;
  931. X    if line then
  932. X    begin
  933. X      LineDelete(screen,b,score,level,lines);
  934. X      b:=b+1;
  935. X    end;
  936. X    b:=b-1;
  937. X  until (nothing = true) or (b = 0);
  938. X  linenum:=lines-linenum;
  939. X  if linenum > 1 then  bounty:=((linenum-1) * 200 * level);
  940. X  score:=score+bounty;
  941. X  writeln(chr(27),'[10;7H',score:1);
  942. Xend;
  943. X{**********************************************************************}
  944. X
  945. X
  946. X{**********************************************************************}
  947. Xprocedure bonus(var score:integer; screen:screenarray; level:integer);
  948. X
  949. Xvar
  950. X  a,
  951. X  b:integer;
  952. X  noline:boolean;
  953. X
  954. X
  955. Xbegin
  956. X  a:=22;
  957. X  b:=1;
  958. X  repeat
  959. X    noline:=true;
  960. X    for b:=1 to 10 do
  961. X      if screen[a,b] = 1 then noline:=false;
  962. X    a:=a-1;
  963. X  until (a = 0) or (noline = true);
  964. X
  965. X  if noline then
  966. X    score:=score+(100*a*level);
  967. Xend;
  968. X{******************************************************************}
  969. X
  970. X{*************************************}
  971. Xprocedure Printshape(screen:screenarray; y,x:integer);
  972. X
  973. Xvar
  974. X  a,
  975. X  b,
  976. X  i,
  977. X  j:integer;
  978. X  stuff:packed array[1..10] of char;
  979. X
  980. Xbegin
  981. X  if flag2 = TRUE then
  982. X  begin
  983. X    waitx(factor);
  984. X  end;
  985. X  for a:= y-2 to y+3 do
  986. X    begin
  987. X      if (a < 23) and (a > 1) then
  988. X      begin
  989. X        intochar(xchrhigh,xchrlow,ychrhigh,ychrlow,31,a);     
  990. X        for b:=1 to 10 do
  991. X        begin
  992. X          if screen[a,b] = 1 then stuff[b]:='#'
  993. X          else
  994. X          if screen[a,b] = 2 then stuff[b]:='@'
  995. X          else
  996. X            stuff[b]:=' '; 
  997. X        end;
  998. X        writeln(chr(27),'[',ychrhigh,ychrlow,';31H',stuff)
  999. X       end;
  1000. X    end;
  1001. Xend;
  1002. X{*************************************}
  1003. X
  1004. X{**********************************************************************}
  1005. Xprocedure printnext(shape:integer);
  1006. X
  1007. Xbegin
  1008. X  writeln(chr(27),'[07;50H  ');
  1009. X  writeln(chr(27),'[08;50H  ');
  1010. X  if shape = 1 then
  1011. X  begin
  1012. X    writeln(chr(27),'[05;50H@@');
  1013. X    writeln(chr(27),'[06;50H@@');
  1014. X  end
  1015. X  else
  1016. X  if shape = 2 then
  1017. X  begin
  1018. X    writeln(chr(27),'[05;50H@ ');
  1019. X    writeln(chr(27),'[06;50H@ ');
  1020. X    writeln(chr(27),'[07;50H@@');
  1021. X  end
  1022. X  else
  1023. X  if shape = 3 then
  1024. X  begin
  1025. X    writeln(chr(27),'[05;50H @');
  1026. X    writeln(chr(27),'[06;50H @');
  1027. X    writeln(chr(27),'[07;50H@@');
  1028. X  end
  1029. X  else
  1030. X  if shape = 4 then
  1031. X  begin
  1032. X    writeln(chr(27),'[05;50H@ ');
  1033. X    writeln(chr(27),'[06;50H@@');
  1034. X    writeln(chr(27),'[07;50H@ ');
  1035. X  end
  1036. X  else
  1037. X  if shape = 5 then
  1038. X  begin
  1039. X    writeln(chr(27),'[05;50H @');
  1040. X    writeln(chr(27),'[06;50H@@');
  1041. X    writeln(chr(27),'[07;50H@ ');
  1042. X  end
  1043. X  else
  1044. X  if shape = 6 then
  1045. X  begin
  1046. X    writeln(chr(27),'[05;50H@ ');
  1047. X    writeln(chr(27),'[06;50H@@');
  1048. X    writeln(chr(27),'[07;50H @');
  1049. X  end
  1050. X  else
  1051. X  if shape = 7 then
  1052. X  begin
  1053. X    writeln(chr(27),'[05;50H@ ');
  1054. X    writeln(chr(27),'[06;50H@ ');
  1055. X    writeln(chr(27),'[07;50H@ ');
  1056. X    writeln(chr(27),'[08;50H@ ');
  1057. X  end;
  1058. Xend;
  1059. X{**********************************************************************}
  1060. X
  1061. X
  1062. X{**********************************************************************}
  1063. Vprocedure Rotation(var screen:screenarray; shape:integer; var position:integer
  1064. X;
  1065. X                       rotint:integer;  var y,x:integer);
  1066. X
  1067. Xvar
  1068. X  newposition:integer;
  1069. X  ax:integer;
  1070. X  change:boolean;
  1071. X
  1072. Xbegin
  1073. X  if shape = 7 then
  1074. X  begin
  1075. X    ax:=x;
  1076. X    if x = 10 then ax:=9;
  1077. X    if x = 1 then ax:=3;
  1078. X    if x = 2 then ax:=3;
  1079. X  end
  1080. X  else
  1081. X    if x =1 then ax:=2
  1082. X  else
  1083. X    if x =10 then ax:=9
  1084. X  else
  1085. X    ax:=x;
  1086. X
  1087. X
  1088. X  if rotint = -1 then
  1089. X  begin
  1090. X    if position = 1 then newposition:=4
  1091. X    else
  1092. X      newposition:=position -1;
  1093. X  end
  1094. X  else
  1095. X  if rotint = 1 then
  1096. X  begin
  1097. X    if position = 4 then newposition:=1
  1098. X    else
  1099. X      newposition:=position +1;
  1100. X  end;
  1101. X
  1102. X
  1103. X  check(shape,newposition,y,ax,change);
  1104. X  if change = true then
  1105. X  begin
  1106. X    shapestuff(shape,position,y,x,screen,0);
  1107. X    position:=newposition;
  1108. X    x:=ax;
  1109. X    shapestuff(shape,position,y,x,screen,2);
  1110. X    printshape(screen,y,x);
  1111. X  end;
  1112. Xend;
  1113. V{*****************************************************************************
  1114. X}
  1115. X
  1116. X
  1117. V{*****************************************************************************
  1118. X}
  1119. Xprocedure Movement(var screen:screenarray; shape,position:integer;
  1120. X                   var y,x:integer; d:integer);
  1121. X
  1122. X
  1123. Xvar
  1124. X  move:boolean;
  1125. X  a,
  1126. X  b:integer;
  1127. Xbegin
  1128. X  move:=true;
  1129. X  if d = 1 then
  1130. X  begin
  1131. X    for a:= x+2 downto x-2 do
  1132. X      for b:=y+2 downto y-1 do
  1133. X        if (a >1) and (a<11) and (b > 1) and (b < 23) then
  1134. X        begin
  1135. X          if (a = 10) and (screen[b,a] = 2) then move:=false;
  1136. X          if (screen[b,a] = 1) and (screen[b,a-1] = 2) then move:=false;
  1137. X        end; 
  1138. X  end
  1139. X  else
  1140. X  if d = -1 then
  1141. X  begin
  1142. X    for a:=x-3 to x+1 do
  1143. X      for b:=y-1 to y+2 do
  1144. X        if (a >0) and (a<9) and (b>1) and (b<23) then
  1145. X        begin
  1146. X          if (a = 1) and (screen[b,a] = 2) then move:=false;
  1147. X          if (screen[b,a] = 1) and (screen[b,a+1] = 2) then move:=false;
  1148. X        end;
  1149. X  end; 
  1150. X  if move = true then
  1151. X  begin
  1152. X    shapestuff(shape,position,y,x,screen,0);
  1153. X    x:=x+d;
  1154. X    shapestuff(shape,position,y,x,screen,2);
  1155. X    printshape(screen,y,x);
  1156. X  end;
  1157. Xend;
  1158. X{************************************************************************}
  1159. V{*****************************************************************************
  1160. X}
  1161. Vprocedure Down(var screen:screenarray; shape,position:integer; var y,x:integer
  1162. X;
  1163. X               var fast:boolean);
  1164. X
  1165. X
  1166. Xvar
  1167. X  move:boolean;
  1168. X  a,
  1169. X  b:integer;
  1170. X
  1171. Xbegin
  1172. X  move:=true;
  1173. X  for b:=y+3 downto y-1 do
  1174. X    for a:= x+2 downto x-2 do
  1175. X      if (a >0) and (a<11) and (b > 1) and (b < 23) then
  1176. X      begin
  1177. X        if (b = 22) and (screen[b,a] = 2) then move:=false;
  1178. X        if (screen[b,a] = 1) and (screen[b-1,a] = 2) then move:=false;
  1179. X      end; 
  1180. X  if move = true then
  1181. X  begin
  1182. X    if fast = true then
  1183. X    begin
  1184. X      y:=y+1;
  1185. X      shapestuff(shape,position,y-1,x,screen,0);
  1186. X      printshape(screen,y,x);
  1187. X      shapestuff(shape,position,y,x,screen,2);
  1188. X      repeat
  1189. X        move:=true;
  1190. X        for b:=y+3 downto y-1 do
  1191. X          for a:= x+2 downto x-2 do
  1192. X            if (a >0) and (a<11) and (b > 1) and (b < 23) then
  1193. X            begin
  1194. X              if (b = 22) and (screen[b,a] = 2) then move:=false;
  1195. X              if (screen[b,a] = 1) and (screen[b-1,a] = 2 ) then move:=false;
  1196. X            end;
  1197. X         if move = true then
  1198. X         begin
  1199. X           y:=y+1;
  1200. X           shapestuff(shape,position,y-1,x,screen,0);
  1201. X           shapestuff(shape,position,y,x,screen,2);
  1202. X         end;
  1203. X       until move=false;
  1204. X       printshape(screen,y,x);
  1205. X    end
  1206. X    else
  1207. X    begin
  1208. X      y:=y+1;
  1209. X      screen[y-1,x]:=0;
  1210. X      screen[y,x]:=2;
  1211. X      shapestuff(shape,position,y-1,x,screen,0);
  1212. X      shapestuff(shape,position,y,x,screen,2);
  1213. X      printshape(screen,y,x);
  1214. X    end;
  1215. X  end;
  1216. X  fast:=false;
  1217. Xend;
  1218. X{************************************************************************}
  1219. X
  1220. Xprocedure printall(screen:screenarray; score,lines,level:integer);
  1221. X
  1222. X
  1223. Xvar
  1224. X  a,
  1225. X  b:integer;
  1226. X  g,
  1227. X  h,
  1228. X  xchrhigh,
  1229. X  xchrlow,
  1230. X  ychrhigh,
  1231. X  ychrlow:char;
  1232. X  stuff:packed array[1..10] of char;
  1233. X
  1234. Xbegin
  1235. X  
  1236. X  cls;
  1237. X  for I:=1 to 22 do
  1238. X  begin
  1239. X    intochar(g,h,ychrhigh,ychrlow,1,I);
  1240. X    writeln(chr(27),'[',ychrhigh,ychrlow,';30H|          |');
  1241. X  end;
  1242. X  writeln(chr(27),'[23;30H------------');
  1243. X  if flag then writeln(chr(27),'[03;49HNEXT');
  1244. X  writeln(chr(27),'[10;1HSCORE:',score:1);
  1245. X  writeln(chr(27),'[12;1HLEVEL:',level:1);
  1246. X  writeln(chr(27),'[14;1HLINES:',((5*level)-lines):2);
  1247. X  for a:=1 to 22 do
  1248. X  begin
  1249. X    intochar(xchrhigh,xchrlow,ychrhigh,ychrlow,31,a);
  1250. X    for b:=1 to 10 do
  1251. X    begin
  1252. X      if screen[a,b] = 1 then stuff[b]:='#'
  1253. X      else
  1254. X        stuff[b]:=' ';
  1255. X    end;
  1256. X    writeln(chr(27),'[',ychrhigh,ychrlow,';31H',stuff);
  1257. X  end;
  1258. Xend;
  1259. V{*****************************************************************************
  1260. X*}
  1261. X
  1262. V{*****************************************************************************
  1263. X*}
  1264. Xprocedure editshape(key:integer; var nshape:integer);
  1265. X
  1266. X
  1267. Xbegin
  1268. X  nshape:=key-48;
  1269. X  printnext(nshape);
  1270. Xend;
  1271. V{*****************************************************************************
  1272. X*}
  1273. X{***********************************************}
  1274. Xprocedure getyearday(inp:datestr; var year,day:integer);
  1275. X
  1276. Xvar
  1277. X  digit1,
  1278. X  digit2,
  1279. X  digit3,
  1280. X  digit4:integer;
  1281. X  offset:integer;
  1282. X
  1283. Xbegin
  1284. X  offset:= ord('1') + 1;
  1285. X  digit1:= ord(inp[8]) - offset;
  1286. X  digit2:= ord(inp[9]) - offset;
  1287. X  digit3:= ord(inp[10]) - offset;
  1288. X  digit4:= ord(inp[11]) - offset;
  1289. X  year:= digit4 + (10*digit3) + (100*digit2) + (1000*digit1);
  1290. X  digit1:= ord(inp[1]) - offset;
  1291. X  digit2:= ord(inp[2]) - offset;
  1292. X  day:= digit2 + (10*digit1);
  1293. Xend;
  1294. X{************************************************}
  1295. X
  1296. X{**********************************************}
  1297. Xprocedure getmonth(inp:datestr; var month:integer);
  1298. X
  1299. Xbegin
  1300. X  
  1301. X  if (inp[4] = 'J') and (inp[5] = 'A') then month:=1
  1302. X  else
  1303. X  if (inp[4] = 'F') then month:=2
  1304. X  else
  1305. X  if (inp[4] = 'M') and (inp[6] = 'R') then month:=3
  1306. X  else
  1307. X  if (inp[4] = 'A') and (inp[5] = 'P') then month:=4
  1308. X  else
  1309. X  if (inp[4] = 'M') and (inp[6] = 'Y') then month:=5
  1310. X  else
  1311. X  if (inp[4] = 'J') and (inp[6] = 'N') then month:=7
  1312. X  else
  1313. X  if (inp[4] = 'J') then month:=6
  1314. X  else
  1315. X  if (inp[4] = 'A') and (inp[5] = 'U') then month:=8
  1316. X  else
  1317. X  if (inp[4] = 'S') then month:=9
  1318. X  else
  1319. X  if (inp[4] = 'O') then month:=10
  1320. X  else
  1321. X  if (inp[4] = 'N') then month:=11
  1322. X  else
  1323. X  if (inp[4] = 'D') then month:=12;
  1324. Xend;
  1325. X
  1326. V{*****************************************************************************
  1327. X*}
  1328. V{*****************************************************************************
  1329. X*}
  1330. Xfunction older(one,two:datestr):boolean;
  1331. X
  1332. X
  1333. Xvar
  1334. X  oneyear,
  1335. X  twoyear,
  1336. X  onemonth,
  1337. X  twomonth,
  1338. X  oneday,
  1339. X  twoday:integer;
  1340. X
  1341. Xbegin
  1342. X  getyearday(one,oneyear,oneday);
  1343. X  getyearday(two,twoyear,twoday);
  1344. X  getmonth(one,onemonth);
  1345. X  getmonth(two,twomonth);
  1346. X  if oneyear < twoyear then older:=true
  1347. X  else
  1348. X    if onemonth < twomonth then older:=true
  1349. X    else
  1350. X      if oneday < twoday then older:=true
  1351. X      else
  1352. X        older:=false;
  1353. Xend;
  1354. V{*****************************************************************************
  1355. X*}
  1356. V{*****************************************************************************
  1357. X*}
  1358. X
  1359. X
  1360. V{*****************************************************************************
  1361. X*}
  1362. V{*****************************************************************************
  1363. X*}
  1364. XProcedure MainGame(left,right,rotleft,rotright,speed,quitkey,redraw:char;
  1365. X                   level:integer; cheat:boolean);
  1366. X
  1367. Xvar
  1368. X  oldest:integer;
  1369. X  saved,
  1370. X  saving:saverec;
  1371. X  count:integer;
  1372. X  quit:boolean;
  1373. X  a,b:integer;
  1374. X  height:integer;
  1375. X  choice:char;
  1376. X  nx,
  1377. X  ny,
  1378. X  nshape,
  1379. X  nposition:integer;
  1380. X  fast:boolean;
  1381. X  gotin:boolean;
  1382. X
  1383. Xbegin
  1384. X
  1385. Xrandomise;
  1386. Xif restored = false then
  1387. Xbegin
  1388. X  for a:=1 to 22 do
  1389. X    for b:=1 to 10 do
  1390. X      screen[a,b]:=0;
  1391. X  score:=0;
  1392. X  position:=1;
  1393. X  create(shape,position,y,x);
  1394. X  lines:=0;
  1395. X  shapestuff(shape,position,y,x,screen,2);
  1396. Xend;
  1397. Xcreate(nshape,nposition,ny,nx);
  1398. Xcount:=0;
  1399. Xfast:=false;
  1400. Xquit:=false;
  1401. Xott:=false;
  1402. Xcls;
  1403. X
  1404. Xprintshape(screen,y,x);
  1405. Xprintall(screen,score,lines,level);
  1406. Xif restored then 
  1407. X  writeln(chr(27),'[10;49HPress any key to continue game')
  1408. Xelse
  1409. X  writeln(chr(27),'[10;49HPress any key to play game');
  1410. Xwaitkey(key,chan);
  1411. Xwriteln(chr(27),'[10;49H                                ');
  1412. Xrestored:=false;
  1413. Xif flag then printnext(nshape);
  1414. Xrepeat
  1415. X  readkey(key,chan);
  1416. X  choice:=chr(key);
  1417. X  if choice = left then Movement(screen,shape,position,y,x,-1)
  1418. X  else
  1419. X  if choice = right then movement(screen,shape,position,y,x,1)
  1420. X  else
  1421. X  if choice = rotleft then Rotation(screen,shape,position,-1,y,x)
  1422. X  else
  1423. X  if choice = rotright then Rotation(screen,shape,position,1,y,x)
  1424. X  else
  1425. X  if choice = speed then fast:=true
  1426. X  else
  1427. X  if  (choice in ['1'..'7']) and (cheat = true) then editshape(key,nshape)
  1428. X  else
  1429. X  if choice = redraw then
  1430. X  begin
  1431. X    printall(screen,score,lines,level);
  1432. X    if flag then printnext(nshape);
  1433. X  end
  1434. X  else
  1435. X    if choice = quitkey then ott:=true
  1436. X  else
  1437. X    if choice = '!' then 
  1438. X    begin
  1439. X      cls;
  1440. X      writeln('%DCL-I-SPAWN, Type eoj to return to Shapes');
  1441. X      spawn;
  1442. X      printall(screen,score,lines,level);
  1443. X      if flag then printnext(nshape);
  1444. X      writeln(chr(27),'[10;49HPress any key to continue Shapes');
  1445. X      waitkey(key,chan);
  1446. X      writeln(chr(27),'[10;49H                                ');
  1447. X    end
  1448. X  else
  1449. X    if choice = '@' then
  1450. X    begin
  1451. X      cls;
  1452. X      Writeln(                      'Save game option');
  1453. X      usernum(userid);
  1454. X      if (userid = 'CADP02  ') or
  1455. X         (userid = 'CADP03  ') then 
  1456. X      begin 
  1457. X        write('Enter username, MAX 8 letters, RETURN for default: ');
  1458. X        userid:='        ';
  1459. X        readln(userid);
  1460. X        if userid[1] = ' ' then usernum(userid);
  1461. X      end;
  1462. X      saving.num:=score;
  1463. X      saving.level:=level;
  1464. X      saving.outp:=screen;
  1465. X      saving.lines:=lines;
  1466. X      saving.x:=x;
  1467. X      saving.y:=y;
  1468. X      saving.shape:=shape;
  1469. X      saving.position:=position;
  1470. X      saving.user:=userid;
  1471. X      DATE(saving.current);
  1472. X      open(Save,Savefile,history:=readonly);
  1473. X      reset(save);
  1474. X      del:=false;
  1475. X      for I:=1 to 100 do
  1476. X      begin
  1477. X        read(save,peeps[I]);
  1478. X        if (del = true) and (peeps[I].user = saving.user) then
  1479. X          peeps[I].user:='UNUSED  ';
  1480. X        if (del = false) and (peeps[I].user = 'UNUSED  ') then
  1481. X        begin
  1482. X          peeps[I]:=saving;
  1483. X          del:=true;
  1484. X        end;
  1485. X        if (del = false) and (peeps[I].user = saving.user) then
  1486. X        begin
  1487. X          del:=true;
  1488. X          peeps[I]:=saving;
  1489. X        end;
  1490. X      end;
  1491. X      if del = false then
  1492. X      begin
  1493. X        reset(save);
  1494. X        read(save,peeps[1]);
  1495. X        oldest:=1;
  1496. X        for I:=2 to 100 do
  1497. X        begin
  1498. X          read(save,peeps[I]);
  1499. X          if older(peeps[I-1].current,peeps[I].current) = false then 
  1500. X            oldest:=I;
  1501. X        end;
  1502. X        peeps[oldest]:=saving;
  1503. X      end;
  1504. X      close(save);
  1505. X      open(Save,Savefile,history:=old);
  1506. X      rewrite(save);
  1507. X      for I:=1 to 100 do
  1508. X        write(save,peeps[I]);
  1509. X      close(save);
  1510. X      ott:=true;
  1511. X      del:=false;
  1512. X      writeln('Game saved.');
  1513. X      writeln('Press any key for main menu.');
  1514. X      waitkey(key,chan);
  1515. X    end;
  1516. X  if count = 3 then
  1517. X  begin
  1518. X    height:=y;
  1519. X    Down(screen,shape,position,y,x,fast);
  1520. X    if height = y then
  1521. X    begin
  1522. X      for a:=1 to 10 do
  1523. X        if screen[1,a]=2 then ott:=true;
  1524. X      shapestuff(shape,position,y,x,screen,1);
  1525. X      printshape(screen,y,x);
  1526. X      linestuff(screen,lines,level,score);
  1527. X      shape:=Nshape;
  1528. X      position:=Nposition;
  1529. X      y:=Ny;
  1530. X      x:=Nx;
  1531. X      create(nshape,nposition,ny,nx);
  1532. X      if flag then printnext(nshape);
  1533. X      shapestuff(shape,position,y,x,screen,2);
  1534. X      if lines >= 5*level then
  1535. X      begin
  1536. X        level:=level+1;
  1537. X        bonus(score,screen,level);
  1538. X        lines:=0;
  1539. X        printall(screen,score,lines,level);
  1540. X        if flag then printnext(nshape);
  1541. X      end;
  1542. X    end;
  1543. X    count:=0;
  1544. X  end;
  1545. X  count:=count+1;
  1546. Xuntil OTT = true;
  1547. X
  1548. Xif choice <> '@' then
  1549. Xbegin
  1550. X  highscores(score,level,Htable,scores,gotin);
  1551. X  if gotin then viewscores(Htable,scores,key,chan)
  1552. Xend
  1553. Xend;
  1554. V{*****************************************************************************
  1555. X*}
  1556. V{*****************************************************************************
  1557. X*}
  1558. X
  1559. V{*****************************************************************************
  1560. X*}
  1561. V{*****************************************************************************
  1562. X*}
  1563. XProcedure RESTORE;
  1564. X
  1565. Xvar
  1566. X  I:integer;
  1567. X
  1568. Xbegin
  1569. X  cls;
  1570. X  writeln('                    Restore saved game option');
  1571. X  usernum(userid);
  1572. X  if (userid = 'CADP02  ') or
  1573. X     (userid = 'CADP03  ') then 
  1574. X  begin
  1575. X    write('Enter username, MAX 8 letters, RETURN for default: ');
  1576. X    userid:='        ';
  1577. X    readln(userid);
  1578. X    if userid[1] = ' ' then usernum(userid);
  1579. X  end;
  1580. X  restored:=false;
  1581. X  open(Save,Savefile,history:=readonly);
  1582. X  reset(save);
  1583. X  for I:=1 to 100 do
  1584. X  begin
  1585. X    read(save,peeps[I]);
  1586. X    if peeps[I].user = userid then
  1587. X    begin
  1588. X      cls;
  1589. X      writeln('Restoring...');
  1590. X      lines:=peeps[I].lines;
  1591. X      position:=peeps[I].position;
  1592. X      x:=peeps[I].x;
  1593. X      y:=peeps[I].y;
  1594. X      shape:=peeps[I].shape;
  1595. X      screen:=peeps[I].outp;
  1596. X      score:=peeps[I].num;
  1597. X      level:=peeps[I].level;
  1598. X      peeps[I].user:='UNUSED  ';
  1599. X      restored:=true;
  1600. X    end;
  1601. X  end;
  1602. X  close(save);
  1603. X  open(save,savefile,history:=old);
  1604. X  rewrite(save);
  1605. X  for I:=1 to 100 do
  1606. X    write(save,peeps[I]);
  1607. X  close(save);
  1608. X  if restored = true then
  1609. X  begin
  1610. X    writeln('Restored.');
  1611. X    writeln('Press any key for main screen');
  1612. X    waitkey(key,chan);
  1613. X    MAINGAME(left,right,rotleft,rotright,speed,quitkey,redraw,level,cheat);
  1614. X  end
  1615. X  else
  1616. X  begin
  1617. X    writeln('Data file not found.');
  1618. X    writeln('Press any key to return to main menu.');
  1619. X    waitkey(key,chan);
  1620. X  end;
  1621. Xend;
  1622. X
  1623. V{*****************************************************************************
  1624. X*}
  1625. V{*****************************************************************************
  1626. X*}
  1627. X
  1628. X{*******************************************************************}
  1629. Xbegin {SHAPES}
  1630. X  cls;
  1631. X  MAKECHAN(chan);
  1632. X  HP := FALSE;
  1633. X  flag:=true;
  1634. X  flag2:=false;
  1635. X  cheat:=false;
  1636. X  left:='z';right:='x';rotleft:='o';rotright:='p';speed:='[';quitkey:='q';
  1637. X  factor:=0.15;
  1638. X  redraw:='r';
  1639. X  levelmin:=1;
  1640. X  for I:=1 to 22 do
  1641. X    begin {for}
  1642. X    for J:=1 to 10 do
  1643. X      screen[I,J]:=0;
  1644. X    end; {for}
  1645. X  repeat
  1646. X    MENUPRINT;
  1647. X    repeat
  1648. X      if chr(key) = 'c' then flagA:=true;
  1649. X      if chr(key) = 'a' then
  1650. X      begin
  1651. X        if flagA = true then flagB:=true
  1652. X        else flagB:=false;
  1653. X      end;
  1654. X      if chr(key) = 'd' then
  1655. X      begin
  1656. X        if flagB = true then flagC:=true
  1657. X        else flagC:=false;
  1658. X      end;
  1659. X      if chr(key) = 'p' then
  1660. X      begin
  1661. X        if flagC = true then flagD:=true
  1662. X        else flagD:=false;
  1663. X      end;
  1664. X      if (chr(key) <> 'c') and (chr(key) <> 'a') and
  1665. X         (chr(key) <> 'd') and (chr(key) <> 'p') then
  1666. X      begin
  1667. X        flagA:=false;
  1668. X        flagB:=false;
  1669. X        flagC:=false;
  1670. X        flagD:=false;
  1671. X      end;
  1672. X      waitkey(key,chan);
  1673. X    until chr(key) in ['0'..'8']; 
  1674. X    level:=levelmin;
  1675. X    if chr(key) <> '8' then flagD:=false;
  1676. X    if chr(key)='1' then
  1677. X      MAINGAME(left,right,rotleft,rotright,speed,quitkey,redraw,level,cheat);
  1678. V    if chr(key)='2' then KEYDEFINE(left,right,rotleft,rotright,speed,quitkey,r
  1679. Xedraw);
  1680. X    if chr(key)='3' then VIEWSCORES(Htable,scores,key,chan);
  1681. X    if chr(key)='4' then INSTRUCTIONS;
  1682. X    if chr(key)='5' then flag:=not(flag);
  1683. X    if chr(key)='6' then flag2:=not(flag2);
  1684. X    if chr(key)='7' then RESTORE;
  1685. X    if flagD then
  1686. X    begin
  1687. X      cheat:=true;
  1688. X      write('level??: ');
  1689. X      readln(levelmin);
  1690. X      write('reset savefile??: ');
  1691. X      readln(answer);
  1692. X      if (answer = 'y') or (answer = 'Y') then
  1693. X      begin
  1694. X        blank.user:='UNUSED  ';
  1695. X        open(Save,Savefile,history:=unknown);
  1696. X        rewrite(save);
  1697. X        for I:=1 to 100 do
  1698. X          write(save,blank);
  1699. X        close(save);
  1700. X      end;
  1701. X      write('reset scoreboard??: ');
  1702. X      readln(answer);
  1703. X      if (answer='y') or (answer ='Y') then
  1704. X      begin
  1705. X        open (Htable , Htablefile ,
  1706. X`009  history := unknown);
  1707. X        rewrite(Htable);
  1708. X        for A:= 1 to 10 do
  1709. X        begin
  1710. X          scores[A].num:=0;
  1711. X          scores[A].name:='                                        ';
  1712. X          scores[A].level:=1;
  1713. X          scores[A].id:='        ';
  1714. X        end;
  1715. X        for A:=1 to 10 do
  1716. X          write(Htable,scores[A]);
  1717. X        close(Htable);
  1718. X      end;
  1719. X    end;
  1720. X  until (chr(key)='0');
  1721. X  cls;
  1722. X    writeln('There now, that didn''t hurt much did it??');
  1723. X    writeln('Byeeeeeeeeee........');
  1724. Xend. {SHAPES}
  1725. X{*******************************************************************}
  1726. X
  1727. $GoSub Convert_File
  1728. $Exit
  1729.