``````
unit U_PierrotsPuzzle;
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
}

{Find four digit numbers which if treated as two
numbers  (1 digt and 3 digits or 2 digits and 2
digits), the product contains the same digits as
the original number.  e.g 15x93= 1395,

This puzzle was invented by H.E. Dudeney, a
recreational mathematician and published in  his
book "Amusements in Mathematics" around
1917 (reprinted by Dover Publications).

Pierrot is a well known French clown/mime
frequently seen in white face and wearing a
pointed hat.  Dudeney drew him with arms and
legs extended to form the X representing
multiplication.
}

interface

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

type
TForm1 = class(TForm)
Memo1: TMemo;
ListBox1: TListBox;
SearchBtn: TButton;
StatusBar1: TStatusBar;
Image1: TImage;
LZeroBox: TCheckBox;
Label1: TLabel;
procedure SearchBtnClick(Sender: TObject);
end;

var
Form1: TForm1;

implementation

{\$R *.DFM}

{******************* SameDigits ***************}
{Returns true if a and b contain the same digits, not necessarily in the same
order.  If LeadingZeros is true and  a and b are not the same length, the
shorter  number is extended on the left with zeros before setting result.
If result is true, the digits found in variable parameter S}
var
i,j,x:integer;
countsa, countsb:array[0..10] of integer;
begin
for i:=0 to 10 do begin  countsa[i]:=0; countsb[i]:=0; end;
while a >0 do {count occurences of digits in a}
begin
x:=a mod 10;
inc(countsa[x]);
a:=a div 10;
inc(countsa[10]);
end;
while b >0 do  {count occurences of digits in b}
begin
x:=b mod 10;
inc(countsb[x]);
b:=b div 10;
inc(countsb[10]);
end;
result:=true;
s:='';
begin
if countsa[10]<countsb[10] then inc(countsa[0], countsb[10]-countsa[10])
else if countsb[10]<countsa[10] then inc(countsb[0], countsa[10]-countsb[10]);
end;

for i:= 0 to 9 do
begin
if countsa[i]<>countsb[i] then
begin  {counts differ, get out}
result:=false;
s:='';  {wipe out any partial return string}
break;
end
else {count was equal, add this digit to the string}
for j:=1 to countsa[i] do s:=s+','+char(i+ord('0'));
end;
if length(s)>0 then delete(s,1,1); {delete initial ','}
end;

{************** SearchBtnClick *************}
procedure TForm1.SearchBtnClick(Sender: TObject);
{Look for solutions}
var i,n1,n2,n:integer;
str:string;  {the string version of the matching digits, if they match}
list:Tstringlist;
begin
list:=Tstringlist.create;
for i:=1000 to 9999 do {check all 4 digit numbers}
begin {split 1 and 3 digits}
n1:=i div 1000;  {get 1st digit}
n2:=i mod 1000;  {get last 3 digits}
if n2>=100 then n:= n1*n2
else n:=0;
if not samedigits(i,n,LZeroBox.Checked, str) then
begin {split 2 and 2 digits}
n1:=i div 100;  {get the 1st 2 digits}
n2:=i mod 100;  {get the last 2 dgits}
if (n1 < n2) {only check arrangments with n1<n2, n1>n2 is redundant}
then
begin
n:= n1*n2; {since we'll check the other arrangement anyway}
samedigits(i,n, LZeroBox.checked, str);
end;
end;
if str<>'' {we have a solution!}
then list.add(format('%4s:   %d x %d = %.4d ',[str,n1,n2, n]));
end;
list.sort;
listbox1.items.assign(list); {move solutions to listbox}

i:=1;
with listbox1, items do
while I<=count-1 do  {Insert breaks between unique solutions}
begin
if (copy(items[i],1,7)<>copy(items[i-1],1,7)) then
begin
insert(i,' ');
inc(i);
end;
inc(i);
end;
list.free;
end;

end.

``````