home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1994 March / Source_Code_CD-ROM_Walnut_Creek_March_1994.iso / compsrcs / games / vmsnet / tetris / part01 < prev    next >
Encoding:
Internet Message Format  |  1992-07-01  |  28.8 KB
  1. Path: uunet!caen!kuhub.cc.ukans.edu!nrlvx1.nrl.navy.mil!koffley
  2. Newsgroups: vmsnet.sources.games
  3. Subject: TETRIS_VMS.01_OF_05
  4. Message-ID: <1992Jul2.123807.742@nrlvx1.nrl.navy.mil>
  5. From: koffley@nrlvx1.nrl.navy.mil
  6. Date: 2 Jul 92 12:38:07 -0400
  7. Organization: NRL SPACE SYSTEMS DIVISION
  8. Lines: 919
  9.  
  10. $! ------------------ CUT HERE -----------------------
  11. $ v='f$verify(f$trnlnm("SHARE_VERIFY"))'
  12. $!
  13. $! This archive created by VMS_SHARE Version 7.2-007  22-FEB-1990
  14. $!   On  2-JUL-1992 12:35:38.39   By user KOFFLEY 
  15. $!
  16. $! This VMS_SHARE Written by:
  17. $!    Andy Harper, Kings College London UK
  18. $!
  19. $! Acknowledgements to:
  20. $!    James Gray       - Original VMS_SHARE
  21. $!    Michael Bednarek - Original Concept and implementation
  22. $!
  23. $!+ THIS PACKAGE DISTRIBUTED IN 5 PARTS, TO KEEP EACH PART
  24. $!  BELOW 60 BLOCKS
  25. $!
  26. $! TO UNPACK THIS SHARE FILE, CONCATENATE ALL PARTS IN ORDER
  27. $! AND EXECUTE AS A COMMAND PROCEDURE  (  @name  )
  28. $!
  29. $! THE FOLLOWING FILE(S) WILL BE CREATED AFTER UNPACKING:
  30. $!       1. COMPILE.COM;2
  31. $!       2. TETRIS_BUILD.COM;1
  32. $!       3. SHAPES.PAS;2
  33. $!       4. INCLUDES.C;1
  34. $!       5. RAND.FOR;1
  35. $!       6. README.TXT;1
  36. $!       7. HTABLE.DAT;1
  37. $!
  38. $set="set"
  39. $set symbol/scope=(nolocal,noglobal)
  40. $f=f$parse("SHARE_TEMP","SYS$SCRATCH:.TMP_"+f$getjpi("","PID"))
  41. $e="write sys$error  ""%UNPACK"", "
  42. $w="write sys$output ""%UNPACK"", "
  43. $ if f$trnlnm("SHARE_LOG") then $ w = "!"
  44. $ ve=f$getsyi("version")
  45. $ if ve-f$extract(0,1,ve) .ges. "4.4" then $ goto START
  46. $ e "-E-OLDVER, Must run at least VMS 4.4"
  47. $ v=f$verify(v)
  48. $ exit 44
  49. $UNPACK: SUBROUTINE ! P1=filename, P2=checksum
  50. $ if f$search(P1) .eqs. "" then $ goto file_absent
  51. $ e "-W-EXISTS, File ''P1' exists. Skipped."
  52. $ delete 'f'*
  53. $ exit
  54. $file_absent:
  55. $ if f$parse(P1) .nes. "" then $ goto dirok
  56. $ dn=f$parse(P1,,,"DIRECTORY")
  57. $ w "-I-CREDIR, Creating directory ''dn'."
  58. $ create/dir 'dn'
  59. $ if $status then $ goto dirok
  60. $ e "-E-CREDIRFAIL, Unable to create ''dn'. File skipped."
  61. $ delete 'f'*
  62. $ exit
  63. $dirok:
  64. $ w "-I-PROCESS, Processing file ''P1'."
  65. $ if .not. f$verify() then $ define/user sys$output nl:
  66. $ EDIT/TPU/NOSEC/NODIS/COM=SYS$INPUT 'f'/OUT='P1'
  67. PROCEDURE Unpacker ON_ERROR ENDON_ERROR;SET(FACILITY_NAME,"UNPACK");SET(
  68. SUCCESS,OFF);SET(INFORMATIONAL,OFF);f:=GET_INFO(COMMAND_LINE,"file_name");b:=
  69. CREATE_BUFFER(f,f);p:=SPAN(" ")@r&LINE_END;POSITION(BEGINNING_OF(b));
  70. LOOP EXITIF SEARCH(p,FORWARD)=0;POSITION(r);ERASE(r);ENDLOOP;POSITION(
  71. BEGINNING_OF(b));g:=0;LOOP EXITIF MARK(NONE)=END_OF(b);x:=ERASE_CHARACTER(1);
  72. IF g=0 THEN IF x="X" THEN MOVE_VERTICAL(1);ENDIF;IF x="V" THEN APPEND_LINE;
  73. MOVE_HORIZONTAL(-CURRENT_OFFSET);MOVE_VERTICAL(1);ENDIF;IF x="+" THEN g:=1;
  74. ERASE_LINE;ENDIF;ELSE IF x="-" THEN IF INDEX(CURRENT_LINE,"+-+-+-+-+-+-+-+")=
  75. 1 THEN g:=0;ENDIF;ENDIF;ERASE_LINE;ENDIF;ENDLOOP;t:="0123456789ABCDEF";
  76. POSITION(BEGINNING_OF(b));LOOP r:=SEARCH("`",FORWARD);EXITIF r=0;POSITION(r);
  77. ERASE(r);x1:=INDEX(t,ERASE_CHARACTER(1))-1;x2:=INDEX(t,ERASE_CHARACTER(1))-1;
  78. COPY_TEXT(ASCII(16*x1+x2));ENDLOOP;WRITE_FILE(b,GET_INFO(COMMAND_LINE,
  79. "output_file"));ENDPROCEDURE;Unpacker;QUIT;
  80. $ delete/nolog 'f'*
  81. $ CHECKSUM 'P1'
  82. $ IF CHECKSUM$CHECKSUM .eqs. P2 THEN $ EXIT
  83. $ e "-E-CHKSMFAIL, Checksum of ''P1' failed."
  84. $ ENDSUBROUTINE
  85. $START:
  86. $ create 'f'
  87. X!This command procedure will compile and link the source files for the
  88. X!game Shapes, written and copyrighted by Colin Cowie, Glasgow, Scotland,
  89. X!with certain procedures written and copyrighted by Stephen Macdonald,
  90. X!Glasgow, Scotland.
  91. X!
  92. X!It also defines the symbol "shapes" to run the program.
  93. X!Edit the symbol definition of shapes to point to the location of shapes.exe
  94. X
  95. X$write sys$output "Compiling Shapes.."
  96. X$pascal shapes
  97. X$write sys$output "Compiling Includes.."
  98. X$cc includes
  99. X$write sys$output "Compiling Rand.."
  100. X$fortran rand
  101. X$write sys$output "Linking Shapes,Includes,Rand"
  102. X$link shapes,includes,rand
  103. X$write sys$output "Finished!!"
  104. X
  105. X!The following Line should be entered in your login.com, suitably modified
  106. X$shapes:=="$my$root:`5Brcd.tetris`5Dshapes"
  107. $ CALL UNPACK COMPILE.COM;2 1662649190
  108. $ create 'f'
  109. X$!...................... Cut on the dotted line and save ...................
  110. V...
  111. X$! VAX/VMS archive file created by VMS_SHAR V-5.04 04-Feb-1988
  112. X$! which was written by Michael Bednarek (U3369429@ucsvc.dn.mu.oz.au)
  113. X$! To unpack, simply save and execute (@) this file.
  114. X$!
  115. X$! This archive was created by CADP02
  116. X$! on Friday 7-SEP-1990 16:33:46.07
  117. X$!
  118. X$! ATTENTION: To keep each article below 15872 bytes, this program
  119. X$! has been transmitted in 2 parts.
  120. X$! You should concatenate ALL parts to ONE file and execute (@) that file.
  121. X$!
  122. X$! It contains the following 5 files:
  123. X$! COMPILE.COM INCLUDES.C RAND.FOR README.TXT SHAPES.PAS
  124. X$!==========================================================================
  125. V===
  126. X$Set Symbol/Scope=(NoLocal,NoGlobal)
  127. X$Version=F$GetSYI("VERSION")
  128. X$If Version.ges."V4.4" then goto Version_OK
  129. X$Write SYS$Output "Sorry, you are running VMS ",Version, -
  130. X", but this procedure requires V4.4 or higher."
  131. X$Exit 44
  132. X$Version_OK:CR`5B0,8`5D=13
  133. X$Pass_or_Failed="failed!,passed."
  134. X$Goto Start
  135. X$Convert_File:
  136. X$Read/Time_Out=0/Error=No_Error1/Prompt="creating ''File_is'" SYS$Command dd
  137. Vd
  138. X$No_Error1:Define/User_Mode SYS$Output NL:
  139. X$Edit/TPU/NoSection/NoDisplay/Command=SYS$Input/Output='File_is' -
  140. XVMS_SHAR_DUMMY.DUMMY
  141. Xf:=Get_Info(Command_Line,"File_Name");b:=Create_Buffer("",f);
  142. Xo:=Get_Info(Command_Line,"Output_File");Set(Output_File,b,o);
  143. XPosition(Beginning_of(b));Loop x:=Erase_Character(1);Loop ExitIf x<>"V";
  144. XMove_Vertical(1);x:=Erase_Character(1);Append_Line;
  145. XMove_Horizontal(-Current_Offset);EndLoop;Move_Vertical(1);
  146. XExitIf Mark(None)=End_of(b) EndLoop;Position(Beginning_of(b));Loop
  147. Xx:=Search("`60",Forward,Exact);ExitIf x=0;Position(x);Erase_Character(1);
  148. XIf Current_Character='`60' then Move_Horizontal(1);else
  149. XCopy_Text(ASCII(INT(Erase_Character(3))));EndIf;EndLoop;Exit;
  150. X$Delete VMS_SHAR_DUMMY.DUMMY;*
  151. X$Checksum 'File_is
  152. X$Success=F$Element(Check_Sum_is.eq.CHECKSUM$CHECKSUM,",",Pass_or_Failed)+CR
  153. X$Read/Time_Out=0/Error=No_Error2/Prompt=" CHECKSUM ''Success'" SYS$Command d
  154. Vdd
  155. X$No_Error2:Return
  156. X$Start:
  157. X$File_is="COMPILE.COM"
  158. X$Check_Sum_is=523446877
  159. X$Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
  160. XX!This command procedure will compile and link the source files for the
  161. XX!game Shapes, written and copyrighted by Colin Cowie, Glasgow, Scotland,
  162. XX!with certain procedures written and copyrighted by Stephen Macdonald,
  163. XX!Glasgow, Scotland.
  164. XX!
  165. XX!It also defines the symbol "shapes" to run the program.
  166. XX!Edit the symbol definition of shapes to point to the location of shapes.ex
  167. Ve
  168. XX
  169. XX$write sys$output "Compiling Shapes.."
  170. XX$pascal shapes
  171. XX$write sys$output "Compiling Includes.."
  172. XX$cc includes
  173. XX$write sys$output "Compiling Rand.."
  174. XX$fortran rand
  175. XX$write sys$output "Linking Shapes,Includes,Rand"
  176. XX$link shapes,includes,rand
  177. XX$write sys$output "Finished!!"
  178. XX
  179. XX!The following Line should be entered in your login.com, suitably modified
  180. XX$shapes:=="$disk18:`5Bcadp02.pascal.shapes`5Dshapes"
  181. X$GoSub Convert_File
  182. X$File_is="INCLUDES.C"
  183. X$Check_Sum_is=1613696431
  184. X$Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
  185. XV/**************************************************************************
  186. V***
  187. XX**
  188. XXCopyright 1989,1990 by Colin Cowie, Glasgow, Scotland.
  189. XX
  190. XX                        All Rights Reserved
  191. XX
  192. XXPermission to use, copy, modify, and distribute this software and its`20
  193. XXdocumentation for any purpose and without fee is hereby granted,`20
  194. XXprovided that the above copyright notice appear in all copies and that
  195. XXboth that copyright notice and this permission notice appear in
  196. XXsupporting documentation.
  197. XV***************************************************************************
  198. V***
  199. XX*/
  200. XX
  201. XX#include <string.h>
  202. XX#include <jpidef.h>
  203. XX#include <iodef.h>             `20
  204. XX#include <descrip.h>
  205. XX
  206. XXtypedef struct
  207. XX`7B
  208. XX`60009unsigned short`60009length ;
  209. XX`60009char`60009`60009dtype ;
  210. XX`60009char`60009`60009class ;
  211. XX`60009char`60009`60009*pntr ;
  212. XX`7DDESCR ;
  213. XX
  214. XX#define stdescr(name,string) name.length = strlen(string);\
  215. XX name.dtype = DSC$K_DTYPE_T; name.class = DSC$K_CLASS_S;\
  216. XX name.pntr = string ;
  217. XX
  218. XX
  219. XXvoid makechan(chan)
  220. XXint *chan;
  221. XX`7B
  222. XX  DESCR term;
  223. XX  int status;
  224. XX  stdescr(term,"TT");
  225. XX  status = sys$assign (&term,chan,0,0);
  226. XX  if (status != 1) lib$STOP(status);
  227. XX`7D
  228. XX
  229. XXvoid readkey(key,chan)
  230. XXint *chan;
  231. XXint *key;
  232. XX
  233. XX`7B
  234. XX  char inkey;                              `20
  235. XX  int status;                   `20
  236. XX  int func;
  237. XX  inkey = (char) 0;
  238. XX  func = IO$_READVBLK `7C IO$M_NOECHO `7C IO$M_TIMED;
  239. XX  status = sys$qiow(0,*chan,func,0,0,0,&inkey,1,0,0,0,0);
  240. XX  if (status != 1) lib$STOP(status);
  241. XX  *key = (int) inkey;
  242. XX`7D
  243. XX
  244. XXvoid waitkey(key,chan)
  245. XXint *chan;
  246. XXint *key;
  247. XX
  248. XX`7B
  249. XX  char inkey;                              `20
  250. XX  int status;                   `20
  251. XX  int func;
  252. XX  inkey = (char) 0;
  253. XX  func = IO$_READVBLK `7C IO$M_NOECHO `7C IO$M_PURGE;
  254. XX  status=sys$qiow(0,*chan,func,0,0,0,&inkey,1,0,0,0,0);
  255. XX  if (status != 1) lib$STOP(status);
  256. XX  *key = (int) inkey;
  257. XX`7D
  258. XX
  259. XXvoid spawn()
  260. XX`7B
  261. XX  DESCR userid;
  262. XX  stdescr(userid,"Shapes_Refugee");
  263. XX  LIB$SPAWN(0,0,0,0,&userid,0,0,0,0,0,0,0);
  264. XX`7D
  265. XX
  266. XXparam(word)
  267. XXchar word`5B5`5D;
  268. XX`7B
  269. XX  DESCR inp;
  270. XX  int length;
  271. XX  stdescr(inp,"    ");
  272. XX  LIB$GET_FOREIGN(&inp,0,&length,0); `20
  273. XX  strcpy(word,inp.pntr);
  274. XX`7D
  275. XX
  276. XXvoid usernum(userid)
  277. XXchar userid`5B8`5D;
  278. XX`7B
  279. XX  DESCR u_name;
  280. XX  int status;
  281. XX  stdescr(u_name,"        ");
  282. XX  lib$getjpi(&(JPI$_USERNAME),0,0,0,&u_name,0);
  283. XX  strcpy(userid,u_name.pntr);
  284. XX`7D
  285. XX
  286. XXvoid waitx(tim)
  287. XXfloat *tim;
  288. XX`7B
  289. XX  lib$wait(tim);
  290. XX`7D
  291. X$GoSub Convert_File
  292. X$File_is="RAND.FOR"
  293. X$Check_Sum_is=325473741
  294. X$Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
  295. XXC---------------------------------------------------------------------
  296. XXC RND Function - Designed, Written and Programmed by Stephen Macdonald
  297. XXC Code is copyright 1988 Stephen Macdonald CHBS08 Software Consultants
  298. XXC---------------------------------------------------------------------
  299. XX`60009SUBROUTINE Randomise
  300. XX`60009INTEGER seed
  301. XX`60009COMMON /seed/seed
  302. XX`60009CHARACTER date*30
  303. XX`60009CALL LIB$DATE_TIME(%DESCR(date))
  304. XX`60009seed=(10000*(ICHAR(date(16:16))-ICHAR('0'))
  305. XX     +        +1000*(ICHAR(date(17:17))-ICHAR('0'))
  306. XX     +        + 100*(ICHAR(date(19:19))-ICHAR('0'))
  307. XX     +        +  10*(ICHAR(date(20:20))-ICHAR('0'))
  308. XX     +        +     (ICHAR(date(22:22))-ICHAR('0')))
  309. XX`60009END
  310. XX
  311. XX
  312. XX`60009INTEGER FUNCTION Random(min,max)
  313. XX`60009INTEGER min,max,seed
  314. XX`60009REAL rnd,realseed
  315. XX`60009COMMON /seed/seed
  316. XX`60009seed=(((seed+1)*75)-1).AND.65535
  317. XX`60009realseed=seed
  318. XX`60009rnd=(realseed/65536)*(max-min)+min
  319. XX`60009random=rnd
  320. XX`60009END         `20
  321. XXC---------------------------------------------------------------------
  322. XXC RND Function - Designed, Written and Programmed by Stephen Macdonald
  323. XXC Code is copyright 1988 Stephen Macdonald CHBS08 Software Consultants
  324. XXC---------------------------------------------------------------------
  325. X$GoSub Convert_File
  326. X$File_is="README.TXT"
  327. X$Check_Sum_is=307909798
  328. X$Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
  329. XVThe game Shapes is based on the arcade game tetris, and follows roughly the
  330. V sa
  331. XXme
  332. XXrules, Full instructions are given in the game itself.
  333. XX
  334. XVThe game requires a VT100 compatible terminal, and a VAX running VMS versio
  335. Vn 4
  336. XX`20
  337. XXor later (at any rate, 4 was the earliest version it was compiled under).
  338. XX
  339. XXThe source code consists of:-
  340. XX
  341. XX  Shapes.pas     -    The main source code for the game
  342. XX
  343. XX  Includes.c     -    Certain system calls, which were easier to write in '
  344. VC'
  345. XX
  346. XX  Rand.for       -    Random number generator, written by a friend, Stephen
  347. XX                      Macdonald, and borrowed by me, cos I couldnt be bothe
  348. Vred
  349. XX
  350. XX
  351. XXSetting up the game:-
  352. XX
  353. XXThe game shapes uses 2 data files, one for the high score table, and one fo
  354. Vr
  355. XXany saved games which might exist. The destinations of these files should b
  356. Ve
  357. XXchanged in the source code "Shapes.pas" to point to wherever you want the
  358. XXfiles.
  359. XX
  360. XXThe actual lines to change are:
  361. XX
  362. XX  Htablefile='disk18:`5Bcadp02.pascal.shapes`5DHtable.dat';
  363. XX  Savefile='disk18:`5Bcadp02.pascal.shapes`5Dsave.dat';
  364. XX
  365. XX
  366. XXTo compile this code, execute the command procedure "compile.com" which is
  367. XXsupplied with this archive (e.g @compile )
  368. XX
  369. XXAfter compiling the code you need to create 2 empty data files, one for
  370. XXthe saved games, and one for the high score table.
  371. XX
  372. XXThis is done from within the game itself, by entering the "Cheat" mode.
  373. XXTo do this, run the game, and when the menu comes up, type in the string
  374. XX"cadp8". This activates the cheat mode.
  375. XX
  376. XXYou are then asked for a level number. This would be what level you would
  377. XXlike to start at, if you were going to play the game. At the moment we
  378. XXare not interested in that, so type 1 and press return.
  379. XX
  380. XXYou are now prompted if you would like to reset the saved games file.
  381. XXPress y and return.
  382. XX
  383. XXDo the same for the highscore table file.
  384. XX
  385. XXBoth files should be on world read and write access if other people are to
  386. XXbe able to play the game.
  387. XX
  388. XX
  389. XXThe game is now ready to play.
  390. XX
  391. XX
  392. XXNotes on the cheat mode:-
  393. XX
  394. XXBy entering the cheat mode as above, you can reset either , both or none of
  395. XXthe data files for the game, and choose which level to start on. Also,
  396. XVfrom within the game you can choose which shape you would like next by pres
  397. Vsin
  398. XXg
  399. XXthe keys 1 to 7 to choose. The appropriate shape will appear in the next sh
  400. Vape
  401. XXposition.
  402. XX
  403. XX
  404. XXThats it!! Enjoy!!
  405. XX
  406. XX
  407. XXYou are free to modify the code in any way whatsoever.
  408. XXThere are probably major improvements that can be made in the game as it is
  409. V,
  410. XXso if you make any, or have any comments, mail them to me at:-
  411. XX
  412. XX                     "CADP02@uk.ac.strath.vaxe"
  413. XX
  414. X$GoSub Convert_File
  415. X$Goto Part4
  416. XRelay-Version: VMS News - V5.9C 19/12/89 VAX/VMS V5.3; site cerritos.edu
  417. XPath: cerritos.edu!usc!wuarchive!zaphod.mps.ohio-state.edu!uakari.primate.wi
  418. Vsc.edu!aplcen!uunet!mcsun!ukc!strath-cs!str-va!cadp02
  419. XNewsgroups: alt.sources,vmsnet.sources.games
  420. XSubject: shapes 2 of 2
  421. XMessage-ID: <247.26e7cf1c@vaxa.strath.ac.uk>
  422. XFrom: cadp02@vaxa.strath.ac.uk
  423. XDate: 7 Sep 90 16:47:24 GMT
  424. XOrganization: Strathclyde University VAX Cluster
  425. XLines: 1722
  426. X
  427. XThis is part two of a two part poting of tetris for VAX's
  428. X
  429. XDelete everything above the line showing "$Part4:", concatenate part 2 onto
  430. Xthe end of part one and then "@shapes.shar1" to unarchive it
  431. X
  432. X
  433. X!---------------------------------------------------------------------------
  434. V--
  435. X$Part4:
  436. X$File_is="SHAPES.PAS"
  437. X$Check_Sum_is=573653758
  438. X$Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
  439. XXprogram Shapes(input,output,Htable,Save);
  440. XX
  441. XX
  442. XV`7B************************************************************************
  443. V*****
  444. XX**
  445. XX   Copyright 1989,1990 by Colin Cowie, Glasgow, Scotland.
  446. XX
  447. XX                        All Rights Reserved
  448. XX
  449. XX   Permission to use, copy, modify, and distribute this software and its`20
  450. XX   documentation for any purpose and without fee is hereby granted,`20
  451. XX   provided that the above copyright notice appear in all copies and that
  452. XX   both that copyright notice and this permission notice appear in`20
  453. XX   supporting documentation.
  454. XV***************************************************************************
  455. V***
  456. XX*`7D
  457. XX
  458. XX
  459. XX
  460. XXconst
  461. XX  Htablefile='disk18:`5Bcadp02.pascal.shapes`5DHtable.dat';
  462. XX  Savefile='disk18:`5Bcadp02.pascal.shapes`5Dsave.dat';
  463. XX
  464. XXtype
  465. XX  string = packed array`5B1..8`5D of char;
  466. XX  scorerec = record
  467. XX      num:integer;
  468. XX     name:packed array`5B1..40`5D of char;
  469. XX     level:integer;
  470. XX     id:string;
  471. XX     end;
  472. XX  recfile = file of scorerec;
  473. XX  scorearray = array`5B1..10`5D of scorerec;
  474. XX  screenarray = array`5B1..22,1..10`5D of integer;
  475. XX  timearray = packed array`5B1..11`5D of char;
  476. XX  datestr = packed array `5B1..11`5D of char;
  477. XX  saverec = record
  478. XX     num:integer;
  479. XX     level:integer;
  480. XX     outp:screenarray;
  481. XX     x:integer;
  482. XX     y:integer;
  483. XX     shape:integer;
  484. XX     position:integer;
  485. XX     lines:integer;
  486. XX     user:string;
  487. XX     current:datestr;
  488. XX      end;
  489. XX  saverecfile = file of saverec;
  490. XX  savearray = array`5B1..100`5D of saverec;
  491. XX
  492. XXvar
  493. XX  restored:boolean;
  494. XX  blank:saverec;
  495. XX  peeps:savearray;
  496. XX  HP:boolean;
  497. XX  factor:real;
  498. XX  curr:timearray;
  499. XX  flag,
  500. XX  flag2:boolean;
  501. XX  answer:char;
  502. XX  del:boolean;
  503. XX  userid:string;
  504. XX  flagA,
  505. XX  flagB,
  506. XX  flagC,
  507. XX  flagD:boolean;
  508. XX  chan:integer;
  509. XX  key:integer;
  510. XX  xchrhigh,
  511. XX  xchrlow,
  512. XX  ychrhigh,
  513. XX  ychrlow:char;
  514. XX  score,
  515. XX  shape,
  516. XX  position:integer;
  517. XX  cheat:boolean;
  518. XX  currd:datestr;
  519. XX  I,J,A:integer;
  520. XX  x,y:integer;
  521. XX  scores:scorearray;
  522. XX  OTT:boolean;
  523. XX  Htable:recfile;
  524. XX  Save,
  525. XX  Saver:saverecfile;
  526. XX  level:integer;
  527. XX  levelmin:integer;
  528. XX  screen:screenarray;
  529. XX  left,
  530. XX  right,
  531. XX  rotleft,
  532. XX  rotright,
  533. XX  speed,
  534. XX  redraw,
  535. XX  quitkey:char;
  536. XX  lines:integer;
  537. XX
  538. XX`7B*****************************************************************`7D
  539. XXprocedure CLS;
  540. XXbegin `7BCLS`7D
  541. XXwrite(chr(27),'`5BH');
  542. XXwriteln(chr(27),'`5B2J');
  543. XXend; `7BCLS`7D
  544. XX`7B*****************************************************************`7D
  545. XX
  546. XX`7B*****************************************************************`7D
  547. XV`7B************************************************************************
  548. V*****
  549. XX`7D
  550. XXprocedure makechan(%REF chan:integer);external;
  551. XX
  552. XXprocedure readkey(%REF key,chan:integer);external;
  553. XX
  554. XXprocedure waitkey(%REF key,chan:integer);external;
  555. XX
  556. XXprocedure waitx(%REF factor:real);external;
  557. XX
  558. XXprocedure spawn;external;
  559. XX
  560. XXprocedure RANDOMISE;fortran;
  561. XX
  562. XXfunction RANDOM(min,max:integer):integer;fortran;
  563. XX
  564. XXprocedure USERNUM(%stdescr userid:string);fortran;
  565. XX`7B*****************************************************************`7D
  566. XX
  567. XX
  568. XX`7B******************************************************************`7D
  569. XXprocedure highscores(score:integer; bit:integer; var Htable:recfile;
  570. XX var scores:scorearray; var gotin:boolean);
  571. XX
  572. XX
  573. XXvar
  574. XX  I,J:integer;
  575. XX  newscore:scorerec;
  576. XX  A:integer;
  577. XX  two:boolean;
  578. XX
  579. XXbegin
  580. XX  gotin:=false;
  581. XX  cls;
  582. XX  writeln('You scored: ',score,' points!!');
  583. XX  I:=1;
  584. XX  open (Htable, Htablefile,
  585. XX        history:=readonly);
  586. XX  reset(Htable);
  587. XX  while (not eof(Htable)) and (I <=10) do
  588. XX  begin
  589. XX    read(Htable,scores`5BI`5D);
  590. XX    I:=I+1;
  591. XX  end;
  592. XX  close(Htable);
  593. XX  for A:= I to 10 do
  594. XX  begin
  595. XX    scores`5BA`5D.num:=0;
  596. XX    scores`5BA`5D.name:='                                        ';
  597. XX    scores`5BA`5D.level:=1;
  598. XX    scores`5BA`5D.id:='        ';
  599. XX  end;
  600. XX  if score > scores`5B10`5D.num then
  601. XX  begin
  602. XX    two := true;
  603. XX    usernum(userid);
  604. XX    if (userid='CADP03  ') or
  605. XX       (userid='CADP02  ') or
  606. XX       (userid='CRAA30  ') or
  607. XX       (userid='CRAA38  ') then
  608. XX    begin
  609. XX      writeln('Enter usernum, maximum 8 chars (RETURN for default):');
  610. XX      write(':');
  611. XX      userid:='        ';
  612. XX      readln(userid);
  613. XX      if userid`5B1`5D=' ' then usernum(userid);
  614. XX    end;
  615. XX
  616. XX    for I := 10 downto 1 do
  617. XX    begin
  618. XX      if userid = scores`5BI`5D.id then
  619. XX      begin`20
  620. XX       if score > scores`5BI`5D.num then
  621. XX        begin
  622. XX          for J := I to 9 do
  623. XX            scores`5BJ`5D := scores`5BJ+1`5D;
  624. XX          if I = 9 then
  625. XX            scores`5B9`5D := scores`5B10`5D;
  626. XX          scores`5B10`5D.num:=0;
  627. XX          scores`5B10`5D.name:='                                       ';
  628. XX          scores`5B10`5D.level:=1;
  629. XX          scores`5B10`5D.id:='        ';
  630. XX        end
  631. XX        else
  632. XX        begin
  633. XX          two := false;
  634. XX        end;
  635. XX      end;
  636. XX    end;
  637. XX    if two = true then
  638. XX    begin
  639. XX      gotin:=true;
  640. XX      writeln('Well done, yu have made it into the top ten!!');
  641. XX      for A:=1 to 20 do
  642. XX        newscore.name`5BA`5D:=' ';
  643. XX      Writeln('Enter name, maximum 40 chars:');
  644. XX      write(':');
  645. XX      readln(newscore.name);
  646. XX      usernum(userid);
  647. XX      if (userid='CADP03  ') or`20
  648. XX         (userid='CADP02  ') or`20
  649. XX         (userid='CRAA30  ') or
  650. XX         (userid='CHBS08  ') then
  651. XX      begin
  652. XX        writeln('Enter usernum, maximum 8 chars (RETURN for default):');
  653. XX        write(':');
  654. XX        userid:='        ';
  655. XX        readln(userid);
  656. XX        if userid`5B1`5D=' ' then usernum(userid);
  657. XX      end;
  658. XX      newscore.num:=score;
  659. XX      newscore.level:=bit;
  660. XX      newscore.id:=userid;
  661. XX      I:=1;
  662. XX      while newscore.num < scores`5BI`5D.num do
  663. XX        I:=I+1;
  664. XX      for A:=10 downto I+1 do
  665. XX        scores`5BA`5D:=scores`5BA-1`5D;   `20
  666. XX      scores`5BI`5D:=newscore;
  667. XX      open (Htable , Htablefile ,
  668. XX  `60009history := old);
  669. XX      rewrite(Htable);
  670. XX      for I:=1 to 10 do
  671. XX        write(Htable,scores`5BI`5D);
  672. XX      close (Htable);
  673. XX      writeln('Press any key to view high-score table');
  674. XX    end
  675. XX    else
  676. XX    begin
  677. XX      writeln('One entry only per usernum in the high score table!!');
  678. XX      writeln('Press any key to return to main menu');
  679. XX    end;
  680. XX  end
  681. XX  else
  682. XX  begin
  683. XX    writeln('Sorry, yu didnt make the high score table!!!!!!');
  684. XX    writeln('Press any key to return to main menu');
  685. XX  end;
  686. XX  waitkey(key,chan);
  687. XXend;
  688. XX`7B*************************************************************`7D
  689. XX
  690. XX
  691. XX`7B*************************************************************`7D
  692. XXprocedure viewscores(var Htable:recfile; scores:scorearray; key,chan:intege
  693. Vr);
  694. XX
  695. XXvar
  696. XX  score:scorerec;
  697. XX  I,
  698. XX  A:integer;
  699. XX
  700. XXbegin
  701. XX  cls;
  702. XX  open (Htable, Htablefile,
  703. XX        history:=readonly);
  704. XX  reset(Htable);
  705. XX  I:=1;
  706. XX  while (not eof(Htable)) and (I <=10) do`20
  707. XX  begin
  708. XX    read(Htable,score);
  709. XX    scores`5BI`5D:=score;
  710. XX    I:=I+1;
  711. XX  end;
  712. XX  close (Htable);
  713. XX  for A:= I to 10 do
  714. XX  begin
  715. XX    scores`5BI`5D.num:=0;
  716. XX    scores`5BI`5D.name:='                                        ';
  717. XX    scores`5BI`5D.level:=1;
  718. XX    scores`5BI`5D.id:='        ';
  719. XX  end;
  720. XX  Writeln('                       Shapes HIGH SCORE TABLE');
  721. XX  writeln;writeln;
  722. XV  writeln('          score              name                           leve
  723. Vl `20
  724. XXuserid');
  725. XX  for I:=1 to 10 do
  726. XX  begin
  727. XX    writeln(I:2,'. ',scores`5BI`5D.num,'     ',scores`5BI`5D.name,'  ',
  728. XX            scores`5BI`5D.level:2,'    ',scores`5BI`5D.id);
  729. XX  end;
  730. XXwriteln;writeln;
  731. XXwriteln('                         Press any key to return to main menu');
  732. XXwaitkey(key,chan);
  733. XXend;
  734. XX
  735. XX`7B***********************************************************`7D
  736. XX
  737. XX
  738. XX`7B************************************************************`7D
  739. XXprocedure INTOCHAR(var xchrhigh,xchrlow,
  740. XX                       ychrhigh,ychrlow:char; x,y:integer);
  741. XX
  742. XXbegin `7BINTOCHAR`7D
  743. XX  xchrhigh`60009:= chr(ord('0') + x div 10) ;
  744. XX  xchrlow`60009:= chr(ord('0') + x mod 10) ;
  745. XX
  746. XX  ychrhigh`60009:= chr(ord('0') + y div 10) ;
  747. XX  ychrlow`60009:= chr(ord('0') + y mod 10) ;
  748. XX
  749. XXend; `7BINTOCHAR`7D
  750. XX`7B*********************************************************************`7D
  751. XX
  752. XX
  753. XX`7B*****************************************************************`7D
  754. XXprocedure MENUPRINT;
  755. XX
  756. XXbegin
  757. XX  CLS;
  758. XX  writeln(chr(27),'#3               Shapes');
  759. XX  writeln(chr(27),'#4               Shapes');
  760. XX  writeln(chr(27),'`5B22;25HCopyright 1989,1990 LokiSoft Ltd.');
  761. XX  writeln(chr(27),'`5B09;31H1. Play Shapes');
  762. XX  writeln(chr(27),'`5B10;31H2. Redefine Keys');
  763. XX  writeln(chr(27),'`5B11;31H3. View Score Board');
  764. XX  writeln(chr(27),'`5B12;31H4. Instructions');
  765. XX  write(chr(27),'`5B13;31H5. Print Next Shape');
  766. XX  if flag then writeln('  (YES)') else writeln('  (NO) ');
  767. XX  write(chr(27),'`5B14;31H6. Slow Down Game');
  768. XX  if flag2 then writeln('   (YES)') else writeln('   (NO) ');
  769. XX  writeln(chr(27),'`5B15;31H7. Restore Saved Game');
  770. XX  writeln(chr(27),'`5B17;31H0. Exit from game');
  771. XX  writeln(chr(27),'`5B19;31HEnter choice from options above');
  772. XX  writeln;
  773. XXend;
  774. XX`7B**********************************************************************`7
  775. VD
  776. XX`7B*****************************`7D
  777. XXprocedure Instructions;
  778. XXbegin
  779. XXcls;
  780. XXwriteln('Hi Guys, here''s another offering from the LokiSoft label,');
  781. XXwriteln('except this one''s good!!!!');
  782. XXwriteln;
  783. XXwriteln('This game is based on a certain arcade game which you may have ');
  784. XXwriteln('played at sometime or other, but I aint mentioning which one cos')
  785. V;
  786. XXwriteln('this is a blatant rip-off of it so its really dead obvious!!');
  787. XXwriteln;
  788. XXwriteln('Anyway, its like this: there are these seven different shapes:-');
  789. XXwriteln;
  790. XXwriteln('@@        @        @        @        @        @        @');
  791. XXwriteln('@@        @        @        @@      @@        @@       @');
  792. XXwriteln('          @@      @@         @      @         @        @');
  793. XXwriteln('                                                       @');
  794. XXwriteln('And these shapes fall from the top of the screen to the bottom,');
  795. XXwriteln('piling on top of one another.');
  796. XXwriteln('You can rotate each shape, and move it left or right, the ');
  797. XXwriteln('object being to get complete unbroken lines of "@@@@@@@@@@" at ');
  798. XXwriteln('the bottom of the screen.');
  799. XXwriteln('when this happens, that line is deleted, and the pile drops down')
  800. V;
  801. XXwriteln('and you are given points depending on which level you are on');
  802. XXwriteln;
  803. XXwriteln('                           Press any key for next page');
  804. XXwaitkey(key,chan);
  805. XXcls;
  806. XXwriteln;
  807. XXwriteln('If you are fortunate enough to get more than one completed line at
  808. V');
  809. XVwriteln('a time, you receive a bonus dependent on the level you are on and
  810. V the
  811. XX');
  812. XXwriteln('number of lines completed.');
  813. XXwriteln('After completing 5 lines, you move on to level 2 where you have to
  814. V');
  815. XXwriteln('complete 10 lines,..15 for level 3, and so on.');
  816. XXwriteln('There is a bonus at the end of each level depending on which level
  817. V');
  818. XVwriteln('you are on, and how low the pile of bricks is,..the lower the pile
  819. V,')
  820. XX;
  821. XXwriteln('the higher the bonus');
  822. XVwriteln('For each level, the number of points per completed line, and poten
  823. Vtia
  824. XXl');
  825. XXwriteln('bonus per level is increased, and there are an infinite number');
  826. XXwriteln('of levels in the game.');
  827. XXwriteln;
  828. XXwriteln('The default keys are: z - left, x - right,');
  829. XXwriteln('                o - rotate left, p - rotate right,');
  830. XXwriteln('     `5B - move shape to bottom, r - redraw screen, q - quit');
  831. XXwriteln('     ! - to spawn to dcl, @ - to save game');
  832. XXwriteln;
  833. XXwriteln('                           Press any key for next page');
  834. XXwaitkey(key,chan);
  835. XXcls;
  836. XXwriteln('Note on Saving game:-');
  837. XXwriteln;
  838. XXwriteln('It is only possible for any user to have one saved game at a time,
  839. V');
  840. XVwriteln('and if you attempt to save a game when you already have one stored
  841. V,')
  842. XX;
  843. XXwriteln('the stored game will be written over!!!');
  844. XXwriteln('Stored games will automatically be deleted when restored.');
  845. XXwriteln;
  846. XVwriteln('There is total space on the save-file for 100 games, and when it i
  847. Vs')
  848. XX;
  849. XVwriteln('full, whenever anyone attempts to save their game, the oldest prev
  850. Viou
  851. XXs');
  852. XXwriteln('saved game is written over!');
  853. XXwriteln;
  854. XXwriteln('Note on Slowing down game option:-');
  855. XXwriteln;
  856. XVwriteln('This option is intended only for people using workstations or simi
  857. Vlar
  858. XX');
  859. XXwriteln('which vastly speed up the screen printing, thereby making the game
  860. V');
  861. XXwriteln('unplayable. The slow down option negates this problem.');
  862. XXwriteln;
  863. XXwriteln('Now I''ll take this opportunity to wish you happy playing and good
  864. V');
  865. XXwriteln('luck, you''ll need it!!!!');
  866. XXwriteln(chr(27),'`5B22;30HPress any key for main menu');
  867. XXwaitkey(key,chan);
  868. XXend;
  869. XX`7B*****************************`7D
  870. XX
  871. XX
  872. XX
  873. XX`7B*******************************************************************`7D `
  874. V20
  875. XVprocedure KEYDEFINE(var left,right,rotleft,rotright,speed,quitkey,redraw:ch
  876. Var)
  877. XX;
  878. XX
  879. XXvar
  880. XX
  881. XX  redrawint,
  882. XX  null,
  883. XX  leftint,
  884. XX  rightint,
  885. XX  rotleftint,
  886. XX  rotrightint,
  887. XX  speedint,
  888. XX  stopint:integer;
  889. XX  quitint:integer;
  890. XX
  891. XXbegin `7BKEYDEFINE`7D
  892. XX  CLS;
  893. XX  writeln('         Defining Keys For SHAPES ');
  894. XX  writeln;
  895. XX  writeln;
  896. XX  writeln;
  897. XX  writeln;
  898. XX  writeln('Press key for movement LEFT: ');
  899. XX  waitkey(leftint,chan);
  900. XX  left:=chr(leftint);
  901. XX  writeln(left);
  902. XX  writeln('press key for movement RIGHT: ');
  903. XX  waitkey(rightint,chan);
  904. XX  while (rightint=leftint) do
  905. XX    waitkey(rightint,chan);
  906. XX  right:=chr(rightint);
  907. XX  writeln(right);
  908. XX  writeln('Press key for rotation ANTICLOCKWISE: ');
  909. XX  waitkey(rotleftint,chan);
  910. XX  while (rotleftint=leftint) or
  911. XX        (rotleftint=rightint) do
  912. XX    waitkey(rotleftint,chan);
  913. XX  rotleft:=chr(rotleftint);
  914. XX  writeln(rotleft);
  915. XX  writeln('press key for rotation CLOCKWISE: ');
  916. XX  waitkey(rotrightint,chan);
  917. XX  while (rotrightint=rightint) or
  918. XX        (rotrightint=rotleftint) or
  919. XX        (rotrightint=leftint) do
  920. XX    waitkey(rotrightint,chan);
  921. +-+-+-+-+-+-+-+-  END  OF PART 1 +-+-+-+-+-+-+-+-
  922. -- 
  923. \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
  924. < Joe Koffley                        KOFFLEY@NRLVAX.NRL.NAVY.MIL             >
  925. < Naval Research Laboratory          KOFFLEY@SMOVAX.NRL.NAVY.MIL             >
  926. < Space Systems Division             AT&T  :  202-767-0894                   >
  927. \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
  928.  
  929.