unit U_NIM3;
{Copyright  © 2002, Gary Darby,  www.DelphiForFun.org
 This program may be used or modified for any non-commercial purpose
 so long as this original notice remains in place.
 All other rights are reserved
 }

{A multi-pile version of NIM -
   players may as many tokens as desired from single row in a turn}


interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Spin, ExtCtrls, ComCtrls;

type

TRowRec= record
nbrtokens:integer;
    rowindex:integer; {which row to display tokens}
tokens:TList;
end;


  TForm1 = class(TForm)
    HumanRGrp: TGroupBox;
    TakeBtn: TButton;
    Label2:    TLabel;
    NewGameBtn: TButton;
    TypeRGrp:  TRadioGroup;
    Panel1: TPanel;
    PlayerGrp: TRadioGroup;
    PlayList: TListBox;
    RestoreBtn: TButton;
    StatusBar1: TStatusBar;
procedure TakeBtnClick(Sender: TObject);
procedure NewGameBtnClick(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure Shape1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
procedure Panel1Resize(Sender: TObject);
procedure RestoreBtnClick(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure PlayerGrpClick(Sender: TObject);
procedure TypeRGrpClick(Sender: TObject);
public
NextPlayer:char;
    laststickloses:boolean;
    WinningSticks:integer;  {1 for normal game, last stick loses}
{0 for misere game, last stick wins}
board:array of Trowrec;  {nbr of sticks in each row}
tokensize:integer;
    usedrows:integer; {non-zero rows for new game}
{max:integer;}
clickedrow:integer;
    gameover:boolean;
    player1move:boolean;
    clickedcol:integer; {index of latest token clicked on this move,
                          used when ctrl-click is used to select multiple tokens}
player1, player2:string;
procedure computermove;
procedure restoregame;
procedure setplayer;
procedure setplayernames;
end;

var
Form1: TForm1;
  maxrows:integer=5;
implementation

uses math, {max and min functions require math unit}
U_Setup;


{$R *.DFM}

{****************** FormActivate ************}
procedure TForm1.FormActivate(Sender: TObject);
{Initialization stuff}
var i:integer;
begin
with setupdlg.boardgrid do
begin
randomize;
    rowcount:=maxrows+1;
    cells[0,0]:='Pile Nbr';
    cells[1,0]:='# of tokens';
for i:=1 to maxrows do
begin
cells[0,i]:=inttostr(i);
      cells[1,i]:=inttostr(random(10));
end;
end;
  setlength(board,maxrows+1);
for i:= 0 to maxrows-1 do   {create the lists to hold the tokens}
with board[i] do tokens:=TList.create;
  typergrpclick(sender); {initialize playmode}
restoregame;
end;


{********************* RestoreGame ***************}
procedure TForm1.Restoregame;
{Initialize game based on setupdlg.boardgrid values}
var
i,j:integer;
  h,w:integer;
  max:integer;
begin
usedrows:=0;
  max:=0;
{free up any remaining old tokens}
for i:=0 to maxrows-1 do
with board[i] do
begin
for j:= 0 to tokens.count-1 do if tokens[j]<>nil then TShape(tokens[j]).free;
    tokens.clear;
end;

with setupdlg.boardgrid do
begin
for i:=0 to maxrows-1 do
with board[i] do
begin
nbrtokens:=strtointdef(cells[1,i+1],8);
if nbrtokens>max then max:=nbrtokens;
      rowindex:=usedrows;
if nbrtokens>0 then usedrows:=i;
for j:=0 to nbrtokens-1 do  {create tokens as TShape component}
begin
tokens.add(TShape.create(panel1));
with Tshape(tokens[tokens.count-1]) do
begin
parent:=panel1;
          shape:=stCircle;
          brush.color:=clblue;
          onmousedown:= Shape1MouseDown ;
end;
end;
end;
end;
  h:=9*panel1.height div (10*(usedrows+1));
  w:=9*panel1.width div (10*max);
if h>w then tokensize:=w else tokensize:=h;

{set token sixe and location info}
for i:=0 to maxrows-1 do
with board[i] do
for j:= 0 to tokens.count-1 do
with TShape(Tokens[j]) do
begin
left:=tokensize div 2 + j*tokensize {+ 2};
    top:= tokensize div 2 + i*tokensize {+ 2};
    width:= tokensize-4;  {make actual height a width a few pixels smaller}
height:=tokensize-4;
end;
  clickedrow:=0;
  gameover:=false;
  playlist.clear;
  setplayernames;
  panel1.caption:='';
if (Playergrp.itemindex>0) and (not gameover)
then if ((playergrp.itemindex=1) and player1move)
or ((playergrp.itemindex=2) and (not player1move))
then computermove;
end;


{************** TakeBtnClick ****************}
procedure TForm1.TakeBtnClick(Sender: TObject);
{User says to take some sticks}
var
i,j:integer;
  player, tokenstr:string;
  take,row:integer;
begin
take:=0;
  row:=-1;
for i:=0 to maxrows-1 do
with board[i] do
begin
j:=0;
while j<tokens.count do
if tokens[j]<>nil then
with tshape(tokens[j]) do
begin
if brush.color=clsilver then
begin
tshape(tokens[j]).free;
        tokens.delete(j);
        row:=i;
        inc(take);
end
else inc(j);
end;
if row>=0 then break;
end;
if player1move then player:=player1 else player:=player2;
if take=1 then tokenstr:=' token ' else tokenstr:=' tokens ';
  playlist.items.add(player+' takes '+inttostr(take)
             +tokenstr +'from row ' + inttostr(row+1));
  playlist.itemindex:=playlist.items.count-1;

  clickedrow:=0;

{count tokens remaining to see if we're done}
j:=0;
for i:=0 to maxrows-1 do
with board[i] do inc(j,tokens.count);
if j=0 then
begin
if laststickloses then setplayer;
if player1move then player:=player1 else player:=player2;
    Panel1.caption:=player + ' wins!';
    gameover:=true;
end
else
begin
setplayer;
if (Playergrp.itemindex>0) and (not gameover) then computermove;
end;
end;

{*************** Setplayer *********}
procedure Tform1.setplayer;
begin
player1move:=not player1move;
if player1move then humanrgrp.caption:='Your turn '+player1
else humanrgrp.caption:='Your turn '+player2;
  application.processmessages;
end;

{************ NewGameBtnClick ***********}
procedure TForm1.NewGameBtnClick(Sender: TObject);
begin
if setupdlg.showmodal=mrOK then restoregame;
end;

{************* Shape1MouseDown *****************}
procedure TForm1.Shape1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
{On mouse down exit used by each token to select or deselect it for deletion}
var
row:integer;
  i:integer;
  prevcol:integer;
  start,stop:integer;
begin
row:= (tshape(sender).top+y-tokensize div 2) div tokensize;
   prevcol:=clickedcol;
if not (ssshift in shift) then clickedcol:=board[row].tokens.indexof(sender);

{if user clicked new row - reset previous row tokens}
if (row<>clickedrow) and (clickedrow<>0) then
with board[clickedrow] do
for i:=0 to tokens.count-1 do
if tokens[i]<>nil then tshape(tokens[i]).brush.color:=clblue;

{handlle shift-click - multiple select/deselect}
if (ssshift in shift) and (prevcol>=0) and (clickedcol>=0) then
begin
i:=board[row].tokens.indexof(sender);
     start:=min(prevcol,i);
     stop:=max(prevcol,i);
for i:=start+1 to stop-1 do {end tokens have been or will be switched}
with tshape(board[row].tokens[i]) do
if brush.color<>clSilver then brush.color:=clsilver
else brush.color:=clblue;
end;

{select or deselect clicked token}
with tshape(sender) do
if brush.color<>clSilver then brush.color:=clsilver
else brush.color:=clblue;

   clickedrow:=row; {save clicked row}
end;

const maxbits=5; {max tokens in a row  = 2^maxbits -1}

{****************** ComputerMove ***************}
procedure tform1.computermove;
{The fun part of this program - use algorithm described by Martin Gardner
 to make "unsafe" positions "safe".}
var
i,j:integer;
  row:integer;
  take:integer;
  n:integer;
  max:integer;
  singlecount:integer; {number of rows with a single token}
multcount:integer;   {number of rows with more than one token}
tokenstr:string;

begin {computermove}


row:=-1;

{code for  misere version}
if laststickloses then
begin
{if only one row with token count >1 then
     reduce that row to 1 if number of rows with 1 token is odd
     or reduce to 0 of number of rows with 1 token is even,
     either way the idea is to leave an odd number of
     rows with a single token for your opponent.
     Since it is his turn and and last token loses, we are guaranteed to win!
     If we are not in that condition yet, leave row at -1 and next section
     wil calculate the move
    }
singlecount:=0;
    multcount:=0;
for i:=0 to maxrows-1 do
with board[i] do
if tokens.count=1 then inc(singlecount)
else if tokens.count>1 then
begin
inc(multcount);
      row:=i;
end;
if multcount=1 then
begin
if singlecount mod 2 =1 then take:=board[row].tokens.count
else take:=board[row].tokens.count-1;
end
else row:=-1;
end;

if row<0 then {either last token wins or last token loses but condition of
                 previous "close to end" test not met}
begin
{Original algorithm using Martin Gardner's description from "Hexaflexagons..."
     book removed}
{revised code - thanks to Arne Vedo for this simpler, but equivalent,
      algorithm using XOR,  50 lines of code reduced to 15!}
n:=board[0].tokens.count; {get "XOR product" of all counts}
for i:=1 to maxrows-1 do n:=n xor board[i].tokens.count;

if n>0 then
begin {unsafe - make it safe}
for i:=0 to maxrows-1 do
begin
{find the row with count matching leftmost bit of N}
j:=n xor board[i].tokens.count;
if j < board[i].tokens.count then
begin
row:=i;
          take:=board[i].tokens.count - j;
          break;
end;
end;
end

{back to original code}
else {position is safe - best we can do is remove one token from longest row}
begin
max:=0;
      row:=-1;
for i:=0 to maxrows-1 do
begin
if board[i].tokens.count>max then
begin
row:=i;
          max:=board[i].tokens.count;
end;
end;
      take:=1;
end;
end;

if take=1 then tokenstr:=' token ' else tokenstr:=' tokens ';
  playlist.items.add('Computer takes '+inttostr(take)
             +tokenstr+'from row ' + inttostr(row+1));
  playlist.itemindex:=playlist.items.count-1;
for i := 1 to take do
with board[row] do
begin
n:=tokens.count-1;
with tshape(tokens[n]) do  brush.color:=clsilver;
    application.processmessages;
    sleep(500);
    tshape(tokens[n]).free;
    tokens.delete(n);
    application.processmessages;
end;
  n:=0;
for i:=0 to maxrows-1 do
with board[i] do n:=n+tokens.count;
if n=0 then
begin
panel1.caption:='Computer wins again!';
    gameover:=true;
end;
  setplayer;
end;


{***************** Panel1Resize ***************}
procedure TForm1.Panel1Resize(Sender: TObject);
begin
{make sure board is initialized before trying to restore the game,
   an initial call to resize is made before this is true}
if length(board)>0 then restoregame;
end;

{******************** ResttoreBtnClick **********}
procedure TForm1.RestoreBtnClick(Sender: TObject);
begin  restoregame;  end;

{************ Generate a test board - OK to delete this  *********}
procedure TForm1.Button1Click(Sender: TObject);
begin
with setupdlg.boardgrid do
begin
cells[1,1]:='8';
    cells[1,2]:='13';
    cells[1,3]:='24';
    cells[1,4]:='30';
    cells[1,5]:='0';
end;
  restoregame;
end;

{*************** SetPlayerNames ************}
procedure TForm1.setplayernames;
begin
case playergrp.itemindex of
0: begin {H vs H}
player1:='Human #1';
         player2:='Human #2';
end;
    1: begin {C vs H}
player1:='Computer';
          player2:='Human';
end;
    2: begin {H vs c}
player1:='Human';
         player2:='Computer';
end;
end; {case}
player1move:=false;
  setplayer;
end;

{**************** PlayerGrpClick **********}
procedure TForm1.PlayerGrpClick(Sender: TObject);
{player structure changed, restore the board}
begin  restoregame;  end;

{************** TypeRgrpClick ************}
procedure TForm1.TypeRGrpClick(Sender: TObject);
{Normal or misere (last token loses) mode changed - restore the game}
begin
if typergrp.itemindex=1 then laststickloses:=true
else laststickloses:=false;
  restoregame;
end;

end.