Develop and Download Open Source Software

reversi-of-d

Browse Subversion Repository

/[reversi-of-d]/Unit1.pas

Diff of /Unit1.pas

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 13 by yamat0jp, Tue Jul 14 00:24:36 2015 UTC revision 24 by yamat0jp, Sun Jul 19 01:35:48 2015 UTC
# Line 12  const Line 12  const
12    Count = 8;    Count = 8;
13    
14  type  type
15    TStoneType = (stNone, stWhite, stBlack, stError);    TStoneType = (stNone, stWhite, stBlack, stError, stEffect);
16    
17      TEffectData = record
18        X, Y: integer;
19        Left, Top: integer;
20        Stone: TStoneType;
21      end;
22    
23    TGridData = array [0 .. Count - 1] of array [0 .. Count - 1] of TStoneType;    TGridData = array [0 .. Count - 1] of array [0 .. Count - 1] of TStoneType;
24    
# Line 32  type Line 38  type
38      FTurnNumber: integer;      FTurnNumber: integer;
39      FTurnIndex: integer;      FTurnIndex: integer;
40      FActive: Boolean;      FActive: Boolean;
41        FList: TList;
42        FEffectStone: TStoneType;
43        FBool: Boolean;
44        FTerminated: Boolean;
45        FIndex_X: integer;
46        FIndex_Y: integer;
47      function GetStrings(X, Y: integer): TStoneType;      function GetStrings(X, Y: integer): TStoneType;
48      procedure SetStrings(X, Y: integer; const Value: TStoneType);      procedure SetStrings(X, Y: integer; const Value: TStoneType);
49      procedure SetTurnNumber(const Value: integer);      procedure SetTurnNumber(const Value: integer);
50    public    public
51        constructor Create;
52        destructor Destroy; override;
53      procedure Clear;      procedure Clear;
54      function CalScore(Stone: TStoneType; X, Y: integer): integer;      function CalScore(Stone: TStoneType; X, Y: integer): integer;
55      function CanSetStone(Stone: TStoneType; X, Y: integer; Reverse: Boolean;      function CanSetStone(Stone: TStoneType; X, Y: integer; Reverse: Boolean;
# Line 44  type Line 58  type
58      procedure Start;      procedure Start;
59      procedure Restart;      procedure Restart;
60      procedure Pause;      procedure Pause;
61        function ListExecute: Boolean;
62        procedure Paint(Canvas: TCanvas);
63        procedure ImageCount(X, Y: integer);
64      property Strings[X, Y: integer]: TStoneType read GetStrings      property Strings[X, Y: integer]: TStoneType read GetStrings
65        write SetStrings; default;        write SetStrings; default;
66      property TurnNumber: integer read FTurnNumber write SetTurnNumber;      property TurnNumber: integer read FTurnNumber write SetTurnNumber;
# Line 66  type Line 83  type
83      MenuItem10: TMenuItem;      MenuItem10: TMenuItem;
84      MenuItem11: TMenuItem;      MenuItem11: TMenuItem;
85      MenuItem12: TMenuItem;      MenuItem12: TMenuItem;
86        Timer2: TTimer;
87        Image1: TImage;
88        Image2: TImage;
89        Image3: TImage;
90        Image4: TImage;
91        Image5: TImage;
92      procedure FormCreate(Sender: TObject);      procedure FormCreate(Sender: TObject);
93      procedure FormDestroy(Sender: TObject);      procedure FormDestroy(Sender: TObject);
94      procedure Timer1Timer(Sender: TObject);      procedure Timer1Timer(Sender: TObject);
# Line 81  type Line 104  type
104      procedure MenuItem8Click(Sender: TObject);      procedure MenuItem8Click(Sender: TObject);
105      procedure MenuItem10Click(Sender: TObject);      procedure MenuItem10Click(Sender: TObject);
106      procedure MenuItem11Click(Sender: TObject);      procedure MenuItem11Click(Sender: TObject);
107        procedure Timer2Timer(Sender: TObject);
108        procedure FormDeactivate(Sender: TObject);
109        procedure FormActivate(Sender: TObject);
110    private    private
111      { Private 宣言 }      { Private 宣言 }
112      StoneGrid: TStoneGrid;      StoneGrid: TStoneGrid;
# Line 111  var Line 137  var
137  begin  begin
138    if CanSetStone(Stone, X, Y, true) = true then    if CanSetStone(Stone, X, Y, true) = true then
139    begin    begin
140      if Stone = stBlack then      case Stone of
141        Stone := stWhite        stBlack:
142      else          Stone := stWhite;
143        Stone := stBlack;        stWhite:
144            Stone := stBlack;
145          stEffect:
146            Stone := FEffectStone;
147        end;
148      result := 0;      result := 0;
149      for i := 0 to Count - 1 do      for i := 0 to Count - 1 do
150        for j := 0 to Count - 1 do        for j := 0 to Count - 1 do
# Line 132  end; Line 162  end;
162  function TStoneGrid.CanSetStone(Stone: TStoneType; X, Y: integer;  function TStoneGrid.CanSetStone(Stone: TStoneType; X, Y: integer;
163    Reverse: Boolean; const Visible: Boolean): Boolean;    Reverse: Boolean; const Visible: Boolean): Boolean;
164  var  var
165    i, k: integer;    i: integer;
166    p: Boolean;    p: Boolean;
167    q: ^TPoint;    q: ^TEffectData;
   list: TList;  
168    procedure Method(m, n: integer);    procedure Method(m, n: integer);
169    var    var
170      s: TStoneType;      s: TStoneType;
171      j: integer;      j, k: integer;
172    begin    begin
173      if p = false then      if p = false then
174        Exit;        Exit;
# Line 147  var Line 176  var
176      while true do      while true do
177      begin      begin
178        s := GetStrings(X + m * i, Y + n * i);        s := GetStrings(X + m * i, Y + n * i);
179          if s = stEffect then
180            s := FEffectStone;
181        if (s = stNone) or (s = stError) then        if (s = stNone) or (s = stError) then
182          break          break
183        else if s = Stone then        else if s = Stone then
184          if i > 1 then          if i > 1 then
185          begin          begin
186              if (result = false) and (Reverse = true) then
187                SetStrings(X, Y, Stone);
188            result := true;            result := true;
189            if Reverse = true then            if Reverse = true then
190            begin            begin
191              for j := 1 to i - 1 do              for j := 1 to i - 1 do
192              begin              begin
193                New(q);                Form1.PaintBox1.Repaint;
194                q^ := Point(X + m * j, Y + n * j);                if Visible = true then
195                list.Add(q);                begin
196                    FEffectStone := Stone;
197                    New(q);
198                    q^.Left := X + m * j;
199                    q^.Top := Y + n * j;
200                    q^.Stone := Stone;
201                    q^.X := 0;
202                    q^.Y := 0;
203                    FList.Add(q);
204                    SetStrings(q^.Left, q^.Top, stEffect);
205                    for k := 1 to 100 do
206                    begin
207                      Sleep(1);
208                      Application.ProcessMessages;
209                    end;
210                  end
211                  else
212                    SetStrings(X + m * j, Y + n * j, Stone);
213              end;              end;
214              break;              break;
215            end            end
# Line 177  var Line 227  var
227    end;    end;
228    
229  begin  begin
230    list := TList.Create;    result := false;
231    try    if Visible = true then
232      result := false;    begin
233      p := true;      FBool := FActive;
234      if GetStrings(X, Y) = stNone then      FActive := false;
235      begin    end;
236        Method(-1, -1);    p := true;
237        Method(-1, 0);    if GetStrings(X, Y) = stNone then
238        Method(-1, 1);    begin
239        Method(0, -1);      Method(-1, -1);
240        Method(0, 1);      Method(-1, 0);
241        Method(1, -1);      Method(-1, 1);
242        Method(1, 0);      Method(0, -1);
243        Method(1, 1);      Method(0, 1);
244        if (Reverse = true) and (result = true) then      Method(1, -1);
245        begin      Method(1, 0);
246          SetStrings(X, Y, Stone);      Method(1, 1);
         for i := 0 to list.Count - 1 do  
         begin  
           if Visible = true then  
           begin  
             for k := 1 to 10 do  
             begin  
               Sleep(10);  
               Application.ProcessMessages;  
             end;  
             Form1.PaintBox1.Repaint;  
           end;  
           q := list[i];  
           SetStrings(q^.X, q^.Y, Stone);  
         end;  
       end;  
     end;  
   finally  
     for i := 0 to list.Count - 1 do  
       Dispose(list[i]);  
     list.Free;  
   end;  
   if (Visible = true)and(result = true) then  
   begin  
     inc(FTurnIndex);  
     inc(FTurnNumber);  
     FBuffer[FTurnIndex] := FStrings;  
247    end;    end;
248  end;  end;
249    
# Line 227  procedure TStoneGrid.Clear; Line 251  procedure TStoneGrid.Clear;
251  var  var
252    i, j: integer;    i, j: integer;
253  begin  begin
254      for i := 0 to FList.Count - 1 do
255        Dispose(FList[i]);
256      FList.Clear;
257    for i := 0 to Count - 1 do    for i := 0 to Count - 1 do
258      for j := 0 to Count - 1 do      for j := 0 to Count - 1 do
259        Strings[i, j] := stNone;        Strings[i, j] := stNone;
# Line 239  begin Line 266  begin
266    FBuffer[0] := FStrings;    FBuffer[0] := FStrings;
267  end;  end;
268    
269    constructor TStoneGrid.Create;
270    begin
271      inherited;
272      FList := TList.Create;
273    end;
274    
275    destructor TStoneGrid.Destroy;
276    var
277      i: integer;
278    begin
279      for i := 0 to FList.Count - 1 do
280        Dispose(FList[i]);
281      FList.Free;
282      inherited;
283    end;
284    
285  function TStoneGrid.GetStrings(X, Y: integer): TStoneType;  function TStoneGrid.GetStrings(X, Y: integer): TStoneType;
286  begin  begin
287    if (X >= 0) and (X < Count) and (Y >= 0) and (Y < Count) then    if (X >= 0) and (X < Count) and (Y >= 0) and (Y < Count) then
# Line 247  begin Line 290  begin
290      result := stError;      result := stError;
291  end;  end;
292    
293    procedure TStoneGrid.ImageCount(X, Y: integer);
294    begin
295      FIndex_X := X;
296      FIndex_Y := Y;
297    end;
298    
299    function TStoneGrid.ListExecute: Boolean;
300    var
301      p: ^TEffectData;
302      i: integer;
303    begin
304      if FList.Count = 0 then
305        result := false
306      else
307      begin
308        for i := 0 to FList.Count - 1 do
309        begin
310          p := FList[i];
311          if p^.X < FIndex_X - 1 then
312            p^.X := p^.X + 1
313          else if p^.Y < FIndex_Y - 1 then
314          begin
315            p^.X := 0;
316            p^.Y := p^.Y + 1;
317          end
318          else
319          begin
320            SetStrings(p^.Left, p^.Top, p^.Stone);
321            Dispose(p);
322            FList[i] := nil;
323          end;
324        end;
325        for i := FList.Count - 1 downto 0 do
326          if FList[i] = nil then
327            FList.Delete(i);
328        if FList.Count = 0 then
329        begin
330          if FTerminated = true then
331            FActive := false
332          else
333            FActive := FBool;
334          inc(FTurnIndex);
335          inc(FTurnNumber);
336          FBuffer[FTurnIndex] := FStrings;
337        end;
338        result := true;
339      end;
340    end;
341    
342  function TStoneGrid.NextStone(Stone: TStoneType): TPoint;  function TStoneGrid.NextStone(Stone: TStoneType): TPoint;
343  var  var
344    i, j, m, n: integer;    i, j, m, n: integer;
# Line 266  begin Line 358  begin
358      result := Point(-1, -1);      result := Point(-1, -1);
359  end;  end;
360    
361    procedure TStoneGrid.Paint(Canvas: TCanvas);
362    var
363      i: integer;
364      k, m, n: integer;
365      s: TBitmap;
366      p: ^TEffectData;
367    begin
368      m := Form1.Image3.Bitmap.Width;
369      n := Form1.Image3.Bitmap.Height;
370      k := Form1.Size;
371      for i := 0 to FList.Count - 1 do
372      begin
373        p := FList[i];
374        if p^.Stone = stBlack then
375          s := Form1.Image1.Bitmap
376        else
377          s := Form1.Image2.Bitmap;
378        Canvas.DrawBitmap(s, RectF(p^.X * m, p^.Y * n, (p^.X + 1) * m,
379          (p^.Y + 1) * n), RectF(p^.Left * k, p^.Top * k, (p^.Left + 1) * k,
380          (p^.Top + 1) * k), 1);
381      end;
382    end;
383    
384  procedure TStoneGrid.Pause;  procedure TStoneGrid.Pause;
385  begin  begin
386    FActive := false;    if FActive = true then
387        FActive := false;
388      FTerminated := true;
389  end;  end;
390    
391  procedure TStoneGrid.Restart;  procedure TStoneGrid.Restart;
392  begin  begin
393    FActive := true;    if FTerminated = true then
394    FTurnIndex := FTurnNumber;    begin
395        FActive := true;
396        FTurnIndex := FTurnNumber;
397        FTerminated := false;
398      end;
399  end;  end;
400    
401  procedure TStoneGrid.SetStrings(X, Y: integer; const Value: TStoneType);  procedure TStoneGrid.SetStrings(X, Y: integer; const Value: TStoneType);
# Line 291  begin Line 412  begin
412      FTurnNumber := 0      FTurnNumber := 0
413    else    else
414      FTurnNumber := Value;      FTurnNumber := Value;
   FActive := false;  
415    FStrings := FBuffer[FTurnNumber];    FStrings := FBuffer[FTurnNumber];
416  end;  end;
417    
418  procedure TStoneGrid.Start;  procedure TStoneGrid.Start;
419  begin  begin
420    Clear;    Clear;
421      FTerminated := false;
422    FActive := true;    FActive := true;
423  end;  end;
424    
# Line 310  var Line 431  var
431    procedure Main;    procedure Main;
432    begin    begin
433      if Index = Player1 then      if Index = Player1 then
434        Index := Player2      begin
435          Index := Player2;
436          s := '白の手番です';
437        end
438      else      else
439        begin
440        Index := Player1;        Index := Player1;
441          s := '黒の手番です';
442        end;
443    end;    end;
444    function Execute: Boolean;    function Execute: Boolean;
445    var    var
446      i, j: integer;      i, j: integer;
447        m: integer;
448        n: integer;
449    begin    begin
     result := false;  
450      for i := 0 to Count - 1 do      for i := 0 to Count - 1 do
451        for j := 0 to Count - 1 do        for j := 0 to Count - 1 do
452          if StoneGrid.CanSetStone(Index.Stone, i, j, false) = true then          if StoneGrid.CanSetStone(Index.Stone, i, j, false) = true then
# Line 326  var Line 454  var
454            result := true;            result := true;
455            Exit;            Exit;
456          end;          end;
457        result := false;
458    end;    end;
459    
460  begin  begin
461      Timer1.Enabled:=false;
462    Main;    Main;
463    if Execute = false then    if Execute = false then
464    begin    begin
# Line 336  begin Line 466  begin
466      if Execute = false then      if Execute = false then
467      begin      begin
468        StoneGrid.Pause;        StoneGrid.Pause;
       Timer1.Enabled := false;  
469        m := 0;        m := 0;
470        n := 0;        n := 0;
471        for i := 0 to Count - 1 do        for i := 0 to Count - 1 do
# Line 347  begin Line 476  begin
476              stWhite:              stWhite:
477                inc(n);                inc(n);
478            end;            end;
479          Caption := s;
480        if m > n then        if m > n then
481          s := 'Player1 Win:' + #13#10          s := 'Player1 Win:' + #13#10
482        else if m < n then        else if m < n then
# Line 355  begin Line 485  begin
485          s := 'Draw:' + #13#10;          s := 'Draw:' + #13#10;
486        Showmessage(s + '(Player1) ' + IntToStr(m) + #13#10 + '(Player2) ' +        Showmessage(s + '(Player1) ' + IntToStr(m) + #13#10 + '(Player2) ' +
487          IntToStr(n));          IntToStr(n));
488      end;      end
489    end;      else
490          Caption := s;
491      end
492      else
493        Caption := s;
494      Timer1.Enabled:=true;
495  end;  end;
496    
497  procedure TForm1.CompStone;  procedure TForm1.CompStone;
# Line 371  end; Line 506  end;
506    
507  procedure TForm1.GameStart;  procedure TForm1.GameStart;
508  begin  begin
509      Timer1.Enabled:=false;
510      Index := Player1;
511    StoneGrid.Start;    StoneGrid.Start;
512    PaintBox1.Repaint;    PaintBox1.Repaint;
513    Index := Player1;    Caption := '黒から始めます';
514    Timer1.Enabled := true;    Timer1.Enabled:=true;
515  end;  end;
516    
517  procedure TForm1.MenuItem10Click(Sender: TObject);  procedure TForm1.MenuItem10Click(Sender: TObject);
518  begin  begin
519    StoneGrid.Restart;    StoneGrid.Restart;
   Timer1.Enabled := true;  
520  end;  end;
521    
522  procedure TForm1.MenuItem11Click(Sender: TObject);  procedure TForm1.MenuItem11Click(Sender: TObject);
523    var
524      i: integer;
525  begin  begin
   Timer1.Enabled := false;  
526    with StoneGrid do    with StoneGrid do
527      begin
528        i := TurnNumber;
529      if Sender = MenuItem11 then      if Sender = MenuItem11 then
530        TurnNumber := TurnNumber + 1        TurnNumber := TurnNumber + 1
531      else      else
532        TurnNumber := TurnNumber - 1;        TurnNumber := TurnNumber - 1;
533    ChangePlayer;      if (i = TurnNumber) then
534          Exit
535        else
536          Pause;
537      end;
538    PaintBox1.Repaint;    PaintBox1.Repaint;
539      ChangePlayer;
540  end;  end;
541    
542  procedure TForm1.MenuItem2Click(Sender: TObject);  procedure TForm1.MenuItem2Click(Sender: TObject);
# Line 409  procedure TForm1.MenuItem6Click(Sender: Line 553  procedure TForm1.MenuItem6Click(Sender:
553  begin  begin
554    Player1.Auto := MenuItem6.IsChecked;    Player1.Auto := MenuItem6.IsChecked;
555    Player2.Auto := MenuItem7.IsChecked;    Player2.Auto := MenuItem7.IsChecked;
   MenuItem10Click(Sender);  
556  end;  end;
557    
558  procedure TForm1.MenuItem8Click(Sender: TObject);  procedure TForm1.MenuItem8Click(Sender: TObject);
559  begin  begin
560    StoneGrid.Pause;    StoneGrid.Pause;
   Timer1.Enabled := false;  
561  end;  end;
562    
563  procedure TForm1.PaintBox1Paint(Sender: TObject; Canvas: TCanvas);  procedure TForm1.PaintBox1Paint(Sender: TObject; Canvas: TCanvas);
564  var  var
565    i, j: integer;    i, j: integer;
566  begin  begin
567    Canvas.Fill.Color := TAlphaColors.White;    if StoneGrid.Active = false then
568    Canvas.FillRect(RectF(0, 0, Count * Size, Count * Size), 0, 0, [], 1);      StoneGrid.Paint(Canvas);
569    for i := 0 to Count do    for i := 0 to Count - 1 do
570    begin    begin
571      Canvas.DrawLine(PointF(i * Size, 0), PointF(i * Size, Size * Count), 1);      for j := 0 to Count - 1 do
     for j := 0 to Count do  
572      begin      begin
       Canvas.DrawLine(PointF(0, j * Size), PointF(Count * Size, j * Size), 1);  
573        case StoneGrid.Strings[i, j] of        case StoneGrid.Strings[i, j] of
574          stWhite:          stWhite:
575            Canvas.DrawEllipse(RectF(i * Size, j * Size, (i + 1) * Size,            Canvas.DrawBitmap(Image4.Bitmap, RectF(0, 0, Image4.Bitmap.Width,
576                Image4.Bitmap.Height), RectF(i * Size, j * Size, (i + 1) * Size,
577              (j + 1) * Size), 1);              (j + 1) * Size), 1);
578          stBlack:          stBlack:
579            begin            Canvas.DrawBitmap(Image3.Bitmap, RectF(0, 0, Image3.Bitmap.Width,
580              Canvas.Fill.Color := TAlphaColors.Black;              Image3.Bitmap.Height), RectF(i * Size, j * Size, (i + 1) * Size,
581              Canvas.FillEllipse(RectF(i * Size, j * Size, (i + 1) * Size,              (j + 1) * Size), 1);
582                (j + 1) * Size), 1);          stEffect:
583            end;            continue;
584          else
585            Canvas.DrawBitmap(Image5.Bitmap, RectF(0, 0, Image5.Bitmap.Width,
586              Image5.Bitmap.Height), RectF(i * Size, j * Size, (i + 1) * Size,
587              (j + 1) * Size), 1);
588        end;        end;
589          Canvas.DrawLine(PointF(0, j * Size), PointF(Count * Size, j * Size), 1);
590      end;      end;
591        Canvas.DrawLine(PointF(i * Size, 0), PointF(i * Size, Size * Count), 1);
592    end;    end;
593      Canvas.DrawLine(PointF(Count * Size, 0),
594        PointF(Count * Size, Count * Size), 1);
595      Canvas.DrawLine(PointF(0, Count * Size),
596        PointF(Count * Size, Count * Size), 1);
597  end;  end;
598    
599  procedure TForm1.PaintBox1Resize(Sender: TObject);  procedure TForm1.PaintBox1Resize(Sender: TObject);
# Line 450  begin Line 601  begin
601    Size := Min(ClientWidth, ClientHeight) div Count;    Size := Min(ClientWidth, ClientHeight) div Count;
602  end;  end;
603    
604    procedure TForm1.FormActivate(Sender: TObject);
605    begin
606      Timer1.Enabled := true;
607    end;
608    
609  procedure TForm1.FormCreate(Sender: TObject);  procedure TForm1.FormCreate(Sender: TObject);
610  begin  begin
611    StoneGrid := TStoneGrid.Create;    StoneGrid := TStoneGrid.Create;
612      StoneGrid.ImageCount(Form1.Image1.Bitmap.Width div Form1.Image3.Bitmap.Width,
613        Form1.Image1.Bitmap.Height div Form1.Image3.Bitmap.Height);
614    Player1 := TPlayer.Create;    Player1 := TPlayer.Create;
615    Player2 := TPlayer.Create;    Player2 := TPlayer.Create;
616    Player1.Stone := stBlack;    Player1.Stone := stBlack;
# Line 468  begin Line 626  begin
626    GameStart;    GameStart;
627  end;  end;
628    
629    procedure TForm1.FormDeactivate(Sender: TObject);
630    begin
631      Timer1.Enabled := false;
632    end;
633    
634  procedure TForm1.FormDestroy(Sender: TObject);  procedure TForm1.FormDestroy(Sender: TObject);
635  begin  begin
636    StoneGrid.Free;    StoneGrid.Free;
# Line 484  end; Line 647  end;
647  procedure TForm1.Timer1Timer(Sender: TObject);  procedure TForm1.Timer1Timer(Sender: TObject);
648  begin  begin
649    if (StoneGrid.Active = true) and (Index.Auto = true) then    if (StoneGrid.Active = true) and (Index.Auto = true) then
   begin  
     Timer1.Enabled := false;  
650      CompStone;      CompStone;
651      Timer1.Enabled := true;  end;
652    end;  
653    procedure TForm1.Timer2Timer(Sender: TObject);
654    begin
655      if (StoneGrid.Active = false) and (StoneGrid.ListExecute = true) then
656        PaintBox1.Repaint;
657  end;  end;
658    
659  procedure TForm1.FormResize(Sender: TObject);  procedure TForm1.FormResize(Sender: TObject);
Legend:
Removed from v.13  
changed lines
  Added in v.24
Back to OSDN">Back to OSDN
 ViewVC Help
Powered by ViewVC 1.1.26  
About OSDN
Find Software
Develop Software
Help