cadp02@vaxa.strath.ac.uk (09/07/90)
This is part two of a two part poting of tetris for VAX's
Delete everything above the line showing "$Part4:", concatenate part 2 onto
the end of part one and then "@shapes.shar1" to unarchive it
!-----------------------------------------------------------------------------
$Part4:
$File_is="SHAPES.PAS"
$Check_Sum_is=573653758
$Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
Xprogram Shapes(input,output,Htable,Save);
X
X
V{*****************************************************************************
X**
X Copyright 1989,1990 by Colin Cowie, Glasgow, Scotland.
X
X All Rights Reserved
X
X Permission to use, copy, modify, and distribute this software and its
X documentation for any purpose and without fee is hereby granted,
X provided that the above copyright notice appear in all copies and that
X both that copyright notice and this permission notice appear in
X supporting documentation.
V******************************************************************************
X*}
X
X
X
Xconst
X Htablefile='disk18:[cadp02.pascal.shapes]Htable.dat';
X Savefile='disk18:[cadp02.pascal.shapes]save.dat';
X
Xtype
X string = packed array[1..8] of char;
X scorerec = record
X num:integer;
X name:packed array[1..40] of char;
X level:integer;
X id:string;
X end;
X recfile = file of scorerec;
X scorearray = array[1..10] of scorerec;
X screenarray = array[1..22,1..10] of integer;
X timearray = packed array[1..11] of char;
X datestr = packed array [1..11] of char;
X saverec = record
X num:integer;
X level:integer;
X outp:screenarray;
X x:integer;
X y:integer;
X shape:integer;
X position:integer;
X lines:integer;
X user:string;
X current:datestr;
X end;
X saverecfile = file of saverec;
X savearray = array[1..100] of saverec;
X
Xvar
X restored:boolean;
X blank:saverec;
X peeps:savearray;
X HP:boolean;
X factor:real;
X curr:timearray;
X flag,
X flag2:boolean;
X answer:char;
X del:boolean;
X userid:string;
X flagA,
X flagB,
X flagC,
X flagD:boolean;
X chan:integer;
X key:integer;
X xchrhigh,
X xchrlow,
X ychrhigh,
X ychrlow:char;
X score,
X shape,
X position:integer;
X cheat:boolean;
X currd:datestr;
X I,J,A:integer;
X x,y:integer;
X scores:scorearray;
X OTT:boolean;
X Htable:recfile;
X Save,
X Saver:saverecfile;
X level:integer;
X levelmin:integer;
X screen:screenarray;
X left,
X right,
X rotleft,
X rotright,
X speed,
X redraw,
X quitkey:char;
X lines:integer;
X
X{*****************************************************************}
Xprocedure CLS;
Xbegin {CLS}
Xwrite(chr(27),'[H');
Xwriteln(chr(27),'[2J');
Xend; {CLS}
X{*****************************************************************}
X
X{*****************************************************************}
V{*****************************************************************************
X}
Xprocedure makechan(%REF chan:integer);external;
X
Xprocedure readkey(%REF key,chan:integer);external;
X
Xprocedure waitkey(%REF key,chan:integer);external;
X
Xprocedure waitx(%REF factor:real);external;
X
Xprocedure spawn;external;
X
Xprocedure RANDOMISE;fortran;
X
Xfunction RANDOM(min,max:integer):integer;fortran;
X
Xprocedure USERNUM(%stdescr userid:string);fortran;
X{*****************************************************************}
X
X
X{******************************************************************}
Xprocedure highscores(score:integer; bit:integer; var Htable:recfile;
X var scores:scorearray; var gotin:boolean);
X
X
Xvar
X I,J:integer;
X newscore:scorerec;
X A:integer;
X two:boolean;
X
Xbegin
X gotin:=false;
X cls;
X writeln('You scored: ',score,' points!!');
X I:=1;
X open (Htable, Htablefile,
X history:=readonly);
X reset(Htable);
X while (not eof(Htable)) and (I <=10) do
X begin
X read(Htable,scores[I]);
X I:=I+1;
X end;
X close(Htable);
X for A:= I to 10 do
X begin
X scores[A].num:=0;
X scores[A].name:=' ';
X scores[A].level:=1;
X scores[A].id:=' ';
X end;
X if score > scores[10].num then
X begin
X two := true;
X usernum(userid);
X if (userid='CADP03 ') or
X (userid='CADP02 ') or
X (userid='CRAA30 ') or
X (userid='CRAA38 ') then
X begin
X writeln('Enter usernum, maximum 8 chars (RETURN for default):');
X write(':');
X userid:=' ';
X readln(userid);
X if userid[1]=' ' then usernum(userid);
X end;
X
X for I := 10 downto 1 do
X begin
X if userid = scores[I].id then
X begin
X if score > scores[I].num then
X begin
X for J := I to 9 do
X scores[J] := scores[J+1];
X if I = 9 then
X scores[9] := scores[10];
X scores[10].num:=0;
X scores[10].name:=' ';
X scores[10].level:=1;
X scores[10].id:=' ';
X end
X else
X begin
X two := false;
X end;
X end;
X end;
X if two = true then
X begin
X gotin:=true;
X writeln('Well done, yu have made it into the top ten!!');
X for A:=1 to 20 do
X newscore.name[A]:=' ';
X Writeln('Enter name, maximum 40 chars:');
X write(':');
X readln(newscore.name);
X usernum(userid);
X if (userid='CADP03 ') or
X (userid='CADP02 ') or
X (userid='CRAA30 ') or
X (userid='CHBS08 ') then
X begin
X writeln('Enter usernum, maximum 8 chars (RETURN for default):');
X write(':');
X userid:=' ';
X readln(userid);
X if userid[1]=' ' then usernum(userid);
X end;
X newscore.num:=score;
X newscore.level:=bit;
X newscore.id:=userid;
X I:=1;
X while newscore.num < scores[I].num do
X I:=I+1;
X for A:=10 downto I+1 do
X scores[A]:=scores[A-1];
X scores[I]:=newscore;
X open (Htable , Htablefile ,
X `009history := old);
X rewrite(Htable);
X for I:=1 to 10 do
X write(Htable,scores[I]);
X close (Htable);
X writeln('Press any key to view high-score table');
X end
X else
X begin
X writeln('One entry only per usernum in the high score table!!');
X writeln('Press any key to return to main menu');
X end;
X end
X else
X begin
X writeln('Sorry, yu didnt make the high score table!!!!!!');
X writeln('Press any key to return to main menu');
X end;
X waitkey(key,chan);
Xend;
X{*************************************************************}
X
X
X{*************************************************************}
Xprocedure viewscores(var Htable:recfile; scores:scorearray; key,chan:integer);
X
Xvar
X score:scorerec;
X I,
X A:integer;
X
Xbegin
X cls;
X open (Htable, Htablefile,
X history:=readonly);
X reset(Htable);
X I:=1;
X while (not eof(Htable)) and (I <=10) do
X begin
X read(Htable,score);
X scores[I]:=score;
X I:=I+1;
X end;
X close (Htable);
X for A:= I to 10 do
X begin
X scores[I].num:=0;
X scores[I].name:=' ';
X scores[I].level:=1;
X scores[I].id:=' ';
X end;
X Writeln(' Shapes HIGH SCORE TABLE');
X writeln;writeln;
V writeln(' score name level
Xuserid');
X for I:=1 to 10 do
X begin
X writeln(I:2,'. ',scores[I].num,' ',scores[I].name,' ',
X scores[I].level:2,' ',scores[I].id);
X end;
Xwriteln;writeln;
Xwriteln(' Press any key to return to main menu');
Xwaitkey(key,chan);
Xend;
X
X{***********************************************************}
X
X
X{************************************************************}
Xprocedure INTOCHAR(var xchrhigh,xchrlow,
X ychrhigh,ychrlow:char; x,y:integer);
X
Xbegin {INTOCHAR}
X xchrhigh`009:= chr(ord('0') + x div 10) ;
X xchrlow`009:= chr(ord('0') + x mod 10) ;
X
X ychrhigh`009:= chr(ord('0') + y div 10) ;
X ychrlow`009:= chr(ord('0') + y mod 10) ;
X
Xend; {INTOCHAR}
X{*********************************************************************}
X
X
X{*****************************************************************}
Xprocedure MENUPRINT;
X
Xbegin
X CLS;
X writeln(chr(27),'#3 Shapes');
X writeln(chr(27),'#4 Shapes');
X writeln(chr(27),'[22;25HCopyright 1989,1990 LokiSoft Ltd.');
X writeln(chr(27),'[09;31H1. Play Shapes');
X writeln(chr(27),'[10;31H2. Redefine Keys');
X writeln(chr(27),'[11;31H3. View Score Board');
X writeln(chr(27),'[12;31H4. Instructions');
X write(chr(27),'[13;31H5. Print Next Shape');
X if flag then writeln(' (YES)') else writeln(' (NO) ');
X write(chr(27),'[14;31H6. Slow Down Game');
X if flag2 then writeln(' (YES)') else writeln(' (NO) ');
X writeln(chr(27),'[15;31H7. Restore Saved Game');
X writeln(chr(27),'[17;31H0. Exit from game');
X writeln(chr(27),'[19;31HEnter choice from options above');
X writeln;
Xend;
X{**********************************************************************}
X{*****************************}
Xprocedure Instructions;
Xbegin
Xcls;
Xwriteln('Hi Guys, here''s another offering from the LokiSoft label,');
Xwriteln('except this one''s good!!!!');
Xwriteln;
Xwriteln('This game is based on a certain arcade game which you may have ');
Xwriteln('played at sometime or other, but I aint mentioning which one cos');
Xwriteln('this is a blatant rip-off of it so its really dead obvious!!');
Xwriteln;
Xwriteln('Anyway, its like this: there are these seven different shapes:-');
Xwriteln;
Xwriteln('@@ @ @ @ @ @ @');
Xwriteln('@@ @ @ @@ @@ @@ @');
Xwriteln(' @@ @@ @ @ @ @');
Xwriteln(' @');
Xwriteln('And these shapes fall from the top of the screen to the bottom,');
Xwriteln('piling on top of one another.');
Xwriteln('You can rotate each shape, and move it left or right, the ');
Xwriteln('object being to get complete unbroken lines of "@@@@@@@@@@" at ');
Xwriteln('the bottom of the screen.');
Xwriteln('when this happens, that line is deleted, and the pile drops down');
Xwriteln('and you are given points depending on which level you are on');
Xwriteln;
Xwriteln(' Press any key for next page');
Xwaitkey(key,chan);
Xcls;
Xwriteln;
Xwriteln('If you are fortunate enough to get more than one completed line at');
Vwriteln('a time, you receive a bonus dependent on the level you are on and the
X');
Xwriteln('number of lines completed.');
Xwriteln('After completing 5 lines, you move on to level 2 where you have to');
Xwriteln('complete 10 lines,..15 for level 3, and so on.');
Xwriteln('There is a bonus at the end of each level depending on which level');
Vwriteln('you are on, and how low the pile of bricks is,..the lower the pile,')
X;
Xwriteln('the higher the bonus');
Vwriteln('For each level, the number of points per completed line, and potentia
Xl');
Xwriteln('bonus per level is increased, and there are an infinite number');
Xwriteln('of levels in the game.');
Xwriteln;
Xwriteln('The default keys are: z - left, x - right,');
Xwriteln(' o - rotate left, p - rotate right,');
Xwriteln(' [ - move shape to bottom, r - redraw screen, q - quit');
Xwriteln(' ! - to spawn to dcl, @ - to save game');
Xwriteln;
Xwriteln(' Press any key for next page');
Xwaitkey(key,chan);
Xcls;
Xwriteln('Note on Saving game:-');
Xwriteln;
Xwriteln('It is only possible for any user to have one saved game at a time,');
Vwriteln('and if you attempt to save a game when you already have one stored,')
X;
Xwriteln('the stored game will be written over!!!');
Xwriteln('Stored games will automatically be deleted when restored.');
Xwriteln;
Vwriteln('There is total space on the save-file for 100 games, and when it is')
X;
Vwriteln('full, whenever anyone attempts to save their game, the oldest previou
Xs');
Xwriteln('saved game is written over!');
Xwriteln;
Xwriteln('Note on Slowing down game option:-');
Xwriteln;
Vwriteln('This option is intended only for people using workstations or similar
X');
Xwriteln('which vastly speed up the screen printing, thereby making the game');
Xwriteln('unplayable. The slow down option negates this problem.');
Xwriteln;
Xwriteln('Now I''ll take this opportunity to wish you happy playing and good');
Xwriteln('luck, you''ll need it!!!!');
Xwriteln(chr(27),'[22;30HPress any key for main menu');
Xwaitkey(key,chan);
Xend;
X{*****************************}
X
X
X
X{*******************************************************************}
Vprocedure KEYDEFINE(var left,right,rotleft,rotright,speed,quitkey,redraw:char)
X;
X
Xvar
X
X redrawint,
X null,
X leftint,
X rightint,
X rotleftint,
X rotrightint,
X speedint,
X stopint:integer;
X quitint:integer;
X
Xbegin {KEYDEFINE}
X CLS;
X writeln(' Defining Keys For SHAPES ');
X writeln;
X writeln;
X writeln;
X writeln;
X writeln('Press key for movement LEFT: ');
X waitkey(leftint,chan);
X left:=chr(leftint);
X writeln(left);
X writeln('press key for movement RIGHT: ');
X waitkey(rightint,chan);
X while (rightint=leftint) do
X waitkey(rightint,chan);
X right:=chr(rightint);
X writeln(right);
X writeln('Press key for rotation ANTICLOCKWISE: ');
X waitkey(rotleftint,chan);
X while (rotleftint=leftint) or
X (rotleftint=rightint) do
X waitkey(rotleftint,chan);
X rotleft:=chr(rotleftint);
X writeln(rotleft);
X writeln('press key for rotation CLOCKWISE: ');
X waitkey(rotrightint,chan);
X while (rotrightint=rightint) or
X (rotrightint=rotleftint) or
X (rotrightint=leftint) do
X waitkey(rotrightint,chan);
X rotright:=chr(rotrightint);
X writeln(rotright);
X writeln('press key to move shape to bottom: ');
X waitkey(speedint,chan);
X while (speedint=rightint) or
X (speedint=leftint) or
X (speedint=rotleftint) or
X (speedint=rotrightint) do
X waitkey(speedint,chan);
X speed:=chr(speedint);
X writeln(speed);
X writeln('press key to quit game: ');
X waitkey(quitint,chan);
X while (quitint=rightint) or
X (quitint=leftint) or
X (quitint=rotleftint) or
X (quitint=rotrightint) or
X (quitint=speedint) do
X waitkey(quitint,chan);
X quitkey:=chr(quitint);
X writeln(quitkey);
X writeln('press key to redraw screen');
X waitkey(redrawint,chan);
X while (redrawint=rightint) or
X (redrawint=leftint) or
X (redrawint=rotrightint) or
X (redrawint=rotleftint) or
X (redrawint=quitint) do
X waitkey(redrawint,chan);
X redraw:=chr(redrawint);
X writeln(redraw);
X writeln;
X writeln;
X writeln;
X writeln(' Press any key to continue ');
X waitkey(null,chan);
Xend; {KEYDEFINE}
X{*******************************************************************}
X
X
X
X{***********************************************************************}
Xprocedure Shapestuff(shape,position,y,x:integer; var screen:screenarray;
X n:integer);
Xbegin
X screen[y,x]:=n;
X if shape = 1 then
X begin
X screen[y,x+1]:=n;
X screen[y+1,x]:=n;
X screen[y+1,x+1]:=n;
X end
X else
X if shape = 2 then
X begin
X if position = 1 then
X begin
X screen[y-1,x]:=n;
X screen[y+1,x]:=n;
X screen[y+1,x+1]:=n;
X end
X else
X if position = 2 then
X begin
X screen[y,x+1]:=n;
X screen[y,x-1]:=n;
X screen[y+1,x-1]:=n;
X end
X else
X if position = 3 then
X begin
X screen[y+1,x]:=n;
X screen[y-1,x]:=n;
X screen[y-1,x-1]:=n;
X end
X else
X if position = 4 then
X begin
X screen[y,x-1]:=n;
X screen[y,x+1]:=n;
X screen[y-1,x+1]:=n;
X end;
X end
X else
X if shape = 3 then
X begin
X if position = 1 then
X begin
X screen[y-1,x]:=n;
X screen[y+1,x]:=n;
X screen[y+1,x-1]:=n;
X end
X else
X if position = 2 then
X begin
X screen[y,x+1]:=n;
X screen[y,x-1]:=n;
X screen[y-1,x-1]:=n;
X end
X else
X if position = 3 then
X begin
X screen[y-1,x]:=n;
X screen[y+1,x]:=n;
X screen[y-1,x+1]:=n;
X end
X else
X if position = 4 then
X begin
X screen[y,x-1]:=n;
X screen[y,x+1]:=n;
X screen[y+1,x+1]:=n;
X end;
X end
X else
X if shape = 4 then
X begin
X if position = 1 then
X begin
X screen[y-1,x]:=n;
X screen[y+1,x]:=n;
X screen[y,x+1]:=n;
X end
X else
X if position = 2 then
X begin
X screen[y+1,x]:=n;
X screen[y,x-1]:=n;
X screen[y,x+1]:=n;
X end
X else
X if position = 3 then
X begin
X screen[y-1,x]:=n;
X screen[y+1,x]:=n;
X screen[y,x-1]:=n;
X end
X else
X if position = 4 then
X begin
X screen[y-1,x]:=n;
X screen[y,x-1]:=n;
X screen[y,x+1]:=n;
X end;
X end
X else
X if shape = 5 then
X begin
X if (position = 1) or (position = 3) then
X begin
X screen[y+1,x]:=n;
X screen[y,x+1]:=n;
X screen[y-1,x+1]:=n;
X end
X else
X if (position = 2) or (position = 4) then
X begin
X screen[y,x-1]:=n;
X screen[y+1,x]:=n;
X screen[y+1,x+1]:=n;
X end;
X end
X else
X if shape = 6 then
X begin
X if (position = 1) or (position = 3) then
X begin
X screen[y-1,x]:=n;
X screen[y,x+1]:=n;
X screen[y+1,x+1]:=n;
X end
X else
X if (position = 2) or (position = 4) then
X begin
X screen[y,x+1]:=n;
X screen[y+1,x]:=n;
X screen[y+1,x-1]:=n;
X end;
X end
X else
X if shape = 7 then
X begin
X if (position = 1) or (position = 3) then
X begin
X screen[y-1,x]:=n;
X screen[y+1,x]:=n;
X screen[y+2,x]:=n;
X end
X else
X if (position = 2) or (position = 4) then
X begin
X screen[y,x-2]:=n;
X screen[y,x-1]:=n;
X screen[y,x+1]:=n;
X end;
X end;
Xend;
X{****************************************************************************}
X
X
X{***********************************************************************}
Xprocedure Check(shape,position,y,x:integer; var change:boolean);
X
Xbegin
X change:=true;
X if shape = 2 then
X begin
X if position = 1 then
X begin
X if screen[y-1,x]=1 then change:= false
X else
X if screen[y+1,x]=1 then change:= false
X else
X if screen[y+1,x+1]=1 then change:= false;
X end
X else
X if position = 2 then
X begin
X if screen[y,x+1]=1 then change:= false else
X if screen[y,x-1]=1 then change:= false else
X if screen[y+1,x-1]=1 then change:= false;
X end
X else
X if position = 3 then
X begin
X if screen[y+1,x]=1 then change:= false else
X if screen[y-1,x]=1 then change:= false else
X if screen[y-1,x-1]=1 then change:= false;
X end
X else
X if position = 4 then
X begin
X if screen[y,x-1]=1 then change:= false else
X if screen[y,x+1]=1 then change:= false else
X if screen[y-1,x+1]=1 then change:= false;
X end;
X end
X else
X if shape = 3 then
X begin
X if position = 1 then
X begin
X if screen[y-1,x]=1 then change:= false else
X if screen[y+1,x]=1 then change:= false else
X if screen[y+1,x-1]=1 then change:= false;
X end
X else
X if position = 2 then
X begin
X if screen[y,x+1]=1 then change:= false else
X if screen[y,x-1]=1 then change:= false else
X if screen[y-1,x-1]=1 then change:= false;
X end
X else
X if position = 3 then
X begin
X if screen[y-1,x]=1 then change:= false else
X if screen[y+1,x]=1 then change:= false else
X if screen[y-1,x+1]=1 then change:= false;
X end
X else
X if position = 4 then
X begin
X if screen[y,x-1]=1 then change:= false else
X if screen[y,x+1]=1 then change:= false else
X if screen[y+1,x+1]=1 then change:= false;
X end;
X end
X else
X if shape = 4 then
X begin
X if position = 1 then
X begin
X if screen[y-1,x]=1 then change:= false else
X if screen[y+1,x]=1 then change:= false else
X if screen[y,x+1]=1 then change:= false;
X end
X else
X if position = 2 then
X begin
X if screen[y+1,x]=1 then change:= false else
X if screen[y,x-1]=1 then change:= false else
X if screen[y,x+1]=1 then change:= false;
X end
X else
X if position = 3 then
X begin
X if screen[y-1,x]=1 then change:= false else
X if screen[y+1,x]=1 then change:= false else
X if screen[y,x-1]=1 then change:= false;
X end
X else
X if position = 4 then
X begin
X if screen[y-1,x]=1 then change:= false else
X if screen[y,x-1]=1 then change:= false else
X if screen[y,x+1]=1 then change:= false;
X end;
X end
X else
X if shape = 5 then
X begin
X if (position = 1) or (position = 3) then
X begin
X if screen[y+1,x]=1 then change:= false else
X if screen[y,x+1]=1 then change:= false else
X if screen[y-1,x+1]=1 then change:= false;
X end
X else
X if (position = 2) or (position = 4) then
X begin
X if screen[y,x-1]=1 then change:= false else
X if screen[y+1,x]=1 then change:= false else
X if screen[y+1,x+1]=1 then change:= false;
X end;
X end
X else
X if shape = 6 then
X begin
X if (position = 1) or (position = 3) then
X begin
X if screen[y-1,x]=1 then change:= false else
X if screen[y,x+1]=1 then change:= false else
X if screen[y+1,x+1]=1 then change:= false;
X end
X else
X if (position = 2) or (position = 4) then
X begin
X if screen[y,x+1]=1 then change:= false else
X if screen[y+1,x]=1 then change:= false else
X if screen[y+1,x-1]=1 then change:= false;
X end;
X end
X else
X if shape = 7 then
X begin
X if (position = 1) or (position = 3) then
X begin
X if screen[y-1,x]=1 then change:= false else
X if screen[y+1,x]=1 then change:= false else
X if screen[y+2,x]=1 then change:= false;
X end
X else
X if (position = 2) or (position = 4) then
X begin
X if screen[y,x-2]=1 then change:= false else
X if screen[y,x-1]=1 then change:= false else
X if screen[y,x+1]=1 then change:= false;
X end;
X end;
Xend;
X{****************************************************************************}
X
X
X{****************************************************************************}
Xprocedure Create(var shape,position,y,x:integer);
X
Xvar
X shapenum:integer;
X
Xbegin
X shapenum:=random(1,23);
X if shapenum < 4 then shape:=1
X else
X if shapenum < 7 then shape:=2
X else
X if shapenum < 11 then shape:=3
X else
X if shapenum < 14 then shape:=4
X else
X if shapenum < 17 then shape:=5
X else
X if shapenum < 20 then shape:=6
X else
X if shapenum < 23 then shape:=7
X else
X shape:=8;
X position:=1;
X y:=2;
X x:=5;
Xend;
X{**************************************************************************}
X
X
X{***********************************************}
Xprocedure PrintLines(screen:screenarray; b:integer);
X
Xvar
X a,
X c:integer;
X noline:boolean;
X
Xbegin
X a:=b;
X repeat
X noline:=true;
X for c:=1 to 10 do
X begin
X if screen[a,c] = 1 then noline:=false;
X intochar(xchrhigh,xchrlow,ychrhigh,ychrlow,c+30,a);
X if screen[a,c] = 1 then
X writeln(chr(27),'[',ychrhigh,ychrlow,';',xchrhigh,xchrlow,'H#');
X if screen[a,c] = 0 then
X writeln(chr(27),'[',ychrhigh,ychrlow,';',xchrhigh,xchrlow,'H ');
X end;
X a:=a-1;
X until (noline) or (a = 1);
Xend;
X{************************************************}
X{******************************************************}
Xprocedure LineDelete(var screen:screenarray; b:integer; var score:integer;
X level:integer; var lines:integer);
X
Xvar
X a,
X c:integer;
X
Xbegin
X for a:= b downto 2 do
X for c:=1 to 10 do
X screen[a,c]:=screen[a-1,c];
X printlines(screen,b);
X if not(flag) then
X score:=score+(150*level)
X else
X score:=score+(100*level);
X lines:=lines+1;
X writeln(chr(27),'[14;7H',((5*level)-lines):2);
X writeln(chr(27),'[10;7H',score:1);
Xend;
X{***************************************************}
X{****************************************************************************}
Xprocedure LineStuff(var screen:screenarray; var lines:integer;
X level:integer; var score:integer);
X
Xvar
X A,
X B:integer;
X line,
X nothing:boolean;
X linenum:integer;
X bounty:integer;
X
Xbegin
X linenum:=lines;
X b:=22;
X bounty:=0;
X repeat
X line:=true;
X for a:=1 to 10 do
X if screen[b,a]=0 then line:=false;
X nothing:=true;
X for a:=1 to 10 do
X if screen[b,a]=1 then nothing:=false;
X if line then
X begin
X LineDelete(screen,b,score,level,lines);
X b:=b+1;
X end;
X b:=b-1;
X until (nothing = true) or (b = 0);
X linenum:=lines-linenum;
X if linenum > 1 then bounty:=((linenum-1) * 200 * level);
X score:=score+bounty;
X writeln(chr(27),'[10;7H',score:1);
Xend;
X{**********************************************************************}
X
X
X{**********************************************************************}
Xprocedure bonus(var score:integer; screen:screenarray; level:integer);
X
Xvar
X a,
X b:integer;
X noline:boolean;
X
X
Xbegin
X a:=22;
X b:=1;
X repeat
X noline:=true;
X for b:=1 to 10 do
X if screen[a,b] = 1 then noline:=false;
X a:=a-1;
X until (a = 0) or (noline = true);
X
X if noline then
X score:=score+(100*a*level);
Xend;
X{******************************************************************}
X
X{*************************************}
Xprocedure Printshape(screen:screenarray; y,x:integer);
X
Xvar
X a,
X b,
X i,
X j:integer;
X stuff:packed array[1..10] of char;
X
Xbegin
X if flag2 = TRUE then
X begin
X waitx(factor);
X end;
X for a:= y-2 to y+3 do
X begin
X if (a < 23) and (a > 1) then
X begin
X intochar(xchrhigh,xchrlow,ychrhigh,ychrlow,31,a);
X for b:=1 to 10 do
X begin
X if screen[a,b] = 1 then stuff[b]:='#'
X else
X if screen[a,b] = 2 then stuff[b]:='@'
X else
X stuff[b]:=' ';
X end;
X writeln(chr(27),'[',ychrhigh,ychrlow,';31H',stuff)
X end;
X end;
Xend;
X{*************************************}
X
X{**********************************************************************}
Xprocedure printnext(shape:integer);
X
Xbegin
X writeln(chr(27),'[07;50H ');
X writeln(chr(27),'[08;50H ');
X if shape = 1 then
X begin
X writeln(chr(27),'[05;50H@@');
X writeln(chr(27),'[06;50H@@');
X end
X else
X if shape = 2 then
X begin
X writeln(chr(27),'[05;50H@ ');
X writeln(chr(27),'[06;50H@ ');
X writeln(chr(27),'[07;50H@@');
X end
X else
X if shape = 3 then
X begin
X writeln(chr(27),'[05;50H @');
X writeln(chr(27),'[06;50H @');
X writeln(chr(27),'[07;50H@@');
X end
X else
X if shape = 4 then
X begin
X writeln(chr(27),'[05;50H@ ');
X writeln(chr(27),'[06;50H@@');
X writeln(chr(27),'[07;50H@ ');
X end
X else
X if shape = 5 then
X begin
X writeln(chr(27),'[05;50H @');
X writeln(chr(27),'[06;50H@@');
X writeln(chr(27),'[07;50H@ ');
X end
X else
X if shape = 6 then
X begin
X writeln(chr(27),'[05;50H@ ');
X writeln(chr(27),'[06;50H@@');
X writeln(chr(27),'[07;50H @');
X end
X else
X if shape = 7 then
X begin
X writeln(chr(27),'[05;50H@ ');
X writeln(chr(27),'[06;50H@ ');
X writeln(chr(27),'[07;50H@ ');
X writeln(chr(27),'[08;50H@ ');
X end;
Xend;
X{**********************************************************************}
X
X
X{**********************************************************************}
Vprocedure Rotation(var screen:screenarray; shape:integer; var position:integer
X;
X rotint:integer; var y,x:integer);
X
Xvar
X newposition:integer;
X ax:integer;
X change:boolean;
X
Xbegin
X if shape = 7 then
X begin
X ax:=x;
X if x = 10 then ax:=9;
X if x = 1 then ax:=3;
X if x = 2 then ax:=3;
X end
X else
X if x =1 then ax:=2
X else
X if x =10 then ax:=9
X else
X ax:=x;
X
X
X if rotint = -1 then
X begin
X if position = 1 then newposition:=4
X else
X newposition:=position -1;
X end
X else
X if rotint = 1 then
X begin
X if position = 4 then newposition:=1
X else
X newposition:=position +1;
X end;
X
X
X check(shape,newposition,y,ax,change);
X if change = true then
X begin
X shapestuff(shape,position,y,x,screen,0);
X position:=newposition;
X x:=ax;
X shapestuff(shape,position,y,x,screen,2);
X printshape(screen,y,x);
X end;
Xend;
V{*****************************************************************************
X}
X
X
V{*****************************************************************************
X}
Xprocedure Movement(var screen:screenarray; shape,position:integer;
X var y,x:integer; d:integer);
X
X
Xvar
X move:boolean;
X a,
X b:integer;
Xbegin
X move:=true;
X if d = 1 then
X begin
X for a:= x+2 downto x-2 do
X for b:=y+2 downto y-1 do
X if (a >1) and (a<11) and (b > 1) and (b < 23) then
X begin
X if (a = 10) and (screen[b,a] = 2) then move:=false;
X if (screen[b,a] = 1) and (screen[b,a-1] = 2) then move:=false;
X end;
X end
X else
X if d = -1 then
X begin
X for a:=x-3 to x+1 do
X for b:=y-1 to y+2 do
X if (a >0) and (a<9) and (b>1) and (b<23) then
X begin
X if (a = 1) and (screen[b,a] = 2) then move:=false;
X if (screen[b,a] = 1) and (screen[b,a+1] = 2) then move:=false;
X end;
X end;
X if move = true then
X begin
X shapestuff(shape,position,y,x,screen,0);
X x:=x+d;
X shapestuff(shape,position,y,x,screen,2);
X printshape(screen,y,x);
X end;
Xend;
X{************************************************************************}
V{*****************************************************************************
X}
Vprocedure Down(var screen:screenarray; shape,position:integer; var y,x:integer
X;
X var fast:boolean);
X
X
Xvar
X move:boolean;
X a,
X b:integer;
X
Xbegin
X move:=true;
X for b:=y+3 downto y-1 do
X for a:= x+2 downto x-2 do
X if (a >0) and (a<11) and (b > 1) and (b < 23) then
X begin
X if (b = 22) and (screen[b,a] = 2) then move:=false;
X if (screen[b,a] = 1) and (screen[b-1,a] = 2) then move:=false;
X end;
X if move = true then
X begin
X if fast = true then
X begin
X y:=y+1;
X shapestuff(shape,position,y-1,x,screen,0);
X printshape(screen,y,x);
X shapestuff(shape,position,y,x,screen,2);
X repeat
X move:=true;
X for b:=y+3 downto y-1 do
X for a:= x+2 downto x-2 do
X if (a >0) and (a<11) and (b > 1) and (b < 23) then
X begin
X if (b = 22) and (screen[b,a] = 2) then move:=false;
X if (screen[b,a] = 1) and (screen[b-1,a] = 2 ) then move:=false;
X end;
X if move = true then
X begin
X y:=y+1;
X shapestuff(shape,position,y-1,x,screen,0);
X shapestuff(shape,position,y,x,screen,2);
X end;
X until move=false;
X printshape(screen,y,x);
X end
X else
X begin
X y:=y+1;
X screen[y-1,x]:=0;
X screen[y,x]:=2;
X shapestuff(shape,position,y-1,x,screen,0);
X shapestuff(shape,position,y,x,screen,2);
X printshape(screen,y,x);
X end;
X end;
X fast:=false;
Xend;
X{************************************************************************}
X
Xprocedure printall(screen:screenarray; score,lines,level:integer);
X
X
Xvar
X a,
X b:integer;
X g,
X h,
X xchrhigh,
X xchrlow,
X ychrhigh,
X ychrlow:char;
X stuff:packed array[1..10] of char;
X
Xbegin
X
X cls;
X for I:=1 to 22 do
X begin
X intochar(g,h,ychrhigh,ychrlow,1,I);
X writeln(chr(27),'[',ychrhigh,ychrlow,';30H| |');
X end;
X writeln(chr(27),'[23;30H------------');
X if flag then writeln(chr(27),'[03;49HNEXT');
X writeln(chr(27),'[10;1HSCORE:',score:1);
X writeln(chr(27),'[12;1HLEVEL:',level:1);
X writeln(chr(27),'[14;1HLINES:',((5*level)-lines):2);
X for a:=1 to 22 do
X begin
X intochar(xchrhigh,xchrlow,ychrhigh,ychrlow,31,a);
X for b:=1 to 10 do
X begin
X if screen[a,b] = 1 then stuff[b]:='#'
X else
X stuff[b]:=' ';
X end;
X writeln(chr(27),'[',ychrhigh,ychrlow,';31H',stuff);
X end;
Xend;
V{*****************************************************************************
X*}
X
V{*****************************************************************************
X*}
Xprocedure editshape(key:integer; var nshape:integer);
X
X
Xbegin
X nshape:=key-48;
X printnext(nshape);
Xend;
V{*****************************************************************************
X*}
X{***********************************************}
Xprocedure getyearday(inp:datestr; var year,day:integer);
X
Xvar
X digit1,
X digit2,
X digit3,
X digit4:integer;
X offset:integer;
X
Xbegin
X offset:= ord('1') + 1;
X digit1:= ord(inp[8]) - offset;
X digit2:= ord(inp[9]) - offset;
X digit3:= ord(inp[10]) - offset;
X digit4:= ord(inp[11]) - offset;
X year:= digit4 + (10*digit3) + (100*digit2) + (1000*digit1);
X digit1:= ord(inp[1]) - offset;
X digit2:= ord(inp[2]) - offset;
X day:= digit2 + (10*digit1);
Xend;
X{************************************************}
X
X{**********************************************}
Xprocedure getmonth(inp:datestr; var month:integer);
X
Xbegin
X
X if (inp[4] = 'J') and (inp[5] = 'A') then month:=1
X else
X if (inp[4] = 'F') then month:=2
X else
X if (inp[4] = 'M') and (inp[6] = 'R') then month:=3
X else
X if (inp[4] = 'A') and (inp[5] = 'P') then month:=4
X else
X if (inp[4] = 'M') and (inp[6] = 'Y') then month:=5
X else
X if (inp[4] = 'J') and (inp[6] = 'N') then month:=7
X else
X if (inp[4] = 'J') then month:=6
X else
X if (inp[4] = 'A') and (inp[5] = 'U') then month:=8
X else
X if (inp[4] = 'S') then month:=9
X else
X if (inp[4] = 'O') then month:=10
X else
X if (inp[4] = 'N') then month:=11
X else
X if (inp[4] = 'D') then month:=12;
Xend;
X
V{*****************************************************************************
X*}
V{*****************************************************************************
X*}
Xfunction older(one,two:datestr):boolean;
X
X
Xvar
X oneyear,
X twoyear,
X onemonth,
X twomonth,
X oneday,
X twoday:integer;
X
Xbegin
X getyearday(one,oneyear,oneday);
X getyearday(two,twoyear,twoday);
X getmonth(one,onemonth);
X getmonth(two,twomonth);
X if oneyear < twoyear then older:=true
X else
X if onemonth < twomonth then older:=true
X else
X if oneday < twoday then older:=true
X else
X older:=false;
Xend;
V{*****************************************************************************
X*}
V{*****************************************************************************
X*}
X
X
V{*****************************************************************************
X*}
V{*****************************************************************************
X*}
XProcedure MainGame(left,right,rotleft,rotright,speed,quitkey,redraw:char;
X level:integer; cheat:boolean);
X
Xvar
X oldest:integer;
X saved,
X saving:saverec;
X count:integer;
X quit:boolean;
X a,b:integer;
X height:integer;
X choice:char;
X nx,
X ny,
X nshape,
X nposition:integer;
X fast:boolean;
X gotin:boolean;
X
Xbegin
X
Xrandomise;
Xif restored = false then
Xbegin
X for a:=1 to 22 do
X for b:=1 to 10 do
X screen[a,b]:=0;
X score:=0;
X position:=1;
X create(shape,position,y,x);
X lines:=0;
X shapestuff(shape,position,y,x,screen,2);
Xend;
Xcreate(nshape,nposition,ny,nx);
Xcount:=0;
Xfast:=false;
Xquit:=false;
Xott:=false;
Xcls;
X
Xprintshape(screen,y,x);
Xprintall(screen,score,lines,level);
Xif restored then
X writeln(chr(27),'[10;49HPress any key to continue game')
Xelse
X writeln(chr(27),'[10;49HPress any key to play game');
Xwaitkey(key,chan);
Xwriteln(chr(27),'[10;49H ');
Xrestored:=false;
Xif flag then printnext(nshape);
Xrepeat
X readkey(key,chan);
X choice:=chr(key);
X if choice = left then Movement(screen,shape,position,y,x,-1)
X else
X if choice = right then movement(screen,shape,position,y,x,1)
X else
X if choice = rotleft then Rotation(screen,shape,position,-1,y,x)
X else
X if choice = rotright then Rotation(screen,shape,position,1,y,x)
X else
X if choice = speed then fast:=true
X else
X if (choice in ['1'..'7']) and (cheat = true) then editshape(key,nshape)
X else
X if choice = redraw then
X begin
X printall(screen,score,lines,level);
X if flag then printnext(nshape);
X end
X else
X if choice = quitkey then ott:=true
X else
X if choice = '!' then
X begin
X cls;
X writeln('%DCL-I-SPAWN, Type eoj to return to Shapes');
X spawn;
X printall(screen,score,lines,level);
X if flag then printnext(nshape);
X writeln(chr(27),'[10;49HPress any key to continue Shapes');
X waitkey(key,chan);
X writeln(chr(27),'[10;49H ');
X end
X else
X if choice = '@' then
X begin
X cls;
X Writeln( 'Save game option');
X usernum(userid);
X if (userid = 'CADP02 ') or
X (userid = 'CADP03 ') then
X begin
X write('Enter username, MAX 8 letters, RETURN for default: ');
X userid:=' ';
X readln(userid);
X if userid[1] = ' ' then usernum(userid);
X end;
X saving.num:=score;
X saving.level:=level;
X saving.outp:=screen;
X saving.lines:=lines;
X saving.x:=x;
X saving.y:=y;
X saving.shape:=shape;
X saving.position:=position;
X saving.user:=userid;
X DATE(saving.current);
X open(Save,Savefile,history:=readonly);
X reset(save);
X del:=false;
X for I:=1 to 100 do
X begin
X read(save,peeps[I]);
X if (del = true) and (peeps[I].user = saving.user) then
X peeps[I].user:='UNUSED ';
X if (del = false) and (peeps[I].user = 'UNUSED ') then
X begin
X peeps[I]:=saving;
X del:=true;
X end;
X if (del = false) and (peeps[I].user = saving.user) then
X begin
X del:=true;
X peeps[I]:=saving;
X end;
X end;
X if del = false then
X begin
X reset(save);
X read(save,peeps[1]);
X oldest:=1;
X for I:=2 to 100 do
X begin
X read(save,peeps[I]);
X if older(peeps[I-1].current,peeps[I].current) = false then
X oldest:=I;
X end;
X peeps[oldest]:=saving;
X end;
X close(save);
X open(Save,Savefile,history:=old);
X rewrite(save);
X for I:=1 to 100 do
X write(save,peeps[I]);
X close(save);
X ott:=true;
X del:=false;
X writeln('Game saved.');
X writeln('Press any key for main menu.');
X waitkey(key,chan);
X end;
X if count = 3 then
X begin
X height:=y;
X Down(screen,shape,position,y,x,fast);
X if height = y then
X begin
X for a:=1 to 10 do
X if screen[1,a]=2 then ott:=true;
X shapestuff(shape,position,y,x,screen,1);
X printshape(screen,y,x);
X linestuff(screen,lines,level,score);
X shape:=Nshape;
X position:=Nposition;
X y:=Ny;
X x:=Nx;
X create(nshape,nposition,ny,nx);
X if flag then printnext(nshape);
X shapestuff(shape,position,y,x,screen,2);
X if lines >= 5*level then
X begin
X level:=level+1;
X bonus(score,screen,level);
X lines:=0;
X printall(screen,score,lines,level);
X if flag then printnext(nshape);
X end;
X end;
X count:=0;
X end;
X count:=count+1;
Xuntil OTT = true;
X
Xif choice <> '@' then
Xbegin
X highscores(score,level,Htable,scores,gotin);
X if gotin then viewscores(Htable,scores,key,chan)
Xend
Xend;
V{*****************************************************************************
X*}
V{*****************************************************************************
X*}
X
V{*****************************************************************************
X*}
V{*****************************************************************************
X*}
XProcedure RESTORE;
X
Xvar
X I:integer;
X
Xbegin
X cls;
X writeln(' Restore saved game option');
X usernum(userid);
X if (userid = 'CADP02 ') or
X (userid = 'CADP03 ') then
X begin
X write('Enter username, MAX 8 letters, RETURN for default: ');
X userid:=' ';
X readln(userid);
X if userid[1] = ' ' then usernum(userid);
X end;
X restored:=false;
X open(Save,Savefile,history:=readonly);
X reset(save);
X for I:=1 to 100 do
X begin
X read(save,peeps[I]);
X if peeps[I].user = userid then
X begin
X cls;
X writeln('Restoring...');
X lines:=peeps[I].lines;
X position:=peeps[I].position;
X x:=peeps[I].x;
X y:=peeps[I].y;
X shape:=peeps[I].shape;
X screen:=peeps[I].outp;
X score:=peeps[I].num;
X level:=peeps[I].level;
X peeps[I].user:='UNUSED ';
X restored:=true;
X end;
X end;
X close(save);
X open(save,savefile,history:=old);
X rewrite(save);
X for I:=1 to 100 do
X write(save,peeps[I]);
X close(save);
X if restored = true then
X begin
X writeln('Restored.');
X writeln('Press any key for main screen');
X waitkey(key,chan);
X MAINGAME(left,right,rotleft,rotright,speed,quitkey,redraw,level,cheat);
X end
X else
X begin
X writeln('Data file not found.');
X writeln('Press any key to return to main menu.');
X waitkey(key,chan);
X end;
Xend;
X
V{*****************************************************************************
X*}
V{*****************************************************************************
X*}
X
X{*******************************************************************}
Xbegin {SHAPES}
X cls;
X MAKECHAN(chan);
X HP := FALSE;
X flag:=true;
X flag2:=false;
X cheat:=false;
X left:='z';right:='x';rotleft:='o';rotright:='p';speed:='[';quitkey:='q';
X factor:=0.15;
X redraw:='r';
X levelmin:=1;
X for I:=1 to 22 do
X begin {for}
X for J:=1 to 10 do
X screen[I,J]:=0;
X end; {for}
X repeat
X MENUPRINT;
X repeat
X if chr(key) = 'c' then flagA:=true;
X if chr(key) = 'a' then
X begin
X if flagA = true then flagB:=true
X else flagB:=false;
X end;
X if chr(key) = 'd' then
X begin
X if flagB = true then flagC:=true
X else flagC:=false;
X end;
X if chr(key) = 'p' then
X begin
X if flagC = true then flagD:=true
X else flagD:=false;
X end;
X if (chr(key) <> 'c') and (chr(key) <> 'a') and
X (chr(key) <> 'd') and (chr(key) <> 'p') then
X begin
X flagA:=false;
X flagB:=false;
X flagC:=false;
X flagD:=false;
X end;
X waitkey(key,chan);
X until chr(key) in ['0'..'8'];
X level:=levelmin;
X if chr(key) <> '8' then flagD:=false;
X if chr(key)='1' then
X MAINGAME(left,right,rotleft,rotright,speed,quitkey,redraw,level,cheat);
V if chr(key)='2' then KEYDEFINE(left,right,rotleft,rotright,speed,quitkey,r
Xedraw);
X if chr(key)='3' then VIEWSCORES(Htable,scores,key,chan);
X if chr(key)='4' then INSTRUCTIONS;
X if chr(key)='5' then flag:=not(flag);
X if chr(key)='6' then flag2:=not(flag2);
X if chr(key)='7' then RESTORE;
X if flagD then
X begin
X cheat:=true;
X write('level??: ');
X readln(levelmin);
X write('reset savefile??: ');
X readln(answer);
X if (answer = 'y') or (answer = 'Y') then
X begin
X blank.user:='UNUSED ';
X open(Save,Savefile,history:=unknown);
X rewrite(save);
X for I:=1 to 100 do
X write(save,blank);
X close(save);
X end;
X write('reset scoreboard??: ');
X readln(answer);
X if (answer='y') or (answer ='Y') then
X begin
X open (Htable , Htablefile ,
X`009 history := unknown);
X rewrite(Htable);
X for A:= 1 to 10 do
X begin
X scores[A].num:=0;
X scores[A].name:=' ';
X scores[A].level:=1;
X scores[A].id:=' ';
X end;
X for A:=1 to 10 do
X write(Htable,scores[A]);
X close(Htable);
X end;
X end;
X until (chr(key)='0');
X cls;
X writeln('There now, that didn''t hurt much did it??');
X writeln('Byeeeeeeeeee........');
Xend. {SHAPES}
X{*******************************************************************}
X
$GoSub Convert_File
$Exit