paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-20 11:09:42 +02:00
Code Issues Packages Projects Releases Wiki Activity

* updates from marco

Browse Source
This commit is contained in:
peter 1999-06-01 19:24:32 +00:00
parent 192966b0a7
commit 469745aae7
4 changed files with 874 additions and 358 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

316
install/demo/fpctris.pp
View File

@ -35,7 +35,7 @@ TheHeight-1
}
Uses Crt,Dos;
Uses Crt,Dos,GameUnit;
{$dEFINE DoubleCache} {Try to write as less characters to console as possible}
@ -51,11 +51,6 @@ CONST TheWidth = 11; {Watch out, also correct RowMask!}
TYPE TetrisFieldType = ARRAY [0..25] OF LONGINT;
LevelInfoType = ARRAY [0..NrLevels-1] OF LONGINT;
FigureType = LONGINT; { actually array[0..3][0..3] of bit rounded up to a longint}
HighScoreType = Packed RECORD
Name : String[12];
Score: LONGINT;
END;
HighScoreArr = ARRAY[0..9] OF HighScoreType;
CHARSET = SET OF CHAR;
{The figures: }
@ -98,16 +93,7 @@ in binary, and put 5 bits on a row. }
LeftMask : ARRAY[0..4] OF LONGINT = ($84210800,$C6318C00,$E739CE00,$F7BDEF00,$FFFFFFE0);
RightMask: ARRAY[0..4] OF LONGINT = ($08421080,$18C63180,$39CE7380,$7BDEF780,$FFFFFF80);
{Some key-codes. Return value of ReadKey. If value is zero (functionkey) then
code=ReadKey SHL 8}
ArrU = $04800; ArrL = $04B00; ArrR = $04D00; BS = $08; (* Backspace *)
ArrD = $05000; CR = $0D; ESC = $1B; KDelete= $05300;
KInsert= $05200; Home = $04700; KEnd = $04F00; CtrlY = $19;
CtrlT = $14;
{Allowed characters entering highscores}
AlfaBeta : CHARSET= [' '..'z'];
{This constant/parameter is used to detect a certain bug. The bug was fixed, but
I use the constant to remind where the bug was, and what is related to eachother.}
@ -126,11 +112,6 @@ them}
ColorString = #196#179#192#217#219;
DumbTermStr = '-|..*';
{The variables. If people feel they are missing, I first checked the Alias, and
then filled with names of the FPC-Devel list.}
InitNames : ARRAY[0..9] OF String[12] = ('Carl','Daniel','Florian','Jonas','Lee','Marco','Michael (3x)',
'Peter','Pierre','Thomas' );
{ A multiplication factor to reward killing more then one line with one figure}
ProgressiveFactor : ARRAY[1..5] OF LONGINT = (10,12,16,22,30);
@ -159,202 +140,12 @@ VAR
NrFiguresLoaded : LONGINT; {Total figures available in GraphFigures}
CurrentCol : LONGINT; {Color of current falling piece}
UseColor : BOOLEAN; {Color/Mono mode}
DefColor : BYTE; {Backup of startup colors}
Level : LONGINT; {The current level number}
Style : String; {Contains all chars to create the field}
nonupdatemode : BOOLEAN; {Helpmode/highscore screen or game mode}
HelpMode : BOOLEAN;
NextFigure : LONGINT; {Next figure to fall}
Score : LONGINT; {The score}
HighScore : HighScoreArr;
ScorePath : String;
FUNCTION GetKey:LONGINT;
VAR InKey: LONGINT;
BEGIN
InKey:=ORD(ReadKey);
IF InKey=0 THEN InKey:=ORD(ReadKey) SHL 8;
GetKey:=InKey;
END;
FUNCTION InputStr(VAR S:String;X,Y,Len:LONGINT;TextIn:BOOLEAN;CharAllow:CHARSET):BOOLEAN;
{
Input a string from keyboard, in a nice way,
allowed characters are in CHARSET CharAllow, but several editting
keys are always allowed, see CASE loop.
Parameters:
X,Y Coordinates field
Len Length field
TextIn S already filled?}
VAR
InGev : LONGINT; { No. of chars inputted }
Posi : LONGINT; { Cursorposition}
Ins : BOOLEAN; { Insert yes/no}
Key : LONGINT; { Last key as ELib.GetKey
code <255 if normal key,
>256 if special/function
key. See keys.inc}
Uitg : String; {The inputted string}
Full : BOOLEAN; { Is the string full? }
EndVal : WORD;
PROCEDURE ReWr; { Rewrite the field, using Uitg}
VAR I : LONGINT; { Temporary variabele }
BEGIN
IF Length(Uitg)>Len THEN
Uitg[0]:=CHR(Len);
IF Length(Uitg)>0 THEN
FOR I:= 1 TO Length(Uitg) DO
BEGIN
GotoXY(X+I-1,Y);
IF Uitg[I]=CHR(32) THEN
Write(CHR(FieldSpace))
ELSE
Write(Uitg[I]);
END;
IF Len<>Length(Uitg) THEN
BEGIN
GotoXY(X+Length(Uitg),Y);
FOR I:= Length(Uitg) TO Len-1 DO
Write(CHR(FieldSpace));
END;
END;
PROCEDURE DoCursor; { Put Cursor in/out insert-mode }
BEGIN
{$IFNDEF Linux}
{ IF Ins THEN
SetCursorSize($11E)
ELSE
SetCursorSize($71E); }
{$ENDIF}
END;
BEGIN
{ Init }
InGev :=0; { 0 chars untill now }
Posi :=1; { Cursorposition 0 }
Ins :=TRUE; { Insert according to parameters }
DoCursor; { Set cursor accordingly }
Key :=0;
{ put ±±± padded field on screen }
FillChar(Uitg,Len+1,CHR(FieldSpace));
Uitg[0]:=CHR(Len);
ReWr;
GotoXY(X,Y);
FillChar(Uitg,Len,32);
UitG[0]:=#0;
IF TextIn THEN
BEGIN
Uitg:=S;
Posi:=Length(Uitg)+1; { Put a predefined }
ReWr; { String on screen if specified }
END;
EndVal:=0;
WHILE EndVal=0 DO
BEGIN
Full:=FALSE;
IF ((Posi)>=Len) THEN
BEGIN
Full:=TRUE;
Posi:=Len;
END;
GotoXY(X+Posi-1,Y);
{$IFNDEF Linux}
{$IFDEF FPC}
CursorOn;
{$ENDIF}
DoCursor;
{$ENDIF}
Key:=GetKey;
{$IFNDEF Linux}
{$IFDEF FPC}
CursorOff;
{$ENDIF}
{$ENDIF}
CASE Key OF
CR : BEGIN
EndVal:=1;
S:=UitG;
END;
ESC : EndVal:=2;
BS : IF Posi>1 THEN { BackSpace }
BEGIN
DEC(Posi);
Delete(Uitg,Posi,1);
DEC(InGev);
ReWr;
END;
KDelete : BEGIN
Delete(Uitg,Posi,1);
DEC(InGev);
ReWr;
END;
ArrR : IF (NOT Full) AND ((Posi-1)<InGev) THEN
BEGIN
INC (Posi);
GotoXY(X+Posi-1,Y);
END;
KInsert : BEGIN
Ins:= NOT Ins;
DoCursor;
END;
ArrL : IF (NOT (Posi=1)) THEN
BEGIN
DEC (Posi);
GotoXY(X+Posi-1,Y);
END;
Home : Posi:=1;
KEnd : Posi:=InGev-1;
CtrlY : BEGIN
Delete(Uitg,Posi,Length(Uitg)-Posi);
ReWr;
END;
CtrlT : BEGIN
Uitg[0]:=#0; Posi:=1; ReWr;
END;
END; {Case}
IF EndVal=0 THEN
BEGIN
IF (CHR(Key) IN CharAllow) THEN
BEGIN
IF Posi>Len THEN
Posi:=Len;
IF (Ins=FALSE) OR Full THEN
BEGIN
IF (ORD(Uitg[0])<Posi) THEN
Uitg[0]:=CHR(Posi);
Uitg[Posi]:=CHR(Key);
END
ELSE
BEGIN
Insert(CHR(Key),Uitg,Posi);
{ InsertC(uitg,CHR(Key),Posi);}
END;
ReWr;
INC(Posi);
END;
END;
InGev:=Length(Uitg);
END;
InputStr:=Endval=1;
END;
FUNCTION RRotate(Figure:FigureType;ColumnsToDo:LONGINT):FigureType;
@ -741,11 +532,8 @@ END;
PROCEDURE FixScores;
BEGIN
IF UseColor THEN
BEGIN
TextColor(DefColor AND 15);
TextBackground(DefColor SHR 4);
END;
IF UseColor THEN
SetDefaultColor;
GotoXY(40,18);
Write('Score :',Score);
END;
@ -784,7 +572,7 @@ BEGIN
ShowNextFigure(NextFigure);
CurrentCol:=RANDOM(14)+1;
END;
{
PROCEDURE ShowHighScore;
VAR I : LONGINT;
@ -797,7 +585,7 @@ BEGIN
Write(HighScore[I].Name,' ':(13-Length(HighScore[I].Name)),' ',HighScore[I].Score:5);
END;
END;
}
PROCEDURE ShowGameMode;
BEGIN
@ -819,10 +607,9 @@ but the text, and the cadre around the playfield}
VAR I : LONGINT;
BEGIN
TextColor(DefColor AND 15);
TextBackground(DefColor SHR 4);
SetDefaultColor;
GotoXY(40,4);
Write('FPCTris v0.06, (C) by the FPC team.');
Write('FPCTris v0.07, (C) by the FPC team.');
GotoXY(40,6);
Write('A demo of the FPC Crt unit, and');
GotoXY(40,7);
@ -950,7 +737,6 @@ VAR I,J : LONGINT;
S : String;
BEGIN
I:=0;
FOR J:=9 TO 22 DO
BEGIN
GotoXY(40,J);
@ -960,27 +746,16 @@ BEGIN
TextColor(White);
GotoXY(40,23);
Writeln('Game Over, score = ',Score);
WHILE (Score>HighScore[I].Score) AND (I<10) DO
INC(I);
I:=SlipInScore(Score);
IF I<>0 THEN
BEGIN
IF I>1 THEN
FOR J:=0 TO I-2 DO
HighScore[J]:=HighScore[J+1];
HighScore[I-1].Score:=Score;
HighScore[I-1].Name:='';
NonUpdateMode:=TRUE;
HelpMode:=FALSE;
ShowHighScore;
InputStr(S,40,21-I,10,FALSE,AlfaBeta);
HighScore[I-1].Name:=S;
ShowHighScore;
END
ELSE
BEGIN
ShowHighScore;
END;
ShowHighScore;
END;
{$IFNDEF FPC}
@ -1012,10 +787,11 @@ BEGIN
{$ELSE}
UseColor:=TRUE;
{$ENDIF}
DefColor:=TextAttr; { Save the current attributes, to restore}
ClrScr;
CursorOff;
RANDOMIZE;
HighX:=40;
HighY:=9;
CreateFiguresArray; { Load and precalculate a lot of stuff}
IF UseColor THEN
Style:= ColorString
@ -1103,8 +879,7 @@ BEGIN
ORD('q'),
ESC : BEGIN
TextColor(DefColor AND 15);
TextBackground(DefColor SHR 4);
SetDefaultColor;
GotoXY(1,25);
EndGame:=TRUE;
END;
@ -1116,8 +891,7 @@ ORD('C'),
Style:= ColorString
ELSE
BEGIN
TextColor(DefColor AND 15);
TextBackground(DefColor SHR 4);
SetDefaultColor;
Style:=DumbTermStr;
END;
CreateFrame;
@ -1153,10 +927,7 @@ ORD('E'),
NrFigures:=7; {Standard Tetris figures}
CalculateTotalChance; {Recalculate weight-totals}
IF UseColor THEN
BEGIN
TextColor(DefColor AND 15);
TextBackground(DefColor SHR 4);
END;
SetDefaultColor;
ShowGameMode;
END;
@ -1219,69 +990,28 @@ ORD('p') : BEGIN {"p" : Pause}
UNTIL EndGame;
FixHighScores;
CursorOn;
TextColor(DefColor AND 15);
TextBackground(DefColor SHR 4);
SetDefaultColor;
GotoXY(1,25);
END;
CONST FileName='fpctris.scr';
Procedure LoadHighScore;
var
F: File;
I : LONGINT;
VAR I : LONGINT;
BEGIN
{$I-}
Assign(F, FileName);
FileMode := 0; {Set file access to read only }
Reset(F);
Close(F);
{$I+}
IF IOResult=0 THEN
ScorePath:=FileName
ELSE
ScorePath:=FSearch(FileName,GetEnv('PATH'));
IF ScorePath='' THEN
BEGIN
FOR I:=0 TO 9 DO
BEGIN
HighScore[I].Name:=InitNames[I];
HighScore[I].Score:=(I+1)*750;
END;
ScorePath:=FileName;
END
ELSE
BEGIN
Assign(F,ScorePath);
Reset(F,1);
BlockRead(F,HighScore,SIZEOF(HighScoreArr));
Close(F);
END;
END;
Procedure SaveHighScore;
var
F: File;
BEGIN
Assign(F,ScorePath);
Rewrite(F,1);
BlockWrite(F,HighScore,SIZEOF(HighScoreArr));
Close(F);
END;
BEGIN
LoadHighScore;
FOR I:=0 TO 9 DO
HighScore[I].Score:=(I+1)*750;
LoadHighScore(FileName);
DoFpcTris;
SaveHighScore;
END.
{
$Log$
Revision 1.1 1999-05-27 21:36:33 peter
Revision 1.2 1999-06-01 19:24:32 peter
* updates from marco
Revision 1.1 1999/05/27 21:36:33 peter
* new demo's
* fixed mandel for linux

160
install/demo/fpctris.txt Normal file
View File

@ -0,0 +1,160 @@
The FPC games docs...
The FPC-games are a series of small console games written by Marco van de Voort
(Marcov@stack.nl) as demos for the Free Pascal compiler (FPC) and its Run Time
Libraries (RTL).
SameGame can also use the API for mousecontrol. This because the RTL mouseunit
MsMouse only exists under Go32V2. The API mouse routines work with Linux, but
have (right now) a problem with GPM version 1.17. Use a different version if you
can 1.15 works according to the developpers.
Currently the games are
- FPCTris (v0.07)
- Samegame (v0.02)
Copyright
---------
The source code is donated to the FPC project. The FPC project distributes all
sources under a modified GNU license (much like the so called LGPL) see
copying.fpc.
Future
--------
- Some cards games (BlackJack, Poker, and two Dutch games called "Rikken" and
"Toepen") are in preparation
- A server for Linux, so that Linux clients can connect to it for multiplayer
services. One server for all games, otherwise small games like this clog up
the number of free ports ;-)
This is also important because most of the cardsgames (except BlackJack)
can't be played against the computer, the AI is to difficult. (Poker is maybe
also possible)
---------
FPCTRIS
Fpctris is a tetris class game, originally designed
- to be distributed with FPC as Crt demo,
- Keeping possible integration in the IDE in mind (would add 15k or so)
- Svgalib version etc etc. Anyway, the engine is quite platform independant,
and can be ported to different platforms (also TUI,GUI) if needed.
The current versions are still under development, but already playable even
under telnet.
TODO list:
- (difficult, also interesting for Crt and IDE), get more terminals supported under
Linux. Specially I don't want to issue the escape sequence that rapes your console
to an IBM compat charset. Linux users don't like that. (temporarily solved by
doing this only on user request)
- (Linux) Sockets multiplayer client system :-). Have actually started on it,
but are getting nowhere. The server will be separate and support more than
one game. So you get one port for several games.
- Setup screen ((create) alternate blocks etc)
- Commandline options/config file. (.rctetris per user :-))
KNOWN BUGS:
- Upperrow not used with some chars. (Requires shifting up). Possibly related
that very rarely game over appears when there's still one or two rows to go.
(Since the 5x5 version some of this has been removed. If you get a L-shaped
character and immediately rotate, the upper line is used)
- Biggest problem at the moment is the delay procedure and its init on machines
under heavy load. Can't change that though. Only under heavy load, so a
less big problem on heavy machines.
- Selection of colors don't take screen attribs into account. So figures can
seem to disappear on weird TTY's or 4Dos people using strange ANSI prompts.
History:
v0.00 First version with working gameplay, created during the Brussels meeting.
published on tflily.
v0.01 Some work done, first version on my page. Most improvements done in
Brussels, to many to name here.
v0.02 - Got rid of binary encoding, and calculating shapes etc when a new figure
is created. All is done on startup now. Adding characters is simpler now.
- A lot of parameters are variables instead of constants.
- Experienced tetrissers press "e" once.
- Colors! Linux has the color default off (press "C")
v0.03 (Only used on on stack, not on web)
- Keep on pushing arrow down no longer freezes FPCTris.
- Basic level system implemented.
- High ascii background in color mode.
v0.04 (Only used on on stack, not on web)
- The push-down arrow fix removed the possibility to move the character
after arrow-down, which I liked much. Fixed. # of possible moves after
arrow-down also adjustable.
- Tried compiling with W32 compiler. RTE 216 (which is gpf I believe)
Is Crt unit. Hello World "Use crt" also gpf's.
- Removed the first, forgotten bugfix for the hickup problem. Now the
"feel" of the game is ok. When you push down, it goes down, but you
have the change to do one more move.
v0.05 (Never used anywere, backup version before movement to 5x5 figures)
- More Score info
- Help possiblity
- Highscores. (also saved to file, and searched in the path)
- Entering highscores uses inputstr. Size boosts to 1200 lines. Yuck.
- Most functionality now implemented.
v0.06 (To Peter)
- 5x5 figures including "The Cross". Worked almost rightaway, but figures
rotate a bit weird.
- Better rotation 5x5 system. Only smallest square around figure is
rotated.
- Better scores. Incl quadratic (progressive is a better word) scores for
multiple lines. Now it does matter if you remove 2 x 1 line or 2
lines at once.
- Some small other fixes.
- 'q' is also exit.
v0.07 - Highscore table routines moved to gameunit. Gameunit.pp now required.
----------
SameGame.
Principle copied from KDE/GNOME.
The principle: The playfield is a grid consisting out of 3 colors.
You can mark a certain spot on the playfield, and all adjacent grid-cubes
(horizontally or vertically) will also get marked by the computer.
When you press the left button, and two or more cubes are marked, the marked
cubes will disappear, and the playfield will colapse to the bottom left.
This can be repeated until there are no more agregates. If the field is empty
then, you receive a bonus.
The trick is that the score for each disappearing aggregate of cubes is more
than linear (0.25* quadratic right now) dependant on the number of cubes it
contains.
This means that removing 5 times an aggregate of 2 cubes will result in a far
smaller score than one aggregate of 10 cubes. ( 5*2^2 < 10^2)
TODO:
[none]
BUGS:
- Maybe better algoritm for initial filling of playfield.
- Runtime sizable playfield.
HISTORY:
v0.01 :
- Initial version.
- Slightly improved initial algoritm.
v0.02 - Using gameunit. GPM support via API, but whole thing GPF's under Linux,
but works under Go32V2.
- Highscores,helpscreen, all small things that come with a decent finishing
of the concept

460
install/demo/gameunit.pp Normal file
View File

@ -0,0 +1,460 @@
{
$Id$
A simple unit with some common used routines for FPCGames (FpcTris and
SameGame)
Contains
- Highscore routines "developped" for FPCTris, but now also used by SameGame
- "Dummy" mouse routines which either shell to API units or to MSMouse.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
UNIT GameUnit;
INTERFACE
{MouseAPI defined : unit unes API mouse units, which requires that package,
but also works under Linux
MouseAPI undef : RTL unit MsMouse. API not required, but doesn't work under
Linux }
{$UNDEF MouseAPI}
TYPE CHARSET=SET OF CHAR;
{---- Unified Mouse procedures. ---- }
FUNCTION MousePresent : BOOLEAN;
PROCEDURE HideMouse;
PROCEDURE ShowMouse;
PROCEDURE GetMouseState(VAR MX,MY,MState : LONGINT);
PROCEDURE DoneMouse;
PROCEDURE InitMouse;
Const LButton = 1; {left button}
RButton = 2; {right button}
MButton = 4; {middle button}
{---- Standard Highscore procedures ----}
TYPE HighScoreType = Packed RECORD
Name : String[12];
Score: LONGINT;
END;
HighScoreArr = ARRAY[0..9] OF HighScoreType;
VAR HighScore : HighScoreArr;
ScorePath : String;
HighX,HighY : LONGINT;
PROCEDURE LoadHighScore(FileName:STRING);
PROCEDURE SaveHighScore;
PROCEDURE ShowHighScore;
FUNCTION SlipInScore(Score:LONGINT):LONGINT;
{---- Keyboard routines ----}
CONST {Constants for GetKey}
ArrU = $04800; ArrL = $04B00; ArrR = $04D00; BS = $08; (* Backspace *)
ArrD = $05000; CR = $0D; ESC = $1B; KDelete= $05300;
KInsert= $05200; Home = $04700; KEnd = $04F00; CtrlY = $19;
CtrlT = $14;
CONST FieldSpace : CHAR = #177;
AlfaBeta : CHARSET= [' '..'z'];
FUNCTION GetKey:LONGINT;
{Generic string input routine}
FUNCTION InputStr(VAR S:String;X,Y,Len:LONGINT;TextIn:BOOLEAN;CharAllow:CHARSET):BOOLEAN;
{---- Misc ----}
PROCEDURE SetDefaultColor; {Restore the attribs saved on startup}
IMPLEMENTATION
{$IFDEF MouseAPI}
Uses Mouse,Dos,Crt;
{$ELSE}
Uses MsMouse,Dos,Crt;
{$ENDIF}
VAR DefColor : BYTE; {Backup of startup colors}
CONST
{The initial names. If people feel they are missing, I first checked the Alias,
and then filled with names of the FPC-Devel list, and arranged them alfabetically}
InitNames : ARRAY[0..9] OF String[12] = ('Carl','Daniel','Florian','Jonas','Lee','Marco','Michael (3x)',
'Peter','Pierre','Thomas' );
{$IFDEF MouseAPI}
VAR MouseBuffer : LONGINT;
{$ENDIF}
FUNCTION MousePresent : BOOLEAN;
BEGIN
{$IFDEF MouseAPI}
MousePresent:=DetectMouse<>0;
{$ELSE}
MousePresent:=MouseFound;
{$ENDIF}
END;
PROCEDURE ShowMouse;
BEGIN
{$IFDEF MouseAPI}
Mouse.ShowMouse;
{$ELSE}
MsMouse.ShowMouse;
{$ENDIF}
END;
PROCEDURE HideMouse;
BEGIN
{$IFDEF MouseAPI}
Mouse.HideMouse;
{$ELSE}
MsMouse.HideMouse;
{$ENDIF}
END;
PROCEDURE InitMouse;
BEGIN
{$IFDEF MouseAPI}
Mouse.InitMouse;
{$ELSE}
MsMouse.InitMouse;
{$ENDIF}
END;
PROCEDURE DoneMouse;
BEGIN
{$IFDEF MouseAPI}
Mouse.DoneMouse;
{$ENDIF}
END;
PROCEDURE GetMouseState(VAR MX,MY,MState : LONGINT);
{$IFDEF MouseAPI}
VAR MouseEvent : TMouseEvent;
{$ENDIF}
BEGIN
{$IFDEF MouseAPI}
GetMouseEvent(MouseEvent);
MX:=MouseEvent.X SHL 3;
MY:=MouseEvent.Y SHL 3;
MState:=MouseEvent.Buttons;
{$ELSE}
MsMouse.GetMouseState(MX,MY,MState);
{$ENDIF}
END;
Procedure LoadHighScore(FileName:STRING);
var
F: File;
I : LONGINT;
BEGIN
{$I-}
Assign(F, FileName);
FileMode := 0; {Set file access to read only }
Reset(F);
Close(F);
{$I+}
IF IOResult=0 THEN
ScorePath:=FileName
ELSE
ScorePath:=FSearch(FileName,GetEnv('PATH'));
IF ScorePath='' THEN
BEGIN
FOR I:=0 TO 9 DO
BEGIN
HighScore[I].Name:=InitNames[I];
HighScore[I].Score:=(I+1)*750;
END;
ScorePath:=FileName;
END
ELSE
BEGIN
Assign(F,ScorePath);
Reset(F,1);
BlockRead(F,HighScore,SIZEOF(HighScoreArr));
Close(F);
END;
END;
Procedure SaveHighScore;
var
F: File;
BEGIN
Assign(F,ScorePath);
Rewrite(F,1);
BlockWrite(F,HighScore,SIZEOF(HighScoreArr));
Close(F);
END;
FUNCTION SlipInScore(Score:LONGINT):LONGINT;
VAR I,J : LONGINT;
BEGIN
I:=0;
WHILE (Score>HighScore[I].Score) AND (I<10) DO
INC(I);
IF I<>0 THEN
BEGIN
IF I>1 THEN
FOR J:=0 TO I-2 DO
HighScore[J]:=HighScore[J+1];
HighScore[I-1].Score:=Score;
HighScore[I-1].Name:='';
END;
SlipInScore:=I;
END;
PROCEDURE ShowHighScore;
VAR I : LONGINT;
{HighX=40 HighY=9}
BEGIN
GotoXY(HighX+5,9); Write('The Highscores');
FOR I:=0 TO 9 DO
BEGIN
GotoXY(HighX,HighY+11-I);
Write(HighScore[I].Name,' ':(13-Length(HighScore[I].Name)),' ',HighScore[I].Score:5);
END;
END;
FUNCTION GetKey:LONGINT;
VAR InKey: LONGINT;
BEGIN
InKey:=ORD(ReadKey);
IF InKey=0 THEN InKey:=ORD(ReadKey) SHL 8;
GetKey:=InKey;
END;
FUNCTION InputStr(VAR S:String;X,Y,Len:LONGINT;TextIn:BOOLEAN;CharAllow:CHARSET):BOOLEAN;
{
Input a string from keyboard, in a nice way,
allowed characters are in CHARSET CharAllow, but several editting
keys are always allowed, see CASE loop.
Parameters:
X,Y Coordinates field
Len Length field
TextIn S already filled?}
VAR
InGev : LONGINT; { No. of chars inputted }
Posi : LONGINT; { Cursorposition}
Ins : BOOLEAN; { Insert yes/no}
Key : LONGINT; { Last key as ELib.GetKey
code <255 if normal key,
>256 if special/function
key. See keys.inc}
Uitg : String; {The inputted string}
Full : BOOLEAN; { Is the string full? }
EndVal : WORD;
PROCEDURE ReWr; { Rewrite the field, using Uitg}
VAR I : LONGINT; { Temporary variabele }
BEGIN
IF Length(Uitg)>Len THEN
Uitg[0]:=CHR(Len);
IF Length(Uitg)>0 THEN
FOR I:= 1 TO Length(Uitg) DO
BEGIN
GotoXY(X+I-1,Y);
IF Uitg[I]=CHR(32) THEN
Write(FieldSpace)
ELSE
Write(Uitg[I]);
END;
IF Len<>Length(Uitg) THEN
BEGIN
GotoXY(X+Length(Uitg),Y);
FOR I:= Length(Uitg) TO Len-1 DO
Write(FieldSpace);
END;
END;
PROCEDURE DoCursor; { Put Cursor in/out insert-mode }
BEGIN
{$IFNDEF Linux}
{ IF Ins THEN
SetCursorSize($11E)
ELSE
SetCursorSize($71E); }
{$ENDIF}
END;
BEGIN
{ Init }
InGev :=0; { 0 chars untill now }
Posi :=1; { Cursorposition 0 }
Ins :=TRUE; { Insert according to parameters }
DoCursor; { Set cursor accordingly }
Key :=0;
{ put ±±± padded field on screen }
FillChar(Uitg,Len+1,FieldSpace);
Uitg[0]:=CHR(Len);
ReWr;
GotoXY(X,Y);
FillChar(Uitg,Len,32);
UitG[0]:=#0;
IF TextIn THEN
BEGIN
Uitg:=S;
Posi:=Length(Uitg)+1; { Put a predefined }
ReWr; { String on screen if specified }
END;
EndVal:=0;
WHILE EndVal=0 DO
BEGIN
Full:=FALSE;
IF ((Posi)>=Len) THEN
BEGIN
Full:=TRUE;
Posi:=Len;
END;
GotoXY(X+Posi-1,Y);
{$IFNDEF Linux}
{$IFDEF FPC}
CursorOn;
{$ENDIF}
DoCursor;
{$ENDIF}
Key:=GetKey;
{$IFNDEF Linux}
{$IFDEF FPC}
CursorOff;
{$ENDIF}
{$ENDIF}
CASE Key OF
CR : BEGIN
EndVal:=1;
S:=UitG;
END;
ESC : EndVal:=2;
BS : IF Posi>1 THEN { BackSpace }
BEGIN
DEC(Posi);
Delete(Uitg,Posi,1);
DEC(InGev);
ReWr;
END;
KDelete : BEGIN
Delete(Uitg,Posi,1);
DEC(InGev);
ReWr;
END;
ArrR : IF (NOT Full) AND ((Posi-1)<InGev) THEN
BEGIN
INC (Posi);
GotoXY(X+Posi-1,Y);
END;
KInsert : BEGIN
Ins:= NOT Ins;
DoCursor;
END;
ArrL : IF (NOT (Posi=1)) THEN
BEGIN
DEC (Posi);
GotoXY(X+Posi-1,Y);
END;
Home : Posi:=1;
KEnd : Posi:=InGev-1;
CtrlY : BEGIN
Delete(Uitg,Posi,Length(Uitg)-Posi);
ReWr;
END;
CtrlT : BEGIN
Uitg[0]:=#0; Posi:=1; ReWr;
END;
END; {Case}
IF EndVal=0 THEN
BEGIN
IF (CHR(Key) IN CharAllow) THEN
BEGIN
IF Posi>Len THEN
Posi:=Len;
IF (Ins=FALSE) OR Full THEN
BEGIN
IF (ORD(Uitg[0])<Posi) THEN
Uitg[0]:=CHR(Posi);
Uitg[Posi]:=CHR(Key);
END
ELSE
BEGIN
Insert(CHR(Key),Uitg,Posi);
{ InsertC(uitg,CHR(Key),Posi);}
END;
ReWr;
INC(Posi);
END;
END;
InGev:=Length(Uitg);
END;
InputStr:=Endval=1;
END;
PROCEDURE SetDefaultColor;
BEGIN
TextColor(DefColor AND 15);
TextBackground(DefColor SHR 4);
END;
BEGIN
{$IFDEF MouseAPI}
MouseBuffer:=0;
{$ENDIF}
DefColor:=TextAttr; { Save the current attributes, to restore}
END.
{
$Log$
Revision 1.1 1999-06-01 19:24:33 peter
* updates from marco
}

296
install/demo/samegame.pp
View File

@ -20,8 +20,7 @@
**********************************************************************}
PROGRAM SameGame;
Uses Crt,MsMouse;
Uses Crt,GameUnit;
CONST FieldX = 10; {Top left playfield coordinates}
FieldY = 3; {Top left playfield coordinates}
@ -52,20 +51,95 @@ BEGIN
END;
END;
VAR MarkField,PlayField : PlayFieldType;
CubesMarked : LONGINT;
Score : LONGINT;
PROCEDURE ShowHelp;
{Shows some explanation of the game and waits for a key}
VAR I : LONGINT;
BEGIN
FOR I:=2 TO 24 DO
BEGIN
GotoXY(1,I);
ClrEol;
END;
GotoXY(1,3); TextColor(White);
Write('SAMEGAME');
SetDefaultColor;
WriteLn(' is a small game, with a principle copied from some KDE game');
WriteLn;
WriteLn('I tried to implement it under Go32V2 to demonstrate the MsMouse unit');
Writeln('When it worked, I tried to get it running under Linux. I succeeded,');
Writeln('but the mouse unit of the API doesn'#39't work with GPM 1.17');
Writeln;
WriteLn('If you move over the playfield, aggregates of one color will be marked');
Writeln('in purple. If you then press the left mouse button, that aggregate will');
Writeln('disappear, and the playfield will collapse to the bottom-left. Please');
Writeln('keep in mind that only an aggregate of two blocks or more will disappear.');
Writeln;
Writeln('For every aggregate you let disappear you get points, but the score is');
Writeln('quadratic proportional to the number of blocks killed. So 4 times killing');
Writeln(' a 4 block aggregate scores 4 points, and one time 16 blocks will score 64');
Writeln('blocks. The purpose of the game is obtaining the highscore');
Writeln;
Writeln('If you manage to kill the entire playfield, you'#39'll get a bonus');
Writeln;
WriteLn('Press any key to get back to the game');
GetKey;
END;
VAR MarkField,PlayField : PlayFieldType; {The playfield, and the marked form}
CubesMarked : LONGINT; {Cubes currently marked}
Score : LONGINT; {The current score}
LastScore : LONGINT;
PROCEDURE ShowButtons;
{Shows the clickable buttons}
BEGIN
TextColor(Yellow); TextBackGround(Blue);
GotoXY(60,5); Write('NEW game');
GotoXY(60,6); Write('HELP');
GotoXY(60,7); Write('END game');
{$IFDEF Linux}
GotoXY(60,8); Write('Force IBM charset');
{$ENDIF}
SetDefaultColor;
END;
FUNCTION PlayFieldPiecesLeft:LONGINT;
{Counts pieces/cubes/blocks left on the playfield}
VAR I,J,K : LONGINT;
BEGIN
K:=0;
FOR I:=0 TO PlayFieldXDimension-1 DO
FOR J:=0 TO PlayFieldYDimension-1 DO
IF PlayField[I,J]<>3 THEN
INC(K);
PlayFieldPiecesLeft:=K;
END;
PROCEDURE ShowScore;
{Simply procedure to update the score}
BEGIN
TextColor(White);
GotoXY(20,23); Write(' ':20);
GotoXY(20,23); Write('Score : ',Score);
SetDefaultColor;
END;
FUNCTION CubesToScore : LONGINT;
{Function to calculate score from the number of cubes. Should have a higher
order than linear, or the purpose of the game disappears}
BEGIN
CubesToScore:=(CubesMarked*CubesMarked) DIV 2;
CubesToScore:=(CubesMarked*CubesMarked) DIV 4;
END;
PROCEDURE MarkAfield(X,Y:LONGINT);
{Recursively marks the area adjacent to (X,Y);
{Recursively marks the area adjacent to (X,Y);}
VAR TargetColor : LONGINT;
@ -100,28 +174,28 @@ PROCEDURE FillPlayfield;
{Initial version, probably not nice to play with.
Some Life'ish algoritm would be better I think. (so that more aggregates exist)}
VAR X,Y : LONGINT;
VAR X,Y,Last,Now : LONGINT;
BEGIN
FOR Y:=0 TO PlayFieldYDimension-1 DO
FOR X:=0 TO PlayFieldXDimension-1 DO
PlayField[X,Y]:=RANDOM(3);
Last:=0;
FOR X:=0 TO PlayFieldXDimension-1 DO
FOR Y:=0 TO PlayFieldYDimension-1 DO
BEGIN
Now:=RANDOM(4);
IF Now=3 THEN
Now:=Last;
PlayField[X,Y]:=Now;
Last:=Now;
END;
MarkField:=PlayField;
END;
PROCEDURE ShowScore;
{Simply procedure to update the score}
BEGIN
TextColor(White);
GotoXY(20,23);
Write(' ':20);
GotoXY(20,23);
Write('Score : ',Score);
END;
PROCEDURE Colapse;
{Processes the playfield if the mouse button is used}
{Processes the playfield if the mouse button is used.
First the procedure deletes the marked area, and let gravity do its work
Second the procedure uses as if some gravity existed on the left of the
playfield }
VAR X, Y,J :LONGINT;
@ -159,72 +233,164 @@ BEGIN
END;
END;
PROCEDURE BuildScreen;
{Some procedures that build the screen}
BEGIN
ClrScr; Score:=0;
ShowScore;
ShowButtons;
ShowHighScore;
ShowMouse;
GotoXY(1,1);
TextColor(Yellow);
Write('SameGame v0.02');
TextColor(White);
Write(' A demo for the ');
TextColor(Yellow); Write('FPC');
TextColor(White); Write(' API or MsMouse unit. By Marco van de Voort');
SetDefaultColor;
IF LastScore<>0 THEN
BEGIN
GotoXY(10,20);
Write('The score in the last game was :',LastScore);
END;
DisplayPlayField(PlayField);
MarkField:=PlayField;
END;
PROCEDURE DoMainLoopMouse;
{The main game loop. The entire game runs in this procedure, the rest is
initialisation/finalisation (like loading and saving highscores etc etc)}
VAR X,Y,
MX,MY,MState,Dummy : LONGINT;
EndOfGame : LONGINT;
S : String;
BEGIN
MarkField:=PlayField;
RANDOMIZE;
REPEAT
GetMouseState(MX,MY,MState);
X:=MX SHR 3;
Y:= MY SHR 3;
IF (X>=(FieldX-2)) AND (Y>=(FieldY-2)) THEN
BEGIN
DEC(X,FieldX-1); DEC(Y,FieldY-1);
X:=X SHR 1;
IF (X<PlayFieldXDimension) AND (Y<PlayFieldYDimension) THEN
FillPlayField;
BuildScreen;
EndOfGame:=0;
REPEAT
GetMouseState(MX,MY,MState);
X:=MX SHR 3;
Y:=MY SHR 3;
IF PlayFieldPiecesLeft=0 THEN
BEGIN
INC(Score,1000);
EndOfGame:=1;
END
ELSE
BEGIN
IF (X>=60) AND (X<=69) THEN
BEGIN
IF (MState AND LButton) <>0 THEN {If leftbutton pressed,}
BEGIN
IF Y=4 THEN
EndOfGame:=1;
IF Y=6 THEN
EndOfGame:=2;
IF (EndOfGame>0) AND (PlayFieldPiecesLeft=0) THEN
INC(Score,1000);
IF Y=5 THEN
BEGIN
ShowHelp;
BuildScreen;
END;
{$IFDEF Linux}
IF Y=7 THEN
BEGIN
write(#27+'(K');
BuildScreen;
END;
{$ENDIF}
END;
END;
IF (X>=(FieldX-2)) AND (Y>=(FieldY-2)) THEN
BEGIN
IF MarkField[X,Y]<>4 THEN
DEC(X,FieldX-1); DEC(Y,FieldY-1);
X:=X SHR 1;
IF (X<PlayFieldXDimension) AND (Y<PlayFieldYDimension) THEN
BEGIN
MarkField:=PlayField;
MarkAfield(X,Y);
DisplayPlayField(MarkField);
TextColor(White);
GotoXY(20,22);
Write(' ':20);
GotoXY(20,22);
Write('Marked :',CubesToScore);
END;
IF (MState AND LButton) <>0 THEN {If leftbutton pressed,}
BEGIN
REPEAT {wait untill it's released.
IF MarkField[X,Y]<>4 THEN
BEGIN
MarkField:=PlayField;
MarkAfield(X,Y);
DisplayPlayField(MarkField);
TextColor(White);
GotoXY(20,22);
Write(' ':20);
GotoXY(20,22);
Write('Marked :',CubesToScore);
END;
IF (MState AND LButton) <>0 THEN {If leftbutton pressed,}
BEGIN
REPEAT {wait untill it's released.
The moment of pressing counts}
GetMouseState(X,Y,Dummy);
UNTIL (Dummy AND LButton)=0;
Colapse;
MarkField:=PlayField;
END;
END;
GetMouseState(X,Y,Dummy);
UNTIL (Dummy AND LButton)=0;
Colapse;
MarkField:=PlayField;
DisplayPlayField(MarkField);
END;
END;
END;
IF KeyPressed THEN
BEGIN
X:=GetKey;
IF (X=ORD('X')) OR (X=ORD('x')) THEN
EndOfGame:=2;
END;
END;
UNTIL (MState AND RButton) =RButton;
UNTIL EndOfGame>0;
ShowScore;
X:=SlipInScore(Score);
IF X<>0 THEN
BEGIN
ShowHighScore;
InputStr(S,HighX,HighY+12-X,10,FALSE,AlfaBeta);
HighScore[X-1].Name:=S;
END;
LastScore:=Score;
UNTIL EndOFGame=2;
END;
CONST FileName='samegame.scr';
VAR I : LONGINT;
BEGIN
IF NOT MouseFound THEN
IF NOT MousePresent THEN
BEGIN
Writeln('No mouse found. A mouse is required!');
HALT;
END;
ShowMouse;
FOR I:=1 TO 10 DO
HighScore[I].Score:=I*1500;
LoadHighScore(FileName);
InitMouse;
CursorOff;
HighX:=52; HighY:=10; {the position of the highscore table}
RANDOMIZE;
ClrScr; Score:=0;
ShowScore;
GotoXY(1,1);
TextColor(Yellow);
Write('SameGame v0.01');
TextColor(White);
Write(' A demo for the FPC MsMouse unit. By Marco van de Voort');
FillPlayField;
DisplayPlayField(PlayField);
DoMainLoopMouse;
HideMouse;
DoneMouse;
CursorOn;
SaveHighScore;
ClrScr;
Writeln;
Writeln('Last games'#39' score was : ',Score);
END.
{
$Log$
Revision 1.1 1999-05-27 21:36:34 peter
Revision 1.2 1999-06-01 19:24:33 peter
* updates from marco
Revision 1.1 1999/05/27 21:36:34 peter
* new demo's
* fixed mandel for linux