home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS - Coast to Coast / simteldosarchivecoasttocoast.iso / pcmag / vol9n04.zip / GCARDS.PAS < prev    next >
Pascal/Delphi Source File  |  1989-10-23  |  6KB  |  196 lines
  1. {$A+,B-,D-,E-,F-,I+,L-,N-,O-,R-,S-,V-}
  2. {$M 16384,0,655360}
  3. UNIT GCards;
  4. {Graphic Cards, assumes EGA Hi-Res mode}
  5. (**********************)
  6. (**)   INTERFACE    (**)
  7. (**********************)
  8. USES Crt, Graph, Cards;
  9.  
  10. TYPE
  11.   GCardP = ^GCard;
  12.   GDeckP = ^GDeck;
  13.  
  14.   AllSettings = RECORD
  15.     FI : FillSettingsType;
  16.     FP : FillPatternType;
  17.     CO : Word;
  18.     TS : TextSettingsType;
  19.     LI : LineSettingsType;
  20.   END;
  21.  
  22.   pipLocation = array[0..9] of ARRAY[0..1] of byte;
  23.  
  24.   GCard = OBJECT (Card)
  25.     BigPip, SmPip : Pointer;
  26.     PL            : ^PipLocation;
  27.     CONSTRUCTOR Init(iValue:Word;iTC:byte;iFaceUp:Boolean);
  28.     CONSTRUCTOR InitXY(iValue,iX,iY:Word;
  29.                iTC:Byte;iFaceUp:Boolean);
  30.     DESTRUCTOR Done; virtual;
  31.   {-next 4 routines locate card where you say}
  32.     PROCEDURE DrawAt(vX,vY:word); Virtual;
  33.     PROCEDURE HideAt(vX,vY:Word); Virtual;
  34.     PROCEDURE PointTo(vX,vY:Word;dire:direction); Virtual;
  35.     PROCEDURE UnPoint(vX,vY:Word;dire:direction); Virtual;
  36.   END;
  37.  
  38.   GDeck = OBJECT (Deck)
  39.     CONSTRUCTOR Init(iX,iY:Word;iTC:Byte);
  40.     DESTRUCTOR Done; virtual;
  41.   END;
  42.  
  43. (**********************)
  44. (**) IMPLEMENTATION (**)
  45. (**********************)
  46. CONST
  47.   {pip locations on the cards}
  48.   {reason for math is: first number is place of CENTER
  49.    of pip.  Second is adjust for PUTIMAGE}
  50.   R=20-12; S=25-13; T=30-12; U=40-12; V=50-13;
  51.   W=60-12; X=70-12; Y=75-13; Z=80-12;
  52.   pLocs : array[0..12] of PipLocation =
  53. {A}(((0,0),(V,V),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0)),
  54. {2} ((V,R),(0,0),(V,Z),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0)),
  55. {3} ((V,R),(V,V),(V,Z),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0)),
  56. {4} ((S,R),(0,0),(S,Z),(0,0),(0,0),(Y,R),(0,0),(Y,Z),(0,0),(0,0)),
  57. {5} ((S,R),(0,0),(S,Z),(V,V),(0,0),(Y,R),(0,0),(Y,Z),(0,0),(0,0)),
  58. {6} ((S,R),(S,V),(0,0),(S,Z),(0,0),(0,0),(Y,R),(Y,V),(0,0),(Y,Z)),
  59. {7} ((S,R),(S,V),(0,0),(S,Z),(V,T),(0,0),(Y,R),(Y,V),(0,0),(Y,Z)),
  60. {8} ((S,R),(S,V),(0,0),(S,Z),(V,T),(V,X),(Y,R),(Y,V),(0,0),(Y,Z)),
  61. {9} ((S,R),(S,U),(S,W),(S,Z),(V,V),(0,0),(Y,R),(Y,U),(Y,W),(Y,Z)),
  62. {T} ((S,R),(S,U),(S,W),(S,Z),(V,T),(V,X),(Y,R),(Y,U),(Y,W),(Y,Z)),
  63. {J} ((T,S),(X,Y),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0)),
  64. {Q} ((T,S),(X,Y),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0)),
  65. {K} ((T,S),(X,Y),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0)));
  66.  
  67.  
  68.   {OBJ files contain bitmaps for the pips}
  69.   {$L Heart}    PROCEDURE Heart;    External;
  70.   {$L Diamond}  PROCEDURE Diamond;  External;
  71.   {$L Club}     PROCEDURE Club;     External;
  72.   {$L Spade}    PROCEDURE Spade;    External;
  73.   {$L LHeart}   PROCEDURE LHeart;   External;
  74.   {$L LDiamond} PROCEDURE LDiamond; External;
  75.   {$L LClub}    PROCEDURE LClub;    External;
  76.   {$L LSpade}   PROCEDURE LSpade;   External;
  77.  
  78.   {$L CardBack} PROCEDURE CardBack; External;
  79.  
  80.   CONSTRUCTOR GCard.Init(iValue:Word;iTC:Byte;iFaceUp:Boolean);
  81.   BEGIN
  82.     Card.Init(iValue,iTC,iFaceUp);
  83.     IF value >=26 THEN PipColor := brown;
  84.     CASE getSuit OF
  85.       0:BEGIN BigPip := @Heart;   SmPip := @LHeart;   END;
  86.       1:BEGIN BigPip := @Diamond; SmPip := @LDiamond; END;
  87.       2:BEGIN BigPip := @Club;    SmPip := @LClub;    END;
  88.       3:BEGIN BigPip := @Spade;   SmPip := @LSpade;   END;
  89.     END;
  90.     PL := @PLocs[GetRank];
  91.   END;
  92.  
  93.   CONSTRUCTOR GCard.InitXY(iValue,iX,iY:Word;
  94.                iTC:Byte;iFaceUp:Boolean);
  95.   BEGIN Init(iValue,iTC,iFaceUp); PutInPlace(iX,iY); END;
  96.  
  97.   DESTRUCTOR GCard.Done; BEGIN Card.done; END;
  98.  
  99.   PROCEDURE SaveAll(VAR AS : AllSettings);
  100.   BEGIN
  101.     WITH AS DO
  102.       BEGIN
  103.         CO := GetColor;
  104.         GetFillSettings(FI);
  105.         IF FI.pattern = UserFill THEN GetFillPattern(FP);
  106.         GetTextSettings(TS);
  107.         GetLineSettings(LI);
  108.       END;
  109.   END;
  110.  
  111.   PROCEDURE RestoreAll(VAR AS : AllSettings);
  112.   BEGIN
  113.     WITH AS DO
  114.       BEGIN
  115.         WITH TS DO
  116.           BEGIN
  117.             SetTextJustify(Horiz, Vert);
  118.             SetTextStyle(Font, Direction, CharSize);
  119.           END;
  120.         SetFillStyle(FI.pattern,FI.color);
  121.         IF FI.pattern = UserFill THEN SetFillPattern(FP,FI.color);
  122.         SetColor(CO);
  123.         WITH LI DO SetLineStyle(LineStyle, Pattern,Thickness);
  124.       END;
  125.   END;
  126.  
  127.   PROCEDURE GCard.DrawAt(vX,vY:word);
  128.   VAR A : AllSettings;
  129.  
  130.     PROCEDURE CardAt(X,Y,valu:Word);
  131.     VAR N : Byte;
  132.     BEGIN
  133.       {--- draw the white playing card ---}
  134.       SetColor(White);
  135.       SetFillStyle(solidfill,White);
  136.       Bar(X,Y,X+100,Y+100);
  137.       {--- put the rank in the corner ---}
  138.       SetTextJustify(LeftText,TopText);
  139.       SetTextStyle(SansSerifFont,HorizDir,1);
  140.       SetColor(PipColor);
  141.       OutTextXY(X+2,Y+2,pips[GetRank]);
  142.       PutImage(X+2,Y+21,SmPip^,AndPut);
  143.       {--- draw diagonal swatch for face cards ---}
  144.       IF GetRank > 9 THEN
  145.         BEGIN
  146.           Rectangle(x+12,Y+12,x+88,Y+88);
  147.           FOR N := 1 to 12 DO line(x+12,y+64+2*N,x+64+2*n,Y+12);
  148.           FOR N := 1 to 12 DO line(x+12+2*N,Y+88,x+88,y+12+2*N);
  149.         END;
  150.       {--- put the pips in place ---}
  151.       FOR N := 0 to 9 DO
  152.         IF PL^[N][0] > 0 THEN
  153.           PutImage(X+PL^[N][0],Y+PL^[N][1],BigPip^,AndPut);
  154.     END;
  155.  
  156.     PROCEDURE CardBackAt(X,Y:Word);
  157.     BEGIN PutImage(X,Y,@CardBack^,CopyPut); END;
  158.  
  159.   BEGIN
  160.     SaveAll(A);
  161.     IF FaceUp THEN CardAt(vX,vY,Value)
  162.     ELSE CardBackAt(vX,vY);
  163.     RestoreAll(A);
  164.   END;
  165.  
  166.   PROCEDURE GCard.HideAt(vX,vY:word);
  167.   VAR A : AllSettings;
  168.   BEGIN
  169.     SaveAll(A);    SetFillStyle(solidFill,GetBkColor);
  170.     Bar(vX,vY,vX+100,vY+100);           RestoreAll(A);
  171.   END;
  172.  
  173.   PROCEDURE GCard.PointTo(vX,vY:Word;dire:direction);
  174.   VAR A : AllSettings;
  175.   BEGIN
  176.     SaveAll(A);                       SetColor(white);
  177.     Rectangle(vX-2,vY-2,vX+102,vY+102); RestoreAll(A);
  178.   END;
  179.  
  180.   PROCEDURE GCard.UnPoint(vX,vY:Word;dire:direction);
  181.   VAR A : AllSettings;
  182.   BEGIN
  183.     SaveAll(A);                  SetColor(TableColor);
  184.     Rectangle(vX-2,vY-2,vX+102,vY+102); RestoreAll(A);
  185.   END;
  186.  
  187.   CONSTRUCTOR GDeck.Init(iX,iY:Word;iTC:Byte);
  188.   VAR valu : Word;
  189.   BEGIN
  190.     Pile.Init(iX,iY,no);
  191.     FOR valu := 0 to 51 DO AddCard(New(GCardP,Init(valu,iTC,false)));
  192.   END;
  193.  
  194.   DESTRUCTOR GDeck.done; BEGIN Deck.Done; END;
  195.  
  196. END.