* updates from marco

install/demo/fpctris.pp

@@ -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;
-
-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;
+VAR I : LONGINT;
 
 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
 

install/demo/fpctris.txt

@@ -0,0 +1,160 @@
+The FPC games docs...
+
+The FPC-games are a series of small console games written by Marco van de Voort
+([email protected]) 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
+

install/demo/gameunit.pp

@@ -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
+
+}

install/demo/samegame.pp

@@ -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 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;
- UNTIL (MState AND RButton) =RButton;
+  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