(*  unit:        Cards
    version:     3 (1.1)
    release:     July 2002
    developed:   2001-2002
    environment: Borland Delphi 5
    --------------------------------------------------
    author: Thomas Lackó
    web:    http://thomas.sk
    e-mail: thomas.lacko@gmail.com
*)

unit Cards;

INTERFACE

uses Windows,Messages,SysUtils,Classes,Graphics,Controls,Forms,Dialogs;
const
  UnitVersion = $02070003;
  CardWidth=72; CardHeight=100;
  NoCard=0; cardA=1; cardJ=11; cardQ=12; cardK=13; Joker=14;
type
  TCard=class(TGraphicControl)
   private
    S:Single;
    B:Integer;
    C,V:Byte;
    F,NA:Boolean;
    procedure SetSize(x:Single);
    procedure SetColor(x:Byte);
    procedure SetValue(x:Byte);
    procedure SetFace(x:Boolean);
    procedure SetBack(x:Integer);
    procedure SetNiceAce(x:Boolean);
    procedure DrawCard(y,x:Integer);
   protected
    procedure Paint; override;
   published
    property Size:Single read S write SetSize;
    property Color:Byte read C write SetColor;
    property Value:Byte read V write SetValue;
    property Face:Boolean read F write SetFace;
    property Back:Integer read B write SetBack;
    property NiceAce:Boolean read NA write SetNiceAce;
   public
    procedure Turn;
    constructor Create(AOwner:TComponent); override;
  end;
  TPack=class
   private
    C:array of TCard;
    function  GetC(i:Integer):TCard;
    procedure SetColor(x:Byte);
    procedure SetValue(x:Byte);
    procedure SetBack(x:Integer);
    procedure SetFace(x:Boolean);
    procedure SetNiceAce(x:Boolean);
    procedure SetSize(x:Single);
    procedure SetVisibility(x:Boolean);
    {procedure Arrange; virtual;}
   public
    function  Count:Integer;
    property  Card[i:Integer]:TCard read GetC; default;
    property  Color:Byte write SetColor;
    property  Value:Byte write SetValue;
    property  Back:Integer write SetBack;
    property  Face:Boolean write SetFace;
    property  NiceAce:Boolean write SetNiceAce;
    property  Size:Single write SetSize;
    property  Visible:Boolean write SetVisibility;
    procedure Show;
    procedure Hide;
    procedure Turn;
    procedure Mix; virtual;
    procedure Add(Card:TCard);
    procedure Insert(Card:TCard;i:Integer); virtual;
    function  Find(Color,Value:Byte):TCard;
    function  IndexOf(Color,Value:Byte):Integer; overload;
    function  IndexOf(Card:TCard):Integer; overload;
    function  Remove(i:Integer):TCard; overload; virtual;
    function  Remove(Color,Value:Byte):TCard; overload;
    procedure Remove(Card:TCard); overload;
    procedure Delete(i:Integer); overload;
    procedure Delete(Color,Value:Byte); overload;
    function  DeleteAll(Color,Value:Byte):Integer;
    function  Delete(Card:TCard):Integer; overload;
    constructor CreatePack(aOwner:TComponent;aParent:TWinControl;
                   aFace:Boolean=True;Jokers:Integer=0;aBack:Integer=0);
    destructor  Destroy; override;
  end;
var CardsBitmap:TBitmap;

{procedure Register;}

IMPLEMENTATION

const
  CW=CardWidth-4; CH=CardHeight-4;
  CardPolygon:array[0..7] of TPoint=(
    (X:3;Y:0),(X:CardWidth-4;Y:0),(X:CardWidth-1;Y:3),(X:CardWidth-1;Y:CardHeight-4),
    (X:CardWidth-4;Y:CardHeight-1),(X:3;Y:CardHeight-1),(X:0;Y:CardHeight-4),(X:0;Y:3));

{ ===== TCard ===== }

constructor TCard.Create(AOwner:TComponent);
begin
  inherited Create(AOwner);
  Canvas.Pen.Color:=clBlack; Canvas.Brush.Color:=clWhite;
  S:=1; C:=0; V:=0; B:=0; F:=True; NA:=False;
  Width:=CardWidth; Height:=CardHeight;
end;

procedure TCard.SetColor(x:Byte);
begin
  if C=x then Exit;
  C:=x; if Visible and Face then Paint;
end;

procedure TCard.SetValue(x:Byte);
begin
  if V=x then Exit;
  V:=x; if Visible and Face then Paint;
end;

procedure TCard.SetBack(x:Integer);
begin
  if B=x then Exit;
  B:=x; if Visible and not Face then Paint;
end;

procedure TCard.SetFace(x:Boolean);
begin
  if F=x then Exit;
  F:=x; if Visible then Paint;
end;

procedure TCard.SetNiceAce(x:Boolean);
begin
  if NA=x then Exit;
  NA:=x; if Visible and Face and (Color=1) and (Value=cardA) then Paint;
end;

procedure TCard.SetSize(x:Single);
begin
  if (S=x) or (x<=0) then Exit;
  Width:=2+Round((CardWidth-2)*x); Height:=2+Round((CardHeight-2)*x);
  S:=x; if Visible then Paint;
end;

procedure TCard.Turn;
begin SetFace(not F) end;

procedure TCard.DrawCard(y,x:Integer);
var RS,RD:TRect;
begin
  with RD do
    if S=1 then begin
      Left:=2; Right:=2+CW; Top:=2; Bottom:=2+CH;
    end
    else begin
      Left:=1+Round(S); Right:=1+Round((CW+1)*S);
      Top:=1+Round(S); Bottom:=1+Round((CH+1)*S);
    end;
  if CardsBitmap=nil then Canvas.Rectangle(RD)
  else begin
    with RS do begin
      Left:=CW*x; Right:=Left+CW; Top:=CH*y; Bottom:=Top+CH;
    end;
    Canvas.CopyRect(RD,CardsBitmap.Canvas,RS);
  end;
end;

procedure TCard.Paint;
begin
  if S=1 then Canvas.Polygon(CardPolygon)
  else Canvas.RoundRect(0,0,Width,Height,Round(7*S),Round(7*S));
  if not Face then DrawCard((Back+3) mod 4,13+(Back+3) div 4)
  else if (Color=1) and (Value=cardA) and (NiceAce) then DrawCard(0,13)
  else if (Color in [1..4]) and (Value in [cardA..cardK]) then DrawCard(Color-1,Value-1)
  else if Value=Joker then DrawCard(2,13)
  else DrawCard(1,13);
end;

{ ===== TPack ===== }

constructor TPack.CreatePack(aOwner:TComponent;aParent:TWinControl;aFace:Boolean;Jokers,aBack:Integer);
var q,qq:Integer; t:TCard;
begin
  inherited Create; SetLength(C,13*4+Jokers);
  for q:=0 to Jokers-1 do begin
    t:=TCard.Create(aOwner);
    with t do begin
      Parent:=aParent; Value:=Joker; Face:=aFace; Back:=aBack;
    end;
    C[13*4+q]:=t;
  end;
  for qq:=4 downto 1 do
    for q:=cardK downto cardA do begin
      t:=TCard.Create(aOwner);
      with t do begin
        Parent:=aParent; Color:=qq; Value:=q; Face:=aFace; Back:=aBack;
      end;
      C[qq*13+q-14]:=t;
    end;
end;

destructor TPack.Destroy;
var q:Integer;
begin
  for q:=0 to High(C) do C[q].Free;
  SetLength(C,0); inherited;
end;

function TPack.GetC(i:Integer):TCard;
begin if i in [0..High(C)] then Result:=C[i] else Result:=nil end;

procedure TPack.SetColor(x:Byte);
var q:Integer;
begin
  for q:=0 to High(C) do
    if C[q]<>nil then C[q].Color:=x;
end;

procedure TPack.SetValue(x:Byte);
var q:Integer;
begin
  for q:=0 to High(C) do
    if C[q]<>nil then C[q].Value:=x;
end;

procedure TPack.SetBack(x:Integer);
var q:Integer;
begin
  for q:=0 to High(C) do
    if C[q]<>nil then C[q].Back:=x;
end;

procedure TPack.SetFace(x:Boolean);
var q:Integer;
begin
  for q:=0 to High(C) do
    if C[q]<>nil then C[q].Face:=x;
end;

procedure TPack.SetNiceAce(x:Boolean);
var q:Integer;
begin
  for q:=0 to High(C) do
    if C[q]<>nil then C[q].NiceAce:=x;
end;

procedure TPack.SetSize(x:Single);
var q:Integer;
begin
  for q:=0 to High(C) do
    if C[q]<>nil then C[q].Size:=x;
end;

procedure TPack.SetVisibility(x:Boolean);
var q:Integer;
begin
  for q:=0 to High(C) do
    if C[q]<>nil then C[q].Visible:=x;
end;

{procedure TPack.Arrange;
var q,i:Integer;
begin
  i:=0;
  for q:=0 to High(C) do
    if C[q]<>nil then begin
      C[i]:=C[q]; Inc(i);
    end;
  SetLength(C,Length(C)-i);
end;}

function TPack.Count:Integer;
begin Result:=Length(C) end;

procedure TPack.Show;
var q:Integer;
begin
  for q:=0 to High(C) do
    if C[q]<>nil then C[q].Show;
end;

procedure TPack.Hide;
var q:Integer;
begin
  for q:=0 to High(C) do
    if C[q]<>nil then C[q].Hide;
end;

procedure TPack.Turn;
var q:Integer;
begin
  for q:=0 to High(C) do
    if C[q]<>nil then C[q].Turn;
end;

procedure TPack.Mix;
var q,i:Integer; t:TCard;
begin
  {Arrange;}
  for q:=High(C) downto 0 do begin
    i:=Random(q+1); t:=C[q]; C[q]:=C[i]; C[i]:=t;
  end;
end;

procedure TPack.Add(Card:TCard);
begin Insert(Card,Length(C)) end;

procedure TPack.Insert(Card:TCard;i:Integer);
var q:Integer;
begin
  q:=Length(C); if (i<0) or (i>q) then Exit;
  SetLength(C,q+1);
  while q>i do begin
    C[q]:=C[q-1]; Dec(q);
  end;
  C[i]:=Card;
end;

function TPack.Find(Color,Value:Byte):TCard;
begin Result:=C[IndexOf(Color,Value)] end;

function TPack.IndexOf(Color,Value:Byte):Integer;
var L:Integer;
begin
  Result:=0; L:=Length(C);
  repeat
    if Color<>0 then
      if Value<>0 then
        while (Result<L) and ((C[Result].Color<>Color) or (C[Result].Value<>Value)) do Inc(Result)
      else while (Result<L) and (C[Result].Color<>Color) do Inc(Result)
    else if Value<>0 then while (Result<L) and (C[Result].Value<>Value) do Inc(Result);
  until (Result>=L) or (C[Result]<>nil);
  if Result>=L then Result:=-1;
end;

function TPack.IndexOf(Card:TCard):Integer;
var L:Integer;
begin
  Result:=0; L:=Length(C);
  while (Result<L) and (C[Result]<>Card) do Inc(Result);
  if Result=L then Result:=-1;
end;

function TPack.Remove(i:Integer):TCard;
var q:Integer;
begin
  if (i<0) or (i>=Length(C)) then Result:=nil
  else begin
    Result:=C[i];
    for q:=i to Length(C)-2 do C[q]:=C[q+1];
    SetLength(C,Length(C)-1);
  end;
end;

function TPack.Remove(Color,Value:Byte):TCard;
begin Result:=Remove(IndexOf(Color,Value)) end;

procedure TPack.Remove(Card:TCard);
begin Remove(IndexOf(Card)) end;

procedure TPack.Delete(i:Integer);
begin Remove(i).Free end;

procedure TPack.Delete(Color,Value:Byte);
begin Delete(IndexOf(Color,Value)) end;

function TPack.DeleteAll(Color,Value:Byte):Integer;
var q:Integer;
begin
  Result:=0; q:=0;
  while q<Length(C) do
    if (C[q].Color=Color) and (C[q].Value=Value) then begin
      Remove(q).Free; Inc(Result);
    end
    else Inc(q);
end;

function TPack.Delete(Card:TCard):Integer;
var q:Integer;
begin
  Result:=0; q:=0;
  while q<Length(C) do
    if C[q]=Card then begin
      Remove(q); Inc(Result);
    end
    else Inc(q);
  Card.Free;
end;

{procedure Register;
begin
  RegisterComponents('Thomas',[TCard]);
end;}

initialization
  if FileExists(ExtractFilePath(ParamStr(0))+'cards.bmp') then begin
    CardsBitmap:=TBitmap.Create;
    CardsBitmap.LoadFromFile(ExtractFilePath(ParamStr(0))+'cards.bmp');
  end
  else CardsBitmap:=nil;
finalization
  CardsBitmap.Free;
end.
