unit U_HangMan2;
{Copyright 2002, 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
 }

{This version of Hangman allows human or computer to play the role of
 Hamgman or Convict.  There is also the option to allow a "Tricky Hangman"
 who will not exactly cheat but does bend the rules to increase the chance that
 justice will be done}

interface

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

type
TKind=(circle,rectangle,Line); {kinds of elements to draw figure}
THPiece=class(TObject)  {pieces used to draw victim}
kind:TKind;
    start,stop: TPoint;
end;

  TForm1 = class(TForm)
    DeadLbl: TLabel;
    PlayerPanel: TPanel;
    Label4: TLabel;
    WordLbl: TLabel;
    Label3: TLabel;
    Label2: TLabel;
    Edit1: TEdit;
    Guesseslbl: TLabel;
    GallowsImage: TImage;
    NewGameBtn: TBitBtn;
    Label5: TLabel;
    AboutBtn: TButton;
    GroupBox1: TGroupBox;
    HangmanRGrp: TRadioGroup;
    ConvictRGrp: TRadioGroup;
    CABox: TCheckBox;
    MovesLeftLbl: TLabel;
    Panel2: TPanel;
    Memo1: TMemo;
    Levelbar: TTrackBar;
    Label1: TLabel;
    MaxLenLbl: TLabel;
    MaxMovesLbl: TLabel;
procedure FormCreate(Sender: TObject);
procedure Edit1KeyPress(Sender: TObject; var Key: Char);
procedure EditKeyPress(Sender: TObject; var Key: Char);
procedure NewGameBtnClick(Sender: TObject);
procedure AboutBtnClick(Sender: TObject);
procedure HangmanRGrpClick(Sender: TObject);
procedure LevelbarChange(Sender: TObject);
public
HangmanList:TList;  {a list of gallows/convict pieces}
piececount:integer; {nbr of  pieces}
lastcolor:TColor;
    TheWord:string;  {The secret word - only its length may be know if human
                      hangman opts not to tell us}
count:integer;
    maxmoves, maxwordlen:integer;
    movesleft:integer;
    Wordlist: TStringlist; {Eligible word list, used when computer is Hangman}
GuessedLetters:set of char;
function CheckaLetter(ch:char):boolean;
procedure drawAPiece(piececolor:TColor);
procedure MakeComputerGuesses;
function HumanCheckChar(ch:char; var partword:string):boolean;
end;

var
Form1: TForm1;

implementation

uses U_About2, U_GetWordDlg, UDict, U_HumanScoreDlg;


{$R *.DFM}

{**************** FormCreate *****************}
procedure TForm1.FormCreate(Sender: TObject);
var
piece:THPiece;
begin
{Define all of the hangman pieces}
piececount:=0;
  HangManList:=TList.create;
  piece:=THPiece.create;
with piece do
begin
kind:=line;  {base}
start:=point(200,350);
    stop:=point(50,350);
    HangmanList.add(piece);
end;
  piece:=THPiece.create;
with piece do
begin
kind:=line;   {upright}
start:=point(50,350);
    stop:=point(50,50);
    HangmanList.add(piece);
end;
  piece:=THPiece.create;
with piece do
begin
kind:=line;   {crosspiece}
start:=point(50,50);
    stop:=point(125,50);
    HangmanList.add(piece);
end;
  piece:=THPiece.create;
with piece do
begin
kind:=line;  {rope}
start:=point(125,50);
    stop:=point(125,75);
    HangmanList.add(piece);
end;
  piece:=THPiece.create;
with piece do
begin
kind:=circle;  {head}
start:=point(100,75);
    stop:=point(150,125);
    HangmanList.add(piece);
end;
  piece:=THPiece.create;
with piece do
begin
kind:=line;       {body}
start:=point(125,125);
    stop:=point(125,225);
    HangmanList.add(piece);
end;

  piece:=THPiece.create;
with piece do
begin
kind:=line;   {arm1}
start:=point(125,150);
    stop:=point(75,175);
    HangmanList.add(piece);
end;
  piece:=THPiece.create;
with piece do
begin
kind:=line; {arm2}
start:=point(125,150);
    stop:=point(175,175);
    HangmanList.add(piece);
end;
 piece:=THPiece.create;
with piece do
begin      {leg1}
kind:=line;
    start:=point(125,225);
    stop:=point(100,300);
    HangmanList.add(piece);
end;
  piece:=THPiece.create;
with piece do
begin      {leg2}
kind:=line;
    start:=point(125,225);
    stop:=point(150,300);
    HangmanList.add(piece);
end;
  pubdic.LoadDicFromFile(extractfilepath(application.exename)+'HangmanWords.txt');
  wordlist:=TStringlist.create;
  randomize;
  LevelBarchange(sender);
end;

{***************** CheckALetter ***************}
function TForm1.CheckaLetter(ch:char):boolean;
{check a guess and return result true until we are hung or win}
var
i,j:integer;
  s:string;
  goodguess, deleted,a,f,c:boolean;
begin
result:=true;
  goodguess:=false;
if not (ch in GuessedLetters) then  {can't guess the same letter twice}
begin
GuessedLetters:=GuessedLetters+[ch];
    guessesLbl.caption:=guesseslbl.caption+ch+', ';
if hangmanrgrp.itemindex=2 then
begin  {the tricky hangman part}
{if the current word contains the selected letter,
       see if we can find another word that doesn't}
i:=0;
while (i<wordlist.count) do
begin
s:=uppercase(wordlist[i]);
        deleted:=false;
for j:= 1 to length(s) do
if s[j]=ch then
begin
wordlist.delete(i);
          deleted:=true;
          break;
end;
if not deleted then inc(i);
end;
if wordlist.count>0 then Theword:=uppercase(wordlist[0]);
end;
    s:=Wordlbl.caption; {use s for temp string storage}
if (HangmanRgrp.itemindex>0) or CABox.checked then
begin  {computer hangman or computer assisted scoring}
for i:=1 to length(TheWord) do {see if the letter is in the word}
begin
if ch=Theword[i] then
begin
s[2*i-1]:=ch; {fill in the  letter in display}
goodguess:=true;
end;
end;
end
else goodguess:=HumanCheckChar(ch, s); {let the human hangman score it}
wordlbl.caption:=s; {update the partial word display}
if not goodguess then
begin
drawAPiece(clred);
      dec(movesleft);
      movesleftlbl.caption:='You have '+inttostr(movesleft)+' mistakes left!';
end;
If pos('_',WordLbl.caption)=0 {all underscores replaced by letters}
then
begin {We have a winner!}
if convictrgrp.itemindex=0 then
deadlbl.caption:='Your lucky guesses have earned'+#13+'you a reprieve (this time)'
else deadlbl.caption:='My superior intelligence has again won the day';
      result:=false;
end
else If piececount=Hangmanlist.count
then
begin  {Loser!}
if convictrgrp.itemindex=0 then {Convict was human}
begin
s:='Oh, oh  Goodbye!';
         deadlbl.caption:='You''re dead!' ;
end
else
begin {Convict was computer}
s:='Rotten luck!';
         deadlbl.caption:='I''ll get you next time!' ;
end;
If not CABox.checked then
begin
s:=Inputbox('Hangman:','What was the '+inttostr(length(TheWord))+
'-letter secret word?',' ');
if length(s)<>length(Theword) then Theword:= s+' (Wrong length!)'
else
if pubdic.lookup(s,a,f,c) then theword:=s
else Theword:=s+'(but not in your average normal hangman''s vocabulary)';
end;
      showmessage(s+#13 +'(The word was '+theword+')');
      result:=false;
end;
end
else messagebeep(mb_IconExclamation);
end;


{********************** DrawAPiece **************}
procedure TForm1.DrawAPiece(piececolor:TColor);
var
piece:THPiece;
  w,h:integer;
  piecestomove:integer;
  i:integer;
begin
piecestomove:=1;
If ((maxmoves<12) and (piececount= 0))  {8 or 10 mistakes allowed - draw base & upright}
or ((maxmoves=8) and (piececount= 6)){8 mistakes allowed - draw both arms now}
then piecestomove:=2;
for i:=1 to piecestomove do
begin
inc(piececount);    {get to the next piece}
if piececount<=HangManList.count then
with Gallowsimage, canvas, piece do
begin
lastcolor:=piececolor;
      piece:=Hangmanlist[piececount-1];
case piece.kind of
line:
begin
pen.width:=4;
          pen.color:=piececolor;
if piececolor=color {to erase face}
then brush.color:=piececolor;
          moveto(start.x,start.y);
          lineto(stop.x,stop.y);
end;
        circle: {The face}
begin
ellipse(start.x,start.y,stop.x,stop.y);
          w:=stop.x-start.x;
          h:=stop.y-start.y;
{right eye}
moveto(start.x+2*w div 10,
                start.y+3*h div 10);
          lineto(start.x+4*w div 10,
                start.y+3*h div 10);
          moveto(start.x+3*w div 10,
                start.y+2*h div 10);
          lineto(start.x+3*w div 10,
                start.y+4*h div 10);
{left eye}{right eye}
moveto(start.x+6*w div 10,
                start.y+3*h div 10);
          lineto(start.x+8*w div 10,
                start.y+3*h div 10);
          moveto(start.x+7*w div 10,
                start.y+2*h div 10);
          lineto(start.x+7*w div 10,
                start.y+4*h div 10);
{mouth}
ellipse(start.x+4*w div 10,
                  start.y+7*h div 10,
                  start.x+6*w div 10,
                  start.y+8*h div 10);
end;
end; {case}
end; {piecestomove loop}
end;
end;

function TForm1.HumanCheckChar(ch:char; var partword:string):boolean;
{Human hangman didn't trust the us to help score,
 call a dialog to let him score convict's latest guess}
{Partword is the expanded version of the word being guessed w/embedded spaces
  at even numbered locations}
var
i:integer;
begin
with HumanScoreDlg do
begin
guess:=ch;
{set up known part of secret word over in the dialog (without the embedded spaces)}
knownpart:=StringOfChar(' ',length(partword)div 2);
for i:= 1 to length(knownpart) do  knownpart[i]:=partword[2*i-1];
     result:= showmodal = MrOK;
{now pass the result back to caller}
for i:= 1 to length(knownpart) do partword[2*i-1]:=knownpart[i];
end;
end;

{**************Edit1KeyPress ******************}
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
{Check convict entry to make sure it is an uppercase letter}
begin
key:=upcase(key);
If not (key in ['A'..'Z']) then messagebeep(mb_iconexclamation)
else  CheckALetter(key);
  key:=#00;
end;


{*******************EditKeyPress ****************}
procedure TForm1.EditKeyPress(Sender: TObject; var Key: Char);
{Make sure user enters only letters}
begin
if not (upcase(key) in ['A'..'Z']) then
begin
messagebeep(mb_iconexclamation);
    key:=#0;
end;
end;

{**************** NewGameBtnClick **************}
procedure TForm1.NewGameBtnClick(Sender: TObject);
{reset things for a new game}
var
s:string;
  i,n:integer;
begin
panel2.visible:=false;
if hangmanrgrp.itemindex=0 then {human hangman}
begin
if CABox.checked then {computer assisted scoring}
begin
if GetWordDlg.showmodal=MROK
then TheWord:=uppercase(GetWordDlg.WordEdt.text)
else exit;
end
else  {no computer scoring help}
begin
showmessage('You have chosen to keep score yourself. '
+#13+'Choose your secret word, write it down, then click OK to begin');
repeat
s:=inputbox('Unassisted hangman','Enter length of the secret word','0');
        n:=strtointdef(s,0);
if n>maxwordlen then showmessage('Maximum word length at this level is '
+inttostr(maxwordlen) )
else if n=0 then showmessage('Enter a length from 2 to '+inttostr(maxwordlen));
until n>=2;
      theword:=stringofchar(' ',n); {Set length of the word, even though we don't know it}
end;
end
else
with pubdic do
begin {Computer is hangman - go select a random secret word from the dictionary}
{choose random word length between 1/2 maxwordlength and maxwordlength}
n:=(maxwordlen+1) div 2 + random(maxwordlen div 2);
    setrange('a',n,'z',n);
    n:=Getwordcount;
    wordlist.assign(pubdic.expandedlist);
    getwordbynumber(random(n),Theword);
    TheWord:=uppercase(TheWord);
end;
{Common stuff regardless of who plays the hangman}
Playerpanel.visible:=true;
  Gallowsimage.visible:=true;
  wordlbl.caption:='';
for i:=1 to length(Theword) do WordLbl.caption:=wordlbl.caption+'_ ';
  guessedletters:=[];
  guessesLbl.caption:='';
with gallowsimage do canvas.rectangle(clientrect);
  piececount:=0;
  deadlbl.caption:='';
  edit1.text:='';
  edit1.setfocus;
  movesleft:=maxmoves;
  movesleftlbl.caption:='You have '+inttostr(movesleft)+' mistakes left!';
if Convictrgrp.itemindex=1 then {Computer is the Convict}
begin
edit1.readonly:=true; {stop user from making guesses}
MakeComputerguesses;
end
else edit1.readonly:=false;  {let user make guesses}
end;

{*************** MakeComputerguesses *********}
procedure TForm1.MakeComputerGuesses;
{The computer is the convict}
{No cheating here!  But we will take advantage of the dictionary to
 guess the most frequently occurring letter of the possible solution
 words at each turn}

type TCountsrec=record
letter:char;
      count:integer;
end;
var
n:integer;
  triedset:set of char;
  list:TStringlist;
  counts:array[1..26] of TCountsrec;
  temp:TCountsrec;
  ch:char;
  i:integer;

procedure buildcounts;
{Build a list of all possible words based on word length, and
        which letters have already been guessed}
var
i,j,k:integer;
         ch2:char;
begin
{1. Rebuild the word list eliminating all the words that can't be the answer}
for j:= 1 to (length(wordlbl.caption) div 2) do
begin
ch2:=wordlbl.caption[2*j-1];
if ch2<>'_' then
begin
k:=0;
while k<list.count do
{Next line is "dumber" guessing technique - delete word if
                 matched letter not anywhere in the word.
                 if pos(ch2,list[k])=0 then list.delete(k) else inc(k);}
{"Smarter" - delete word if not (matched letter in correct position)}
if list[k][j]<>ch2 then list.delete(k) else inc(k);
end;
end;

{2. Loop through the list and build a table of counts of words containing
           each letter in an unfilled position - we'll select the letter with
           the highest count each time}
for i:=1 to 26 do {initialize counts array}
with counts[i] do
begin
count:=0;
            letter:=char(ord('A')+i-1);
end;
{Accumulate letter counts for all words still in the list}
for i:= 0 to list.count-1 do
begin
For j:= 1 to length(list[i]) do
begin
ch2:=list[i][j];
              inc(counts[ord(ch2)-ord('A')+1].count);
end;
end;
{3. Sort array by descending word count}
{This is the order that we'll be making our guesses}
for i:=1 to 25 do
begin
for j:=i+1 to 26 do
if counts[j].count>counts[i].count then
begin
temp:=counts[i];
              counts[i]:=counts[j];
              counts[j]:=temp;
end;
end;
end; {buildcounts}

begin {MakeComputerGuess}
n:=length(wordlbl.caption) div 2;
    triedset:=['_'];  {letters guessed so far}
pubdic.Setrange('a',n,'z',n);
    list:=TStringList.create;
    pubdic.getwordcount; {build the expanded list of words}
{build uppercase list of dictionary words of proper length}
with pubdic do for i:=0 to expandedlist.count-1
do list.add(uppercase(expandedlist[i]));
repeat {the guess loop}
buildcounts;
      i:=0;
repeat {find an untried letter}
inc(i);
        ch:=counts[i].letter;
{if not (ch in triedset) then buildcounts; }
until (i=26) or (not (ch in triedset));
      sleep(1000);
      application.processmessages;
      triedset:=triedset+[ch];
until (not checkaletter(ch)) or (i=26);
    list.free;
end;

{************** AboutBtnClick ****************}
procedure TForm1.AboutBtnClick(Sender: TObject);
{Show About box }
begin  aboutbox.showmodal; end;


{***************** HangManRGrpClick **************}
procedure TForm1.HangmanRGrpClick(Sender: TObject);
{Hangman radiogroup was clicked}
begin
{only show computer assisted checkbox if hangman is human}
If hangmanrgrp.itemindex=0
then CABox.visible:=true else CABox.visible:=false;
end;

{**************** LevelBarChange **************}
procedure TForm1.LevelbarChange(Sender: TObject);
{ Level was changed - set max word length and number of gallows pieces
  based on level}
begin
MaxLenLbl.caption:='Max word size '+ inttostr(levelbar.position);
case levelbar.position of
3,4: maxmoves:=12;
    9,10: maxmoves:=8;
else maxmoves:=10;
end;
  MaxMovesLbl.caption:='Max mistakes ' +inttostr(maxmoves);
  maxwordlen:=levelbar.position;
end;

end.