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

{Variation of Puzzle #383 from H.E. Dudeney -  Amusements in Mathematics, Dover
Publications

Select the Ace through 9 of any suit from a deck of cards and arrange them
in a 5X5 T shape like this sample:  1 2 9 7 8
3
4
5
6
Notice that the sum of the digits in the crossbar (1+2+9+7+8=27) is the same
as the sum of the cards in the upright (9+3+4+5+6=27).   How many unique
solutions are there?  Unique in this variation means that no set of 5 numbers
may be repeated in any row or column.   Dudeney's original counted each
permutation of the digits as unique
}

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, U_CardComponent, ComCtrls, Grids, Spin, mmsystem;

type

TSlot = record
p:TPoint;
occupiedby:TCard;
end;

TForm1 = class(TForm)
RowLbl: TLabel;
ColLbl: TLabel;
Memo1: TMemo;
StatusBar1: TStatusBar;
StringGrid1: TStringGrid;
ShowSolutionBtn: TButton;
Shownbr: TSpinEdit;
StatusLbl: TLabel;
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure ShowSolutionBtnClick(Sender: TObject);
public
cards:array[1..9] of Tcard;  {array of card images}
cardSlots:array[1..9] of TSlot; {slot descriptor records for cards}
dragflag:boolean;  {true ==> a card is being dragged}
slotfrom:integer;  {where the dragged card came from}
midw,midh:integer; {half of card width and height}

{Solutions are 5 character strings, the intersecting card value followed
by 4 card values in crossbar or upright}
SolutionList:TStringList; {list of solutions already displayed, used to
check for repeats so user doesn't get credit twice}
Allsolutions:TStringList; {All 18 solutions}
solutioncounts:array[1..9] of integer; {# of solutions found by intersecting card value}

{Card moving procedures}
procedure CardMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure CardMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure CardMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure movecardtoslot(c:Tcard; slot:integer);
procedure movecardtohome(c:Tcard);

function updatesums:boolean; {update crossbar and upright sum labels, return true
if T is full and sums are equal}
procedure ComputeSolutions; {Called from FormCreate to find all 18 solutuions}
function IsNewSolution(intersecting:integer; a:array of integer;
var SolutionNbr:integer):boolean; {test for new solution}
end;

var
Form1: TForm1;

implementation

{\$R *.DFM}

uses combo;

const
Ttopleft:Tpoint=(x:330;y:10);
HomeTopLeft:TPoint=(x:10;y:240);

{Adjust borders of grid to just fit cells}
var   w,h,i:integer;
begin
with grid do
begin
w:=0;
for i:=0 to colcount-1 do w:=w+colwidths[i];
width:=w;
repeat width:=width+1 until fixedcols+visiblecolcount=colcount;
h:=0;
for i:=0 to rowcount-1 do h:=h+rowheights[i];
height:=h;
repeat height:=height+1 until fixedrows+visiblerowcount=rowcount;
invalidate;
end;
end;

{**************** FormCreate ***********}
procedure TForm1.FormCreate(Sender: TObject);
{Initialization stuff}
var i:integer;
begin
solutionlist:=TStringList.create;
allsolutions:=TStringlist.create;
{create the cards}
for i:=1 to 9 do
begin
cards[i]:=TCard.create(self);
with cards[i] do
begin
parent:=self;
onmousedown:=Cardmousedown;
onmousemove:=CardMouseMove;
onmouseup:=CardMouseUp;
setcard(i,D);
with Ttopleft do
if i<=5
then cardslots[i].p:=point(x+(I-1)*(width+4),y)
else cardslots[i].p:=point(x+2*(width+4),y+(i-5)*(height+4));
movecardtoslot(cards[i],i);
end;
end;

dragflag:=false;
midw:=cards[1].width div 2;
midh:=cards[1].height div 2;
updatesums; {show the new sum labels}
computesolutions; {find all 18 solutions}
with stringgrid1 do
begin
colwidths[0]:=100;
cells[0,0]:= 'Intersection Card -->';
for i:=0 to 4 do
begin
cells[i+1,0]:=inttostr(2*i+1);
cells[i+1,1]:=inttostr(solutioncounts[2*i+1]);
cells[i+1,2]:='0';
end;
cells[0,1]:='# Solutions';
cells[0,2]:='# Found';
end;
allsolutions.sort;
end;

{************* MoveCardToSlot ***********}
procedure TForm1.movecardtoslot(c:Tcard; slot:integer);
{move card to an empty slot on the the T}
begin
with cardslots[slot] do
begin
c.left:=p.x;
c.top:=p.y;
occupiedby:=c;
end;
end;

{**************** MoveCardToHome **********}
procedure TForm1.movecardtohome(c:Tcard);
{Move card to a fixed position, not on the T, based on card value}
begin
with c do
begin
top:=HomeTopleft.y;
left:=Hometopleft.x+30*(value-1);
end;
end;

{******************** Formpaint ***********}
procedure TForm1.FormPaint(Sender: TObject);
{redraw the rectangles around the card slots on the T}
var
i:integer;
begin
self.Canvas.brush.color:=clblack;
self.canvas.pen.style:=psdash;
for i:=1 to 9 do
with cardslots[i]  do
self.canvas.framerect(rect(p.x-2,p.y-2,p.x+2*midw+2,p.y+2*midh+2));
end;

{***************** CardMouseDown **************}
procedure TForm1.CardMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
{Get ready to move a card}
var
i:integer;
begin
dragflag:=true;
{move mouse to center of card for dragging}
with tcard(sender) do
mouse.cursorpos:=point(self.left+left+midw,self.top+top+midh);
slotfrom:=0;
{if card being dragged from a slot, mark the slot as available}
for i:=1 to 9 do
with cardslots[i] do
if occupiedby=sender then
begin
occupiedby:=nil;
slotfrom:=i;
break;
end;
end;

{***************** CardMouseMove **********}
procedure TForm1.CardMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
{If being dragged. move the card}
begin
If dragflag then
with sender as TCard do
begin
left:=left+x-midw;
top:=top+y-midh;
end;
end;

{update sum labels and return true if T is full and sums are equal}
var
j:integer;
sum1,sum2:integer;
fullT:boolean;
begin
fullt:=true; {are all positions occupied? flag}
sum1:=0;
for j:=1 to 5 do
with cardslots[j] do if occupiedby<> nil then
with occupiedby do sum1:=sum1+value
else fullT:=false;
rowlbl.caption:='Crossbar sum is '+inttostr(sum1);
if cardslots[3].occupiedby<>nil then sum2:=cardslots[3].occupiedby.value
else sum2:=0;
for j:=6 to 9 do
with cardslots[j] do if occupiedby<> nil then
with occupiedby do sum2:=sum2+value
else fullT:=false;
collbl.caption:='Upright sum is '+inttostr(sum2);
if fullt and (sum1=sum2) then result:=true
else result:=false;
end;

{******************** CardMouseUp *************}
procedure TForm1.CardMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
{if being dragged, drop the card on an empty position in the T,
or in its off-T home resting place}
var
i:integer;
carddropped:boolean;
a:array[1..4] of integer;
n:integer;
solutionnbr:integer;
begin
if dragflag then
with sender as TCard do
begin
dragflag:=false;
carddropped:=false;
for i:=1 to 9 do
with cardslots[i] do
if (abs(left- p.x)<midw) and (abs(top-p.y)<midh)
then
begin
if slotfrom>0 then
begin
with cardslots[slotfrom] do
begin
occupiedby:=cardslots[i].occupiedby;
if occupiedby<>nil then
begin
occupiedby.left:=p.x;
occupiedby.top:=p.y;
end;
end;
occupiedby:=nil;
end;
if (occupiedby=nil)
then
with tcard(sender) do
begin  {drop card on cardslot}
left:=p.x;
top:=p.y;
occupiedby:=TCard(sender);
carddropped:=true;
break;
end
else
end;
if not carddropped then movecardtohome(Tcard(sender));
if UpdateSums then {sums were equal}
begin
for i:=6 to 9 do a[i-5]:=cardslots[i].occupiedby.value;
n:=cardslots[3].occupiedby.value;
if IsNewSolution(n, a, solutionnbr) then
begin
statuslbl.caption:='New solution found!'+#13+'(#'+inttostr(solutionnbr)+' of 18)';
with stringgrid1 do cells[n div 2+1,2] :=
inttostr(strtoint(cells[n div 2+1,2])+1);
if fileexists('toot.wav') then playsound('toot.wav',0,snd_nowait)
else messagebeep(mb_iconexclamation);;
end
else if solutionNbr>0
then
begin
statuslbl.caption:='This solution, (#'
+inttostr(solutionnbr) +'), has already been displayed';
beep;
end
else statuslbl.caption:='Not a solution, sums not equal';
end
else statuslbl.caption:='Not a solution, sums not equal';
end;
end;

{*************** ComputeSolutions *************}
procedure TForm1.ComputeSolutions;
{find all 18 solutions and put them in the allsolutions list}
var
i,sum:integer;
n:integer;
s1,s2:string;
OK:boolean;

begin
for i:=1 to 9 do solutioncounts[i]:=0; {keep solution counts  in and array
indexed by intersecting card value}
with combos do
begin
setup(4,9,combinations); {get 4 of 9 combinations}
{we're going to select all possible ways to select 4 of 9 cards and
see which of them could form a solution row}
while getnextcombo do
begin
{add up the 4 numbers in this combination}
sum:=selected[1];
for i:= 2 to 4 do sum:=sum+selected[i];
{Since the sum of all 9 numbers is 45, the sum of any eight, (excluding
the number that will appear where the row and column intersect) will
range from 36 (45-9) to 44 (45-1).  The sum of the 4 row numbers must
equal the sum of the 4 column numbers so the sum of all eight must be
divisible by 2.  This means that the number at the intersection must be
odd, i.e. 1,3,5,7 or 9 since only 45 - an odd number will be even.
Thus the sum of the 4 row numbers must be 18, 19, 20, 21, or 22.
}
if (sum>=18) and (sum<=22) then
begin
{calculate the intersection number for this sum and make sure that it
is not in the combination selected}
n:=(22-sum)*2+1;
ok:=true;
{if n is not in selected then this may be a solution, unless it
it is the column matching a row that has previously been selected}

s1:='';
for i:=1 to 4 do {if the card which should be intersecting is already
in the 4 cards selected, this cannot be a solution}
begin
s1:=s1+inttostr(selected[i]);
if selected[i]=n then
begin
Ok:=false;
break;
end;
end;

If OK then
begin
{still not a solution if
it is the column matching a row that has previously been selected}

{Build a string with the intersection number plus the other 4 digits
that are not in the selected combo}
s2:='';
for i:=1 to 9 do
if (i<>n) and (pos(char(ord('0')+i),s1)=0) then s2:=s2+inttostr(i);
if (allsolutions.indexof(inttostr(n)+s1)>=0) then OK:=false
{it's not, so we have found a solution}
end;
if OK then
begin
inc(solutioncounts[n])
end;
end;
end;
end;
end;

{**************** IsNewSolution *************}
function Tform1.IsNewSolution(intersecting:integer;
a:array of integer;
var solutionnbr:integer):boolean;
{search to see if s (a string made up pf the intersecting cad values plus the
values of card in array "a" is the upright of a  solution,
if not, check if the intersecting card together with the other 4 cards is a
solution}
var
i,j:integer;
t:integer;
s,s2:string;
n:integer;
begin
result:=false;
{is it a possible solution based on sums?}
{It is if 45 + intersecting digit = 2* sum(other 4 digits)}
n:=intersecting;
solutionNbr:=0;
for i:=low(a) to high(a) do n:=n+a[i];
if 2*n<>45+intersecting then exit;

{Sums OK, now check to make sure it has not already been found}
{first sort the 4 digits of a in ascending order}
for i:= low(a) to high(a)-1 do for j:= i+1 to high(a) do if a[i]>a[j] then
begin  t:=a[i]; a[i]:=a[j]; a[j]:=t; end;
s:=inttostr(intersecting);
{build a string, s2, of the other 4 cards}
for i:=low(a) to high(a) do s:=s+inttostr(a[i]);
s2:=s[1];
for i:=1 to 9 do
if (i<>intersecting) and (pos(char(ord('0')+i),s)=0) then s2:=s2+inttostr(i);
{if neither set of intersecting card plus the other 4 cards is in the solution
list then this must be a new one}
if solutionlist.indexof(s)<0 then
begin
if solutionlist.indexof(s2)<0 then
begin
result:=true;
end;
end;

solutionnbr:=allsolutions.indexof(s)+1;
if solutionnbr <=0 then solutionnbr:=allsolutions.indexof(s2)+1;
end;

{************** ShowSolutionBtnClick *************}
procedure TForm1.ShowSolutionBtnClick(Sender: TObject);
{user asked to see a specific solution}
var
s:string;
i,j:integer;
begin
s:=allsolutions[shownbr.value-1];
movecardtoslot(cards[strtoint(s[1])],3);
for i:=2 to 5 do movecardtoslot(cards[strtoint(s[i])],i+4);
j:=0;
for i:=1 to 9 do if pos(char(ord('0')+i),s)=0 then
begin
inc(j);
if j=3 then inc(j);
movecardtoslot(cards[i],j);
end;