Not sure if it is me or FBImage.
ImageDestroy fails upon destruction of type.
Code: Select all
/' based on rdc's "cardobj"
* Name: cardobj.bi
*
* Synopsis: Card object file.
*
* Description: The card object handles all the displaying of the cards as well
* defining the card numbers, suits and values.
*
* Copyright 2010, Richard D. Clark
*
* The Wide Open License (WOL)
*
* Permission to use, copy, modify, distribute and sell this software and its
* documentation for any purpose is hereby granted without fee, provided that
* the above copyright notice and this license appear in all source copies.
* THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED WARRANTY OF
* ANY KIND. See http://www.dspguru.com/wol.htm for more information.
*
(ABOVE URL NOT VALID)
'/
'Shared vars
ReDim Shared As Integer Deck(0) 'redim upon CreatePlayDeck or CreateNSPlayDeck
Dim Shared As Integer ScrX, ScrY 'display info (set when 'Dim as Card CardObj')
#Include Once "FBImage.bi"
'Define True/False values.
#Ifndef FALSE
#Define FALSE 0
#Define TRUE (Not FALSE)
#EndIf
'Create a NULL value.
#Ifndef NULL
#Define NULL 0
#EndIf
'Const rgbGray = RGB(127, 127, 127)
'Const rgbWhite = RGB(255, 255, 255)
Type RowCol
As Integer Row,Col
End Type
Type Card
'Declare Property CardWidth() As Integer
'Declare Property CardHeight() As Integer
'Declare Property LabelWidth() As Integer
'Declare Property LabelHeight() As Integer
Declare Sub ClearCards() 'allow new graphic, or executed on destruction
'Declare Sub DrawPlace(ByVal x As Integer, ByVal y As Integer, border As UInteger = rgbWhite, backg As UInteger = rgbGray)
'Declare Sub GetCardGraphic(GetCard As RowCol, tp As Any Ptr)
'Declare Sub DrawImg(ByVal XLoc As Integer, ByVal YLoc As Integer, GetCard As Integer, Selected As Integer, Rot As Single=0) 'Rot not active
'Declare Sub DrawImg(ByVal XLoc As Integer, ByVal YLoc As Integer, GetCard As RowCol, Selected As Integer, Rot As Single=0) 'Rot not active
'Declare Sub SetBackCard()
'Declare Function Face(C As Integer) As Integer
'Declare Function FaceStr(C As Integer) As String
'Declare Function Suit(C As Integer) As Integer
'Declare Function SuitStr(C As Integer) As String
'Declare Function FullStr(C As Integer) As String
'
'return values of these are only valid for "non jokers"
'Declare Function SameVal(C As Integer,C2 As Integer) As Integer
'Declare Function SameSuit(C As Integer,C2 As Integer) As Integer
'Declare Function SameColor(C As Integer,C2 As Integer) As Integer
'
'full deck creation and suffling
'Declare Sub ShuffleDeck()
Declare Function CreatePlayDeck(NumDecks As Integer, UseJokers As Integer=0, DeckName As String="Standard") As Integer
Declare Function CreateNSPlayDeck Cdecl (NumDecks As Integer, NumSuits As Integer, NumCardsPerSuit As Integer, UseJokers As Integer, ...) As Integer 'DeckName can be specified as last param
'
'THESE ARE TYPE USE ONLY
Declare Constructor()
Declare Destructor()
Declare Sub Load_Normal(DeckName As String) 'left in to show how it is actually loaded
Declare Sub Load(DeckName As String) 'test just for this
As String ConfigFile
As String GraphicFile
As Any Ptr AllCardsGr
'how data is referenced
As Integer DataFlag
'Initial offset
As Integer InitOffsetX
As Integer InitOffsetY
'Offset between cards
As Integer NextOffsetX
As Integer NextOffsetY
'width and height of whole card
As Integer CardW
As Integer CardH
'width and height of card "label" (upper left and bottom right corner)
As Integer LabelW
As Integer LabelH
'location of each card's graphic
As RowCol Deck52(51) 'there is always 52 cards in standard deck
'
As RowCol JokerRed, JokerBlack
As Integer Jokers 'non-zero if Jokers are in graphics
'
As RowCol Backs(Any)
As Integer NumBacks 'number of backs available >0
As Integer CurBackGr 'Back in use *zero based index of Backs*
'
'"Special" graphics
As Integer Special
As RowCol SpecialRC(Any)
End Type
Constructor Card()
AllCardsGr = NULL
'ScreenInfo [ w ] [, [ h ] [, [ depth ] [ , [ bpp ] [ , [ pitch ] [ , [ rate ] [, driver ]]]]]
ScreenInfo(ScrX, ScrY)
End Constructor
Destructor Card()
Cls
Print "Card destructor fired"
ClearCards()
Print "Cards cleared"
Sleep 2000
End Destructor
Sub Card.ClearCards()
If AllCardsGr <> NULL Then
Print "Destroying img ptr"
ImageDestroy(AllCardsGr)
AllCardsGr = NULL
Beep
Print "Image destroyed"
EndIf
End Sub
'test Load
Sub Card.Load(DeckName As String)
Dim As String RootPath = ExePath + "/" 'using common path delimiter
Dim As String LoadDeck
'
If ConfigFile <> DeckName Then
ConfigFile = DeckName
'
'Open RootPath + DeckName + ".ini" For Input As #ff
'data read in by ini file
LoadDeck = "cards.bmp" 'change to what is needed to test
'ini file closed ....
'
If GraphicFile <> LoadDeck Then
ClearCards()
'store graphic file name
GraphicFile = LoadDeck
AllCardsGr = LoadRGBAFile(RootPath + LoadDeck) 'use FBImage
EndIf
EndIf
End Sub
'NON-USER!
Sub Card.Load_Normal(DeckName As String)
Dim LoadDeck As String
Dim As Integer FF = FreeFile
Dim As String RootPath = ExePath + "/" 'using common path delimiter
Dim As Integer x, y
'
If ConfigFile <> DeckName Then
'not going to check for file existance, programmer should know that it is there....
Open RootPath + DeckName + ".ini" For Input As #ff
'If statement here, just in case some quirk in opening of file
If Err = 0 Then
'store config file name
ConfigFile = DeckName
'image file path
'can be relative with no beginning slash "Graphics/MysteryCards.bmp"
Input #FF, LoadDeck
'on load use first "back"
CurBackGr = 0
Input #FF, NumBacks
ReDim Backs(NumBacks - 1)
For x = 0 To NumBacks - 1
Input #FF, Backs(x).Row
Input #FF, Backs(x).Col
Next
Input #FF, CardW
Input #FF, CardH
Input #FF, LabelW
Input #FF, LabelH
For x = 0 To 51
Input #FF, Deck52(x).Row
Input #FF, Deck52(x).Col
Next
'Jokers
Input #FF, Jokers 'non zero if exist
If Jokers Then
Input #FF, JokerRed.Row
Input #FF, JokerRed.Col
Input #FF, JokerBlack.Row
Input #FF, JokerBlack.Col
EndIf
'any special graphics?
Input #FF, Special 'number of graphics
If Special Then
ReDim SpecialRC(Special - 1)
For x = 1 To Special - 1
Input #FF, SpecialRC(x).Row
Input #FF, SpecialRC(x).Col
Next
EndIf
'v0.5 addition
If Eof(FF) = 0 Then
'DataFlag = 0 or not given -- calculated position of card
'DataFlag = non zero - Row/Col is actual location in graphic (no calculation needed)
Input #FF, DataFlag
'Offsets
Input #FF, InitOffsetX
Input #FF, InitOffsetY
Input #FF, NextOffsetX
Input #FF, NextOffsetY
EndIf
Close #FF
If GraphicFile <> LoadDeck Then
ClearCards()
'store graphic file name
GraphicFile = LoadDeck
'AllCardsGr = Cast(fb.Image Ptr, LoadRGBAFile(RootPath + LoadDeck)) 'use FBImage
AllCardsGr = LoadRGBAFile(RootPath + LoadDeck) 'use FBImage
EndIf
EndIf
EndIf
End Sub
Function Card.CreatePlayDeck(NumDecks As Integer, UseJokers As Integer=0, DeckName As String="Standard") As Integer
Dim As Integer TotCards = 52
Dim As Integer DeckL, CardL, ArrPos
'
Load(DeckName)
'check for load error
If AllCardsGr <> 0 Then
If UseJokers Then TotCards += 2
TotCards *= NumDecks
ReDim Deck(TotCards - 1)
'
ArrPos = 0 'ensure cleared var
For DeckL = 1 To NumDecks
For CardL = 0 To 51
Deck(ArrPos) = CardL
ArrPos += 1
Next
If UseJokers Then
Deck(ArrPos) = 52
ArrPos += 1
Deck(ArrPos) = 53
ArrPos += 1
EndIf
Next
Return 1
Else
ReDim Deck(0)
Return 0
EndIf
End Function
Function Card.CreateNSPlayDeck Cdecl (NumDecks As Integer, NumSuits As Integer, NumCardsPerSuit As Integer, UseJokers As Integer, ...) As Integer
Dim As String DeckName
Dim As Integer DeckL, SuitL, CardL, ArrPos 'loop vars
'
'read in param list
Dim As Any Ptr arg = va_first()
Dim As Integer ArgVal
'Suits
Dim As Integer SuitMult(1 To 4) = {0, 1, 2, 3}
If NumSuits < 4 Then
'read in
For ArrPos = 1 To NumSuits
SuitMult(ArrPos) = va_arg(arg, Integer) - 1
arg = va_next(arg, Integer)
Next
EndIf
'Pips per suit
Dim As Integer Pips(1 To 13) = {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12}
If NumCardsPerSuit < 13 Then
'read in
For ArrPos = 1 To NumCardsPerSuit
Pips(ArrPos) = va_arg(arg, Integer) - 1
arg = va_next(arg, Integer)
Next
EndIf
'Graphic card set specified?
arg = va_next(arg, Integer)
DeckL = va_arg(arg, Integer)
If DeckL Then
DeckName = *(va_arg(arg, ZString Ptr))
Else
DeckName = "Standard"
EndIf
'
Load(DeckName)
'check for load error
If AllCardsGr <> 0 Then
'total cards in deck
Dim As Integer TotCards = NumSuits * NumCardsPerSuit
If UseJokers Then TotCards += 2
TotCards *= NumDecks
ReDim Deck(TotCards - 1)
ArrPos = 0 'clear var
For DeckL = 1 To NumDecks
For CardL = 1 To NumCardsPerSuit
For SuitL = 1 To NumSuits
Deck(ArrPos) = Pips(CardL) + SuitMult(SuitL) * 13
ArrPos += 1
Next
Next
If UseJokers Then
Deck(ArrPos) = 52
ArrPos += 1
Deck(ArrPos) = 53
ArrPos += 1
EndIf
Next
Return 1
Else
ReDim Deck(0)
Return 0
EndIf
End Function
/' ini file requirements (RC is Row,Col of the graphic)
"cards.bmp" -- required [filename of graphic, can be relative with no beginning slash "Graphics/MysteryCards.bmp"]
3 -- required [number of backs]
4,2,4,3,4,4 [RC of each back]
71,96 -- required [width and height of cards]
13,27 -- required [width and height of upper left corner]
0,0,0,1,0,2,0,3,0,4,0,5,0,6,0,7,0,8,0,9,0,10,0,11,0,12 -- required [RC of Ace to King of Clubs]
1,0,1,1,1,2,1,3,1,4,1,5,1,6,1,7,1,8,1,9,1,10,1,11,1,12 -- required [RC of Ace to King of Diamonds]
2,0,2,1,2,2,2,3,2,4,2,5,2,6,2,7,2,8,2,9,2,10,2,11,2,12 -- required [RC of Ace to King of Hearts]
3,0,3,1,3,2,3,3,3,4,3,5,3,6,3,7,3,8,3,9,3,10,3,11,3,12 -- required [RC of Ace to King of Spades]
1 -- required (0 if no jokers, any other value if present)
4,0,4,1 [RC of both jokers only if above is not 0, otherwise omit]
2 -- required [number of special graphics]
4,5,4,6 [RC of special graphics, omit if none]
0,0 -- [x and y offset to first card]
0,0 -- [x and y offset between cards]
'/
Code: Select all
#Include "Cards_.bi"
Dim As Integer x, y, L
Randomize Timer
Screen 19, 32
Width 100, 75
Color , RGB(38, 127, 0)
Cls
WindowTitle "Cards_.bi - Card object test"
Dim As Card MyCardObj '<- Sets ScrX,ScrY
'one deck, with jokers (redim's Deck() array)
If MyCardObj.CreatePlayDeck(1, 1, "OneBack") Then
/' Just to show what it could do
MyCardObj.ShuffleDeck()
'display the deck
x = 1
y = 1
For L = 0 To UBound(Deck)
'display the card
MyCardObj.DrawImg x,y,Deck(L),0
'move screen loc
x += MyCardObj.CardWidth + 2
If x + MyCardObj.CardWidth > ScrX Then
'off screen
x = 1
y += MyCardObj.CardHeight
EndIf
Next
x = 1
y += MyCardObj.CardHeight
Draw String (x, y), "Press a key to continue", RGB(255, 255, 255)
L = GetKey
'
'pick random cards, name and compare them
Dim As Integer C1,C2
Dim As String R
For L = 1 To 5
Cls
C1 = Int(Rnd * 52)
Do
C2 = Int(Rnd * 52)
Loop While C1 = C2
MyCardObj.DrawImg 5,5,C1,0
Draw String (15+MyCardObj.CardWidth,15), MyCardObj.FullStr(C1), RGB(255, 255, 255)
'
MyCardObj.DrawImg 5,10 + MyCardObj.CardHeight,C2,0
Draw String (15+MyCardObj.CardWidth,15 + MyCardObj.CardHeight), MyCardObj.FullStr(C2), RGB(255, 255, 255)
R = "The 2 cards are:"
Draw String (5,15 + MyCardObj.CardHeight*2), R, RGB(255, 255, 255)
If MyCardObj.SameVal(C1,C2) Then
R = "T"
Else
R = "Not t"
EndIf
R += "he same value."
Draw String (15,25 + MyCardObj.CardHeight*2), R, RGB(255, 255, 255)
If MyCardObj.SameSuit(C1,C2) Then
R = "T"
Else
R = "Not t"
EndIf
R += "he same suit."
Draw String (15,35 + MyCardObj.CardHeight*2), R, RGB(255, 255, 255)
If MyCardObj.SameColor(C1,C2) Then
R = "T"
Else
R = "Not t"
EndIf
R += "he same color."
Draw String (15,45 + MyCardObj.CardHeight*2), R, RGB(255, 255, 255)
Draw String (15,60 + MyCardObj.CardHeight*2), "Press a key to continue", RGB(255, 255, 0)
C1 = GetKey
Next
'/
'
'just to show graphic loaded ....
'normally the pointer is not directly accessed
ImageInfo(MyCardObj.AllCardsGr, x, y)
Print "Graphic dim are";x;" by";y
Sleep 3000
Put (5, 5), MyCardObj.AllCardsGr, Trans
Sleep 3000
EndIf
Cls
Print "End of program, card destructor fired!"