1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, Menus, Buttons;

type
  TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    Label1: TLabel;
    lblPlayer: TLabel;
    MainMenu1: TMainMenu;
    Datei1: TMenuItem;
    Beenden1: TMenuItem;
    Info1: TMenuItem;
    Autoren1: TMenuItem;
    Hilfe1: TMenuItem;
    Spielregeln1: TMenuItem;
    FAQ1: TMenuItem;
    BitBtn1: TBitBtn;
    Panel1: TPanel;
    procedure FormCreate(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure btnNewGameClick(Sender: TObject);
    procedure btnAboutClick(Sender: TObject);
    procedure Autoren1Click(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure Beenden1Click(Sender: TObject);
    procedure Spielregeln1Click(Sender: TObject);
    procedure FAQ1Click(Sender: TObject);
  private
    { Private declarations }
    FPlayer: Cardinal;
    procedure NewGame;
  public
    { Public declarations }
  end;

const
  APPNAME = 'Vier gewinnt';
  VER = '1.0';
  INFO_TEXT = APPNAME + ' ' + VER + #13#10 +
    'Copyright © 2004'+ #13#10#13#10 +'Alexander Dietrich' + #13#10 +'Bastian Abel'+ #13#10 +'Ewald Klassen'+ #13#10 +'David Braschos';
  REGELN = 'Spielregeln:' + #13#10#13#10 +'1. Das Ziel des Spiels ist es, 4 oder mehr Steine in einer Reihe anzuordnen.' + #13#10#13#10 +'2. Die Steine können entweder vertikal, horizontal oder diagonal gestapelt werden.' + #13#10#13#10 + '3. Ein Spiel gilt als Unentschieden, wenn kein Spieler 4 oder mehr Steine stapeln konnte und das Spielfeld voll ist.';
  FAQ = 'FAQ' + #13#10#13#10 +'1. Wie wird das Spiel bedient ?' + #13#10#13#10 +'- Um ein neues Spiel zu starten genügt ein Klick auf "Neues Spiel".' +#13#10 + '- Um einen Stein zu setzen, muss die linke Maustaste gedrückt werden.'+#13#10+'- Abwechselnd kann man so gelbe und rote Spielsteine setzen.'+#13#10+'- Die Steine können jeweils in einen der 7 Schächte geworfen werden.';
var
  Form1: TForm1;

implementation

{$R *.dfm}

uses
  Unit2;

var
  FourInARow: TFourInARow;

procedure TForm1.NewGame;
begin
  FreeAndNIl(FourInARow);
  FourInARow := TFourInARow.Create(Paintbox1);
  FPlayer := 1;
  lblPlayer.Caption:= 'Spieler '+IntToStr(FPlayer);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.Title := APPNAME;
  Caption := APPNAME;
  NewGame;
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  FourInARow.DrawField;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FreeAndNil(FourInARow);
end;

procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  TempPlayer: Integer;
begin
  tempPlayer := FPlayer;
  if not FourInARow.SetStone(FPlayer, x) then
    ShowMessage('ungültiger Zug')
  else
  begin
    case FPlayer of
      1: FPlayer := 2;
      2: FPlayer := 1;
    end;
  end;
  if FourInARow.Gewonnen(TempPlayer) then
    ShowMessage('Spieler '+IntToStr(TempPlayer)+' hat gewonnen.');
  lblPlayer.Caption:= 'Spieler '+IntToStr(FPlayer);
end;

procedure TForm1.btnNewGameClick(Sender: TObject);
begin
  NewGame;
end;

procedure TForm1.btnAboutClick(Sender: TObject);
begin
  MessageBox(Handle, INFO_TEXT, APPNAME, MB_ICONINFORMATION);
end;

procedure TForm1.Autoren1Click(Sender: TObject);
begin
  MessageBox(Handle, INFO_TEXT, APPNAME, MB_ICONINFORMATION);
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
  NewGame;
end;

procedure TForm1.Beenden1Click(Sender: TObject);
begin
close;
end;

procedure TForm1.Spielregeln1Click(Sender: TObject);
begin
     MessageBox(Handle, REGELN, APPNAME, MB_ICONQUESTION);
end;


procedure TForm1.FAQ1Click(Sender: TObject);
begin
  MessageBox(Handle, FAQ, APPNAME, MB_ICONEXCLAMATION);
end;

end.					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:

unit Unit2;

interface

uses
  windows, SysUtils, Graphics, Types, ExtCtrls, Dialogs;

const
  CIRCLEDIAMETRE = 40;
  CIRCLEFRAMECOLOR = clBlack;
  CIRCLECOLOR = clWhite;
  PLAYERONECOLOR = clRed;
  PLAYERTWOCOLOR = clYellow;
  COLUMNS = 7;
  ROWS = 6;

type
  TFourInARow = class(TObject)
  private
    OffScreenBmp: TBitmap;
    FPaintbox: TPaintbox;
    Field: array[0..COLUMNS - 1, 0..ROWS - 1] of Cardinal;
    procedure DrawCircle(Canvas: TCanvas; Center: TPoint; Diametre: Integer);
    procedure DrawSeparator(Canvas: TCanvas; x: Cardinal);
    function GetColumn(x: Cardinal): Cardinal;
  public
    constructor Create(PaintBox: TPaintBox);
    destructor Destroy; override;
    function SetStone(Player: Cardinal; x: Cardinal): Boolean;
    procedure DrawField;
    function Gewonnen(Spieler: Cardinal): Boolean;
  end;

implementation

{-------------------------------------------------------------------------------
  Description:
  zeichnet die Kreise des Spielfeldes
-------------------------------------------------------------------------------}

procedure TFourInARow.DrawCircle(Canvas: TCanvas; Center: TPoint; Diametre:
  Integer);
begin
  Canvas.Ellipse(Center.X - CIRCLEDIAMETRE div 2, Center.Y - CIRCLEDIAMETRE div
    2, Center.X + CIRCLEDIAMETRE div 2, Center.Y + CIRCLEDIAMETRE div 2);
end;

{-------------------------------------------------------------------------------
  Description:
  Zeichnet die senkrechten Trennlinien
-------------------------------------------------------------------------------}

procedure TFourInARow.DrawSeparator(Canvas: TCanvas; x: Cardinal);
begin
  Canvas.Pen.Color := clcream;
  Canvas.MoveTo(x, 0);
  Canvas.LineTo(x, OffScreenBmp.Height - CIRCLEDIAMETRE);
end;

{-------------------------------------------------------------------------------
  Description:
  Konstruktor. Erstellen des offscreen Bitmaps
-------------------------------------------------------------------------------}

constructor TFourInARow.Create(Paintbox: TPaintBox);
var
  c, r: Integer;
  rec: TRect;
begin
  inherited Create;
  FPaintbox := PaintBox;
  OffScreenBmp := TBitmap.Create;
  OffScreenBmp.Width := FPaintbox.Width;
  OffScreenBmp.Height := FPaintBox.Height;
  rec.Left := 0;
  rec.Top := 0;
  rec.Right := OffScreenBmp.Width;
  rec.Bottom := OffScreenBmp.Height;
  OffScreenBmp.Canvas.Brush.Color := clBtnFace;
  OffScreenBmp.Canvas.FillRect(rec);
  for c := 0 to COLUMNS - 1 do
    for r := 0 to ROWS - 1 do
      Field[c, r] := 0;
  DrawField;
end;

{-------------------------------------------------------------------------------
  Description:
  Destruktor. Zerstören des offscreen Bitmaps.
-------------------------------------------------------------------------------}

destructor TFourInARow.Destroy;
begin
  FreeAndNil(OffScreenBmp);
  inherited;
end;

{-------------------------------------------------------------------------------
  Description:
  Ermittelt über Mauskoordinaten die Spalte
-------------------------------------------------------------------------------}

function TFourInARow.GetColumn(x: Cardinal): Cardinal;
begin
  result := x div (OffScreenBmp.Width div COLUMNS);
end;

{-------------------------------------------------------------------------------
  Description:
  Fügt ein Stein in das Speilfeld-Array ein
-------------------------------------------------------------------------------}

function TFourInARow.SetStone(Player: Cardinal; x: Cardinal): Boolean;
var
  c, r: Integer;
begin
  result := False;
  c := GetColumn(x);
  for r := ROWS - 1 downto 0 do
  begin
    if Field[c, r] = 0 then
    begin
      Field[c, r] := Player;
      result := True;
      break;
    end;
  end;
  DrawField;
end;

{-------------------------------------------------------------------------------
  Description:
  Zeichnet das Spielfeld mit den Steinen
-------------------------------------------------------------------------------}

procedure TFourInARow.DrawField;
var
  pt: TPoint;
  x: Cardinal;
  c, r: Integer;
begin
  x := 0;
  for c := 0 to COLUMNS - 1 do
  begin
    OffScreenBmp.Canvas.Pen.Color := CIRCLEFRAMECOLOR;
    for r := 0 to ROWS - 1 do
    begin
      pt.X := OffScreenBmp.Width div COLUMNS * c + (OffScreenBmp.Width div
        COLUMNS div 2);
      pt.Y := OffScreenBmp.Height div ROWS * r + (CIRCLEDIAMETRE div 2);
      case Field[c, r] of
        0: OffScreenBmp.Canvas.Brush.Color := CIRCLECOLOR;
        1: OffScreenBmp.Canvas.Brush.Color := PLAYERONECOLOR;
        2: OffScreenBmp.Canvas.Brush.Color := PLAYERTWOCOLOR;
      end;
      DrawCircle(OffScreenBmp.Canvas, pt, CIRCLEDIAMETRE);
    end;
    if c < (COLUMNS - 1) then
      x := OffScreenBmp.Width div COLUMNS * (c + 1);
    DrawSeparator(OffScreenBmp.Canvas, x);
  end;
  BitBlt(FPaintbox.Canvas.Handle, 0, 0, FPaintBox.Width, FPaintbox.Height,
    OffScreenBmp.Canvas.Handle, 0, 0, SRCCOPY);
end;

{-------------------------------------------------------------------------------
  Description: Gewinnprüfung
  Author: w3seek
-------------------------------------------------------------------------------}

function TFourInARow.Gewonnen(Spieler: Cardinal): Boolean;
const
  N_GEWINNT = 4;

  function GewinntReihe(Spalte, Zeile, Delta, Max: Integer): Boolean;
  var
    Anfang, Pos, Ende: PCardinal;
    c, i: Integer;
  begin
    Result := false;
    // wir holen uns die adresse des punktes von dem aus wir das spielfeld betrachten, das ist der linke bzw obere spielrand
    Pos := @Field[Spalte, Zeile];
    // wir holen uns die adressen der punkte ueber bzw unter die wir nicht gehen duerfen
    Anfang := @Field[0, 0];
    Ende := @Field[COLUMNS - 1][ROWS - 1];
    c := 0;
    i := 0;

    // diese schleife so lange ausfuehren bis die aktuelle position ausserhalb des spielfelds gesetzt wurde
    while (Cardinal(Pos) <= Cardinal(Ende)) and (Cardinal(Pos) >=
      Cardinal(Anfang)) do
    begin
      // ist der gesuchte spieler an der aktuellen stelle?
      if Pos^ = Spieler then
      begin
        // wir zaehlen hoch, wie viele punkte hintereinander schon ohne unterbrechnung waren
        Inc(c);
        if c = N_GEWINNT then
        begin
          // ok, wir haben genau N_GEWINNT punkte in folge, der spieler hat gewonnen!
          Result := true;
          Exit;
        end;
      end
      else
      begin
        // ok, der punkt ist nicht gesetzt oder gehoert nicht zu dem gesuchten spieler, wir setzen den counter zurueck
        c := 0;
      end;
      // wir springen zum naechsten punkt der getestet wird. je nachdem in welche richtung wir gehen und wie weit, gibt delta an.
      Inc(Pos, Delta);
      // fuer zeilen und spalten brauchen wir ein maximum um nicht in die naechste zeile/spalte zu gelangen!
      if Max > 0 then
      begin
        Inc(i);
        // Schleife unterbrechen, wenn wir das Maximum ueberschritten haben
        if i >= Max then
        begin
          Exit;
        end;
      end;
    end;
  end;

var
  i: Integer;
begin
  Result := false;

  // wir laufen von der linken oberen zur rechten oberen spielecke
  for i := 0 to COLUMNS - 1 do
  begin
       // sind in dieser spalte 4 aufeinanderfolgende punkte des spielers?
       // der abstand zum naechsten punkt (der direkt unter dem ausgangspunkt liegt)
       // ist die anzahl der punkte in einer zeile. Wir pruefen nur N_ZEILEN punkte in der spalte!
    if GewinntReihe(i, 0, 1, ROWS) or
       // N_SPALTEN + 1 ist der abstand zum naechsten punkt unterhalb und rechts von diesem punkt, also um 1 groesser
       // als das spielfeld spalten hat, wir setzen keine maximale anzahl an punkten die zu pruefen sind, also Max=0
    GewinntReihe(i, 0, ROWS + 1, 0) or
       // N_SPALTEN - 1 ist der abstand zum naechsten punkt unterhalb und links von diesem punkt, also um genau 1 kleiner
       // als das spielfeld spalten hat, wir setzen keine maximale anzahl an punkten die zu pruefen sind, also Max=0
    GewinntReihe(i, 0, ROWS - 1, 0) then
    begin
      Result := true;
      Exit;
    end;
  end;

  // wir laufen von der linken oberen spielecke zur linken unteren spielecke
  for i := 0 to ROWS - 1 do
  begin
       // sind in dieser zeile 4 aufeinanderfolgende punkte des spielers?
       // der abstand zum naechsten punkt in der zeile ist 1, wir pruefen maximal N_SPALTEN punkte in der zeile
    if GewinntReihe(0, i, ROWS, COLUMNS) or
       // -(N_SPALTEN - 1) ist der abstand zum naechsten punkt der rechts oben (diagonal) liegt, der abstand ist
       // also negativ und um 1 geringer als das spielfeld spalten hat, wir setzen keine maximale anzahl an punkten die zu pruefen sind, also Max=0
    GewinntReihe(0, i, -(ROWS - 1), 0) or
       // N_SPALTEN + 1 ist der abstand zum naechsten punkt rechts unten (diagonal), der abstand ist also positiv
       // und um 1 groesser als das spielfeld spalten hat, wir setzen keine maximale anzahl an punkten die zu pruefen sind, also Max=0
    GewinntReihe(0, i, ROWS + 1, 0) then
    begin
      Result := true;
      Exit;
    end;
  end;
end;

end.					

1:
2:
3:
4:
5:
6:
7:

const
  APPNAME = 'Vier gewinnt';
  VER = '1.0';
  INFO_TEXT = APPNAME + ' ' + VER + #13#10 +
    'Copyright © 2004 Michael Puff' + #13#10#13#10 +
    'http://www.luckie-online.de'+#13#10#13#10+
    'Gewinnprüfung von w3seek.';					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:

const
  CIRCLEDIAMETRE = 50;
  CIRCLEFRAMECOLOR = clBlack;
  CIRCLECOLOR = clWhite;
  PLAYERONECOLOR = clRed;
  PLAYERTWOCOLOR = clYellow;
  COLUMNS = 7;
  ROWS = 6;

type
  TFourInARow = class(TObject)
  private
    OffScreenBmp: TBitmap;
    FPaintbox: TPaintbox;
    Field: array[0..COLUMNS - 1, 0..ROWS - 1] of Cardinal;
    procedure DrawCircle(Canvas: TCanvas; Center: TPoint; Diametre: Integer);
    procedure DrawSeparator(Canvas: TCanvas; x: Cardinal);
    function GetColumn(x: Cardinal): Cardinal;
  public
    constructor Create(PaintBox: TPaintBox);
    destructor Destroy; override;
    function SetStone(Player: Cardinal; x: Cardinal): Boolean;
    procedure DrawField;
    function Gewonnen(Spieler: Cardinal): Boolean;
  end;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:

{-------------------------------------------------------------------------------
  Description:
  Konstruktor. Erstellen des offscreen Bitmaps
-------------------------------------------------------------------------------}

constructor TFourInARow.Create(Paintbox: TPaintBox);
var
  c, r: Integer;
  rec: TRect;
begin
  inherited Create;
  FPaintbox := PaintBox;
  OffScreenBmp := TBitmap.Create;
  OffScreenBmp.Width := FPaintbox.Width;
  OffScreenBmp.Height := FPaintBox.Height;
  rec.Left := 0;
  rec.Top := 0;
  rec.Right := OffScreenBmp.Width;
  rec.Bottom := OffScreenBmp.Height;
  OffScreenBmp.Canvas.Brush.Color := clBtnFace;
  OffScreenBmp.Canvas.FillRect(rec);
  for c := 0 to COLUMNS - 1 do
    for r := 0 to ROWS - 1 do
      Field[c, r] := 0;
  DrawField;
end;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:

{*******************************************************************************

 Project       : Vier Gewinnt - TFourInARow Klasse
 Compiler Ver. : Delphi 6 Personal
 Author        : Michael Puff
 URL           : www.luckie-online.de
 Copyright     : Copyright (c) 2004 Michael Puff

 Version       : 2004-06-29 - 1.0
                 first release

           When I die I want 'Hello, world' carved on my headstone.

*******************************************************************************}

{*******************************************************************************

 Copyright (c) 2001-2003, Michael Puff ["copyright holder(s)"]
 All rights reserved.

 Redistribution and use in source and binary forms, with or without
 modification, are permitted provided that the following conditions are met:

 1. Redistributions of source code must retain the above copyright notice, this
    list of conditions and the following disclaimer.
 2. Redistributions in binary form must reproduce the above copyright notice,
    this list of conditions and the following disclaimer in the documentation
    and/or other materials provided with the distribution.
 3. The name(s) of the copyright holder(s) may not be used to endorse or
    promote products derived from this software without specific prior written
    permission.

 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
 DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY
 DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
 (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
 ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*******************************************************************************}