unit U_Mastermind;
{Copyright 2001, Gary Darby, Intellitech Systems Inc., 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.

 Mastermind is a registered trademark of Pressman Toy Corporation
 }

interface

uses
  Windows, Messages, ImgList, Controls, StdCtrls, Buttons, ExtCtrls,
  Classes, SysUtils, Graphics, Forms, Dialogs;
 Const
   NbrColors=6;
   maxpatterns=Nbrcolors*NbrColors*Nbrcolors*Nbrcolors;
   maxguesses=10;
type
  TPattern=array[1..4] of byte; {a set of pegs}
  TPatRec = record
    Pattern:TPattern;
    OKFlag:Boolean;  {this pattern is available for use}
  end;
  TGuessRec=record    {and guess and the resulting score}
    patternNbr,nbrinpos,nbroutofpos:integer;
  end;
  TMouseModes=(GetGuess,GetNbrRight);
  TRunModes=(Running,Solved,OutofGuesses,GaveUp,UserError);

  TForm1 = class(TForm)
    StartBtn: TButton;
    RoleBox: TRadioGroup;
    ImageList1: TImageList;
    OKBtn: TBitBtn;
    GiveUpBtn: TButton;
    BoardImage: TPaintBox;
    InstLbl: TLabel;
    OKBtn2: TBitBtn;
    InstLbl2: TLabel;
    SecretBox: TGroupBox;
    PaintBox1: TPaintBox;
    MsgLoc: TLabel;
    ExitBtn: TButton;
    VerboseBox: TCheckBox;
    ShowVerboseBtn: TButton;
    procedure StartBtnClick(Sender: TObject);
    procedure BoardImageMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure OKBtnClick(Sender: TObject);
    procedure GiveUpBtnClick(Sender: TObject);
    procedure BoardImagePaint(Sender: TObject);
    procedure OKBtn2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
    procedure ExitBtnClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure VerboseBoxClick(Sender: TObject);
    procedure ShowVerboseBtnClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    BoardPic:TPicture;
    Level:integer;  {Play level: 1=Beginner, 2=good, 3=unbeatable}
    SecretPattern:TPattern;
    CurGuesses:array [1..maxguesses] of TGuessrec;
    CurGuessCount:Integer;
    Patterns:array[1..maxpatterns] of TPatRec;
    TwoPair:array[1..maxpatterns] of integer;
    nbrpairs:integer;
    {nbrinpos,nbroutofPos:integer;}
    offseth,offsetw,incrx,incry:integer;
    UserGuess, UserNbrRight:TPattern;
    HelpScore:boolean;
    RunMode:TRunModes;
    MouseMode:TMouseModes;
    Workimage,BigPeg,SmallPeg:TBitmap;
    verbose:boolean;
    TotOK:integer;  {# of eligible patterns - used for verbose reporting}
    Procedure InitPatterns;
    Function Eligible(Const guessrec:TGuessrec; const testpatnbr:Integer):boolean;
    Procedure MakeGuess;
    Procedure Score(Const Masterpat:TPattern; var TestGuess:TGuessrec);
    Procedure GetScoreFromUser;
    Procedure showBigpeg(colornbr,col,row:integer; Paintbox:TPaintBox);
    Procedure ShowSmallPeg(pegcolor:TColor;col,row:integer);
    Procedure ShowGuess;
    Procedure ShowNbrRight;
    Procedure DrawBoard;
    Procedure GetUserGuess;
    Function patternOK(Const pattern:TPattern):boolean;
    Function makepatternstr(patnbr:integer):string;
  end;

var
  Form1: TForm1;

implementation

uses U_SelectPattern, U_ShowPattern, U_GetHiderOptions, U_Verbose;

{$R *.DFM}

Const
  colors:array[1..NbrColors]of char=('R','B','G','V','Y','L');

{********************* TForm1.DrawBoard ******************}
Procedure TForm1.DrawBoard;
var
  itop,ileft:integer;
  r:TRect;
  i,j:integer;
  bkcolor:TColor;
Begin
  bkcolor:=rgb(150,150,150);
  with BoardImage do
  Begin
    color:=bkcolor;
    canvas.rectangle(0,0,width,height);
    for i:= 0 to 3 do
    for j:= 0 to maxguesses-1 do
    Begin
      ileft:=offsetw+i*incrx+4;
      itop:=offseth+j*incry+4;
      r:=rect(ileft,itop,ileft+incrx-4,itop+incry-4);
      canvas.moveto(0,itop+incry-2);
      canvas.lineto(width,itop+incry-2);
      canvas.draw(ileft,itop,BigPeg);
    end;
    for i:= 0 to 3 do
    for j:= 0 to maxguesses-1 do
    Begin
      ileft:=offsetw+5*incrx+4;
      If i mod 2 >0 then ileft:= ileft+incrx div 2;
      itop:=offseth+j*incry+4;
      If i>=2 then itop:=itop + incry div 2;
      r:=rect(ileft,itop,ileft+incrx div 2-4,itop+incry div 2-4);
      canvas.draw(ileft,itop,SmallPeg);
    end;
  end;
end;

{********************** TForm1.ShowBigPeg ******************}
Procedure TForm1.showBigpeg(colornbr,col,row:integer; Paintbox:TPaintbox);
var
  itop,ileft:integer;
Begin
  workimage.height:=incry;
  workimage.width:=incrx;
  Imagelist1.Getbitmap(colornbr-1,workimage);
  itop:=trunc(offseth+4+(row-1)*incry);
  ileft:=trunc(offsetw+4+(col-1)*incrx);
  {r:=rect(ileft,itop,ileft+incrx-4,itop+incry-4);}
  Paintbox.canvas.draw(ileft-2,itop-2,workimage) ;
End;

{********************* TForm1.ShowSmallPeg *****************}
Procedure TForm1.ShowSmallPeg(pegcolor:TColor;col,row:integer);
var
  r:TRect;
  itop,ileft:integer;
Begin
  workimage.width:=incrx;
  workimage.height:=incry;
  itop:=trunc(offseth+4+(row-1)*incry);
  if col >2 then itop:=itop+incry div 2;
  ileft:=trunc(offsetw+4+5*incrx);
  if col mod 2 = 0 then ileft:=ileft+incrx div 2;
  r:=rect(ileft,itop,ileft+incrx div 2-4,itop+incry div 2-4);
  with boardimage do
  if pegcolor=clBlack then
  begin
    canvas.brush.color:=clblack;
    canvas.Pen.color:=clteal;
    canvas.pen.width:=2;
    canvas.ellipse(r.left,r.top,r.Right,r.bottom);
  end
  else
  begin
    if pegcolor=clWhite then  Imagelist1.Getbitmap(7,workimage)
    else if pegcolor=clred then Imagelist1.Getbitmap(6,workimage);
    canvas.stretchdraw(r,workimage) ;
  end;
End;

{********************** TForm1.InitPatterns *****************}
Procedure TForm1.InitPatterns;
{initialize all 1296 patterns}
var
  i,j,k,l,count:integer;
Begin
  count:=0;
  nbrpairs:=0;
  for i:= 1 to NbrColors do
    for j:=1 to NbrColors do
      for k:=1 to NbrColors do
        for L:=1 to NbrColors do
        Begin
          inc(count);
          patterns[count].Pattern[1]:=i;
          patterns[count].Pattern[2]:=j;
          patterns[count].Pattern[3]:=k;
          patterns[count].Pattern[4]:=l;

          patterns[count].OKFlag:=true;
          if ((i=j) and (k=L) and (i<>k))
          or ((i=k) and (j=L) and (i<>j))
          or ((i=L) and (j=k) and (i<>j))
          then
          Begin
            inc(nbrpairs);
            twopair[nbrpairs]:=count;
          end;
        end;
  curguesscount:=0;
end;

function TForm1.makepatternstr(patnbr:integer):string;
{used for verbose displays}
  var
    i:integer;
    pat:TPattern;
  begin
    result:='';
    pat:=patterns[patnbr].pattern;
    for i:=1 to 4 do
      result:=result+colors[pat[i]];
  end;


{********************* TForm1.Eligible *********************}
Function TForm1.Eligible(Const guessrec:TGuessrec;
                           Const testpatnbr:Integer):boolean;
var
  i,j:integer;
  oldnbrrightpos,NewNbrRightPos:integer;
  oldnbrrightcolor, NewNbrRightColor:integer;
  Pat1,Pat2:TPattern;
  TestGuess:TGuessrec;



  procedure makemsg(msg:string);
  begin
    with verboseform.listbox1 do
    begin
      items.add(msg + ', Testing '+makepatternstr(testpatnbr)
                  + ' against Guess '+makepatternstr(guessrec.patternnbr)
                  +format(' (%d,%d)',[guessrec.nbrinpos,guessrec.nbroutofpos]));
    end;
  end;

Begin
  result:=true;
  oldnbrrightpos:=guessrec.nbrinpos;
  oldnbrrightcolor:=oldnbrrightpos+guessrec.nbroutofpos;
  pat1:=patterns[guessrec.patternnbr].Pattern;
  pat2:=patterns[testpatnbr].Pattern;

  case level of
  1:  {kind of dumb}
    Begin
      {Heuristics}
      {#1 if colorcount is 0, then
          test pattern cannot have any of that color}
      If result then
      Begin
        if oldnbrrightcolor=0 then
        for i:= 1 to 4 do
        if result then
        begin
          Begin
            j:=1;
            while (j<=4) and result do
            if (pat1[i]<>pat2[j]) then inc(j)
            else
            begin
              result:=false;
              if verbose then makemsg('Heuristic 1 rejected ');
            end;
          end;
        end;
      end;

      If result then
      {#2 If all of guess is one color, there be exactly color count
          in any new guess}
      Begin
        j:=1;
        For i:=2 to 4 do if pat1[i]=pat1[1] then inc(j);
        if j=4 then
        Begin
          j:=0;
          for i:= 1 to 4 do if pat2[i]=pat1[1] then inc(j);
          if j<>oldNbrRightColor then
          begin
            result:=false;
            if verbose then makemsg('Heuristic 2 rejected ');
          end;
        end;
      end;

      if result then
      {#3 - Counts in test pattern must be at least as high as count in the guess}
      Begin
        NewNbrRightPos:=0;
        NewNbrRightColor:=0;
        for i:=1 to 4 do if pat1[i]=pat2[i] then inc(Newnbrrightpos);
        for i:=1 to 4 do
        Begin
          j:=1;
          while (j<=4) and (pat1[i]<>pat2[j]) do inc(j);
          if pat1[i]=pat2[j] then
          Begin
            inc(NewNbrrightcolor);
            pat2[j]:=255; {so we don;t count it twice}
          end;
        end;
        if (NewNbrRightpos<OldNbrRightPos)
          or (NewNbrRightcolor<OldNbrRightColor)
        then
        begin
          result:=false;
          If verbose then makemsg('Heuristic 3 rejected ');
        end;
      end;
    end; {level=1}
  2,3,4: {Pick a solution that has same score  prev guess.
      i.e. each of the 14 possible scores partitions the
      remaining patterns into 14 groups -- the correct solution has to be
      in the group matching the previous score.  This surpsising result
      is based on the symmetry of scores, score(secret pattern, guess patter)=
      score(guess pattern, secretpattern) }
    Begin
      If Patterns[testpatnbr].OKFlag then
      Begin
        with Testguess do
        Begin
          PatternNbr:=testpatnbr;
          nbrinpos:=-1;
          nbroutofpos:=-1;
        end;
        Score(patterns[guessrec.Patternnbr].Pattern,TestGuess);
        If (TestGuess.nbrinpos<>guessrec.nbrinpos)
           or (TestGuess.nbroutofPos<>guessrec.nbroutofpos)
        then
        begin
          result:=false;
        end;
      end
      else
      begin
       result:=false;
      end;
    end; {level=2}
  end; {case}
  if result and verbose then makemsg('Accepted as eligible ');
end; {Eligible}

{******************** TForm1.MakeGuess ***********************}
Procedure TForm1.MakeGuess;
{Computer generates guesses here}

    Procedure displayError;
    var
      s:string;
      i:integer;
    Begin
      s:='';
      for i:=1 to 4
      do s:=s+colors[patterns[curguesses[curguessCount].patternnbr].Pattern[i]];
      If helpscore then
      Begin
        showmessage('System error, Last guess ' + s
                    +#13+'Program stopped - email Grandpa' );
        halt;
      end
      else
      Begin
        RunMode:=UserError;
      end;
    end; {displayerror}

var
  i,j,k:integer;
  testguess:TGuessrec;
  minmax, minmaxguess, maxval:integer;
  maxscores:array[0..24] of integer;
  savecount:integer;
  nbrleft:integer;
  TestPatternNbrs: array[0..maxpatterns] of Integer;
  maxvalscore,minmaxscore:integer;
begin
  if verbose then verboseform.listbox1.clear;
  If curguesscount>0 then
  {elminate from consideration all patterns which are not possible
   based on current guess}
   begin
     savecount:=totok;
    {1. Make sure current does not get selected}
    patterns[curguesses[curguesscount].patternnbr].okFlag:=false;
    dec(totOK);
    {2. Flag all patterns that are not Eligible with the current guess}
    For i := 1 to maxpatterns do
    begin
      {definition of "Eligible" depends on level}
      if Patterns[i].OKFlag and (not Eligible(curguesses[curguessCount],i))
      then
      begin
        Patterns[i].OKFlag:=false;
        dec(TotOK);
      end;
    end;
    if verbose then verboseform.memo1.lines.add('Eligible patterns reduced from '
                                    + inttostr(savecount)+' to '
                                    + inttostr(TotOK));
  end
  else TotOK:=maxpatterns;
  {3. for level 1 or 2, select the first eligible (i.e consistent) pattern
      as next guess}
  If level<3 then
  begin
    i:=1;
    while (i<=maxpatterns) and
    (not patterns[i].OKFlag) do inc(i);
    If not patterns[i].OKFlag then displayerror
    else
    begin
      inc(curguessCount);
      with curguesses[curguessCount] do
      begin
        patternnbr:=i;
        nbrinpos:=-1;
        nbroutofpos:=-1;
      end;
    end;
  end
  else {for level 3 - use min-max technique}
  Begin
    {for each possible guess, get the distribution of scores
     when tested against all eligibles.  Save the largest of these for each guess.
     The pattern we want for our next guess is smallest of these}

    {For speed build a pruned array of just the eligible patterns,
     we can go through this list without checking for eligibility}
    nbrLeft:=0;
    for i:=1 to maxpatterns do
    begin
      if patterns[i].OKFlag then
      begin
        inc(NbrLeft);
        testpatternNbrs[Nbrleft]:=i;
      end;
    end;


    i:=1;
    minmax:=9999;
    minmaxguess:=0;
    for i := 1 to nbrleft do {for all possible guesses}
    Begin
      for j:= 0 to 20 do maxscores[j]:=0;
      testguess.patternnbr:=TestPatternNbrs[i];
      {here's the trickiest part, find out which of the 14 possible
      scoresets, each of the remaing eligible scores belongs to}
      for j:= 1 to nbrleft do
      begin
        Score(Patterns[TestpatternNbrs[j]].pattern, testguess);
        k:=5*testguess.nbrinpos+testguess.nbroutofpos;
        inc(maxscores[k]);
      end;
      maxval:=0;
      {now find the largest};
      for j:=0 to 20 do  {highest subscrupt will be 5*4=20}
      if maxscores[j]>maxval then
      begin
        maxval:=maxscores[j];
        maxvalscore:=j;  {for ver bose display}
      end;
      if maxval<minmax then
      begin
        minmaxguess:=testpatternNbrs[i];
        minmax:=maxval;
        minmaxscore:=maxvalscore;
      end;
      if verbose then verboseform.listbox1.items.add
            ('Min-max max scoreset size for '+ makepatternstr(testpatternnbrs[i])
             +' is '+inttostr(minmax)+ '('+inttostr(minmaxscore div 5)
             +','+inttostr(minmaxscore mod 5)+')');
    end; {for i}
    {we've determined which pattern score contains the minimum maximum number
    of members, that's our next guess}

    if minmaxguess>0 then
    Begin
      inc(curguessCount);
      with curguesses[curguessCount] do
      Begin
        patternnbr:=minmaxguess;
        nbrinpos:=-1;
        nbroutofpos:=-1;
      end;
    end
    else DisplayError;
  end;
  if verbose then verboseform.Memo1.lines.add(makepatternstr(curguesses[curguesscount].patternnbr)
                               + ' selected as next guess');
End;  {makeguess}

{*************** TForm1.Score *********************}
Procedure TForm1.Score(Const Masterpat:TPattern;
                           var TestGuess:TGuessrec);
var
  i,j:Integer;
  pat1,pat2:TPattern;
Begin
    with Testguess do
    Begin
      nbrinpos:=0;
      nbroutofpos:=0;
      pat2:=patterns[{testguess.}patternnbr].Pattern;
      pat1:=MasterPat;

      for i:= 1 to 4 do if pat2[i]=pat1[i] then inc(nbrinpos);
      for i:= 1 to 4 do
      for j:=1 to 4 do
      If (pat2[i]=pat1[j]) and (pat2[i]<>255) then
      Begin
        inc(nbroutofpos);
        pat2[i]:=255; {don't match this one against any more}
        pat1[j]:=255; {and don't match any other pat1 againt this pat2}
      end;
      nbroutofpos:=nbroutofpos-nbrinpos;
    end;
end;

{*************** TForm1/GetScoreFromUser **************}
Procedure Tform1.GetScoreFromUser;
Var
  i:integer;
  testguess:TGuessRec;
Begin
  For i:= 1 to 4 do UserNbrRight[i]:=0;
  MouseMode:=GetNbrright;
  BoardImage.OnMouseup:=BoardimageMouseUp;
  OKBtn2.top:=offseth+incry*(curguesscount);
  OKBtn2.visible:=true;
  Instlbl2.visible:=true;
  GiveUpBtn.visible:=true;
  ExitBtn.visible:=false;
  tag:=0;

  repeat
    application.processmessages;
  until Tag<>0;


  with curguesses[curguesscount] do
  Begin
    nbrinpos:=0;
    nbroutofpos:=0;
  end;
  for i:= 1 to 4 do
  if usernbrright[i]=1 then inc(curguesses[curguesscount].nbrinpos)
  else if usernbrright[i]=2 then inc(curguesses[curguesscount].nbroutofpos);
  If GetHiderOptions.radiogroup1.itemindex=1 then
  Begin
    testguess:=curguesses[curguesscount];
    Score(SecretPattern,testguess);
    If curguesscount<=maxguesses then
    Begin
      If (testguess.nbrinpos<>curguesses[curGuessCount].nbrinpos)
      or (testguess.nbroutofpos<>curguesses[curguesscount].nbroutofpos)
      then messagedlgpos('Oops - you made a scoring error, I''ll correct it for you',
                    mtinformation,[mbOK],0,msgloc.left,msgloc.top);
      curguesses[curguesscount]:=testguess;
      for i:= 1 to 4 do showsmallpeg(clBlack,i,curguesscount);
      shownbrright;
    end;
  end;

  BoardImage.OnMouseup:=nil;
  OKBtn2.visible:=false;
  Instlbl2.visible:=false;
  GiveUpBtn.visible:=false;
  ExitBtn.visible:=true;
End;

{**************** TForm1.ShowGuess ***************}
Procedure TForm1.ShowGuess;
{display a guess on the board}
var
  i:integer;
Begin
  with patterns[curguesses[curguesscount].patternnbr] do
  for i:=1 to 4 do showbigpeg(Pattern[i],i,curguesscount,BoardImage);
end;

{****************** TForm1.ShowNbrRight *****************}
Procedure TForm1.shownbrRight;
{display nbr right pegs on the oard}
var
  i:integer;
begin
  with curguesses[curguesscount] do
  Begin
    for i:=1 to nbrinpos do showsmallpeg(clRed,i,curguesscount);
    for i:= 1 to nbroutofpos do showsmallpeg(clWhite,i+nbrinpos,curguesscount);
  end;

End;

{******************** TForm1.GetUserGuess **************}
Procedure Tform1.GetUserGuess;
{solicit a guess from the user}
Var
  i:integer;
Begin
  MouseMode:=GetGuess;
  For i:= 1 to 4 do UserGuess[i]:=0;
  BoardImage.OnMouseup:=BoardimageMouseUp;
  OKBtn.top:=offseth+incry*(curguesscount+1);
  OKBtn.visible:=true;
  GiveupBtn.Visible:=true;
  Instlbl.visible:=true;
  tag:=0;
  repeat
    application.processmessages;
  until tag<>0;
  BoardImage.OnMouseup:=nil;
  OKBtn.visible:=false;
  GiveupBtn.visible:=false;
  Instlbl.visible:=false;
End;


{***************** TForm1.PatternOK ******************}
function Tform1.PatternOK(Const pattern:TPattern):boolean;
{just check to ensure that 4 colors have been selected}
var
  i:integer;
  Begin
    result:=true;
    for i:= 1 to 4 do
    if pattern[i]=0 then
    begin
      result:=false;
      break;
    end;
  end;


{********************* TForm1.StartBtnClcik **************}
procedure TForm1.StartBtnClick(Sender: TObject);
{begin the solving process}
var
  i:integer;
begin
  StartBtn.enabled:=false;
  drawboard;
  secretbox.visible:=false;
  InitPatterns;
  RunMode:=Running;
  verboseform.memo1.lines.clear;

  case RoleBox.itemindex of
  0: {Computer solves}
  begin
    if GetHiderOptions.showmodal = mrok then
    begin
      application.processmessages;
      level:=GetHiderOptions.Smartbox.itemindex+1;
      helpscore:=false;
      totOK:=maxpatterns;
      case GetHiderOptions.radiogroup1.itemindex of
        0:  ShowpegsDlg.showmodal;
        1,2,3:
        begin
          if PatternDlg.showmodal<>mrOK then  {user changed his mind}
          begin
            StartBtn.enabled:=true;
            exit;
          end;
          if GetHiderOptions.radiogroup1.itemindex=2
          then helpscore:=true;
          Secretpattern:=PatternDlg.UserGuess;
          secretbox.visible:=true;
          for i:=1 to 4 do showbigpeg(secretpattern[i],i,1,Paintbox1);
        end;

      end; {case}


      curguesscount:=1;
      with curguesses[1] do
      case level of
        1,2:  patternnbr:=random(maxpatterns)+1;
        3:  patternnbr:=twopair[random(nbrpairs)+1];
      end;
      ShowGuess;
      If helpscore then
      Begin
        Score(Secretpattern, curguesses[curGuessCount]);
        ShownbrRight;
        sleep(1000);
      end
      else GetScoreFromUser;
      while (RunMode=running) do
      Begin
        makeguess;
        If curguesscount<=maxguesses then ShowGuess;
        If helpscore then
        Begin
          Score(SecretPattern,curguesses[curguesscount]);
          if curguesscount<=MaxGuesses then ShowNbrRight;
          sleep(1000);
        end
        else GetScoreFromUser;
        If curguesses[curguesscount].nbrinpos=4 then RunMode:=solved;
        If (curGuessCount=maxguesses) and (runmode=running) then runMode:=Outofguesses;
      end;
      Case RunMode of
         Solved:messagedlgpos('Solved it , I win!',mtInformation,[mbOK],0,msgloc.left, msgloc.top);
         OutOfGuesses: messagedlgpos('Too many guesses, you win',mtInformation,[mbOK],0,msgloc.left, msgloc.top);
         GaveUp: messagedlgpos('You gave up, I win!',mtInformation,[mbOK],0,msgloc.left, msgloc.top);
         UserError: messagedlgpos('You scored wrong, I win!',mtInformation,[mbOK],0,msgloc.left, msgloc.top)
      end; {case}
    end;
  end;
  1:
    Begin  {user solves}
      {Make a Secret pattern}
      randomize;
      For i:=1 to 4 do SecretPattern[i]:=random(Nbrcolors)+1;
      {Loop}
      repeat
        GetUserGuess;
        Score(SecretPattern,curguesses[curguesscount]);
        if curguesscount<=MaxGuesses then ShowNbrRight;
        If curguesses[curguesscount].nbrinpos=4 then RunMode:=solved;
      until not (RunMode=running) {or (curGuessCount>MaxGuesses)};
      case runmode of
        Solved: messagedlgpos('You solved it, you win!',mtInformation,[mbOK],0,msgloc.left, msgloc.top);
        OutOfGuesses: messagedlgpos('Too many guesses, I win!',mtInformation,[mbOK],0,msgloc.left, msgloc.top);
        GaveUp:messagedlgpos('You gave up, I win!',mtInformation,[mbOK],0,msgloc.left, msgloc.top);
      end; {case}
      If PatternOK(Secretpattern) then {4 pegs were specified in the pattern}
      Begin
        secretbox.visible:=true;
        for i:=1 to 4 do showbigpeg(secretpattern[i],i,1,Paintbox1);
      end;
    end;
  end; {case}
  StartBtn.enabled:=true;
end;



{******************* TForm1.BoardImageMouseUp *******************}
procedure TForm1.BoardImageMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
 {collect and display guess (bigpeg) or score (smallpeg) peg data
  depending on Mousemode flag}
var
  newrow,newcol:integer;
  relx, rely:integer;
begin
  newcol:= (x-offsetw) div incrx+1;
  newrow:= (y-offseth) div incry+1;
  If Mousemode=GetGuess then
  Begin
    If (newrow=curGuesscount+1) and (newcol>=1) and (newcol<=4) then
    Begin
      inc(userguess[newcol]);
      if userguess[newcol]>6
      then userguess[newcol]:=userguess[newcol]-6;
      showbigpeg(userguess[newcol],newcol,newrow,BoardImage);
    end;
  end
  else if Mousemode=GetNbrRight then
  Begin
    If (newrow=curGuesscount) and (newcol=6) then
    Begin
      {Convert column/row for small pegs to virtual column 5 to 9}
      {just for ease of counting - actual positions are not significant}
      relx:=(x-offsetw-4) - 5*incrx;
      rely:=(y - offseth-4) -(newrow-1)*incry;
      newcol:= relx div (incrx div 2) + 2*(rely div (incry div 2))+5;
      inc(usernbrright[newcol-4]);
      if usernbrright[newcol-4]>2 then
      Begin
        usernbrright[newcol-4]:=0;
        showsmallpeg(ClBlack,newcol-4,newrow);
      end
      else If usernbrright[newcol-4]=1 then showsmallpeg(ClRed,newcol-4,newrow)
      else If usernbrright[newcol-4]=2 then showsmallpeg(Clwhite,newcol-4,newrow);
    end;
  end;
end;

{******************** TForm1.OKBtnClick *************}
procedure TForm1.OKBtnClick(Sender: TObject);
{score a users guess}
var
  count:integer;
  i,j:integer;
  found:boolean;
begin
  if not patternOK(Userguess) then messagedlgpos('Click on pegholes to set a pattern'
                                  +#13+'Then click this button',
                                  mtInformation,[mbOK],0,msgloc.left, msgloc.top)
  else
  Begin
    i:=0;
    found:=false;
    while (not found) and (i<MaxPatterns) do
    Begin
      inc(i);
      count:=0;
      for  j:=1 to 4 do if userguess[j]=patterns[i].Pattern[j] then inc(count);
      if count=4 then found:=true;
    End;
    If found then
    Begin
      inc(curguesscount);
      Curguesses[curguesscount].patternnbr:=i;
      tag:=1;
    end
    Else
    Begin
      Showmessage('System error 2 - Email Grandpa');
      halt;
    end;
  end;
end;

{***************** TForm1.GiveUpBtnClick *************}
procedure TForm1.GiveUpBtnClick(Sender: TObject);
begin
  RunMode:=GaveUp;
  tag:=1;
end;

{****************** BoardImagePaint *****************}
procedure TForm1.BoardImagePaint(Sender: TObject);
var
  i,j:integer;
begin
  drawboard;
  for j:= 1 to curguesscount do
  with curguesses[j], patterns[curguesses[j].patternnbr] do
  Begin
    for i:=1 to 4 do showbigpeg(Pattern[i],i,j,BoardImage);
    for i:=1 to nbrinpos do showsmallpeg(clRed,i,j);
    for i:= 1 to nbroutofpos do showsmallpeg(clWhite,i+nbrinpos,j);
  end;
end;

{************** TForm1.OKBtn2Click ***********}
procedure TForm1.OKBtn2Click(Sender: TObject);
begin
  tag:=1;
end;


{*************** TForm1.PaintBox1Paint **************}
procedure TForm1.PaintBox1Paint(Sender: TObject);
{repaint the secret code box as necessary}
var
  i:integer;
begin
  for i:=1 to 4 do showbigpeg(secretpattern[i],i,1,Paintbox1);
end;

{****************** TForm1.ExitBtnClick *****************}
procedure TForm1.ExitBtnClick(Sender: TObject);
begin
  close;
end;

{****************** TForm1.FormClose ***********************}
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  close;
end;

{********************* TForm1.Create ************}
procedure TForm1.FormCreate(Sender: TObject);
begin
  workimage:=TBitmap.create;
  workimage.transparent:=true;
  bigpeg:=TBitmap.create;
  bigpeg.transparent:=true;
  SmallPeg:=TBitmap.create;
  SmallPeg.transparent:=true;
  incry:=Boardimage.height div (maxguesses+1);
  incrx:=Boardimage.width div 9;
  offseth:=incry div 2;
  offsetw:=incrx div 2;
  with Bigpeg do
  Begin
    height:=incry-4;
    width:=incrx-4;
    canvas.fillrect(rect(0,0,width,height));
    canvas.brush.color:=clblack;
    canvas.Pen.color:=clteal;
    canvas.pen.width:=4;
    canvas.ellipse(4,4,width-4,height-4);
  end;
  With SmallPeg do
  Begin
    height:=incry div 2 -4;
    width:=incrx div 2 -4;
    canvas.brush.color:=clblack;
    canvas.Pen.color:=clteal;
    canvas.pen.width:=2;
    canvas.ellipse(0,0,width,height);
  end;

  giveupbtn.top:=StartBtn.top;
  giveupbtn.left:=StartBtn.left;
  randomize;
end;


procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  canclose:=true;
  tag:=1;
  runmode:=gaveup;
end;

procedure TForm1.VerboseBoxClick(Sender: TObject);
begin
  If verbosebox.checked then
  begin
    verbose:=true;
    showverbosebtn.visible:=true;
  end
  else verbose:=false;
  verboseform.visible:=verbose;
  showverbosebtn.visible:=verbose;
end;

procedure TForm1.ShowVerboseBtnClick(Sender: TObject);
begin
  verboseform.visible:=true;
end;

end.