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

{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);

{**************** AdjustGridSize *************}
procedure adjustGridSize(grid:TStringGrid);
{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;
  adjustgridsize(stringgrid1);
  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;

{*************** UpdateSuns **********}
function TForm1.UpdateSums:boolean;
{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
else allsolutions.add(inttostr(n)+s2);
{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;
      solutionlist.add(s2);
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;
  updatesums;
if shownbr.value<18
then shownbr.value:=shownbr.value+1
else shownbr.value:=1;
{Add to user solution list if not there, so user doesn't get credit for this one}
if solutionlist.IndexOf(s)<0 then solutionlist.Add(s);
end;

end.