OK. here is a game based on my card lib code
first, the Include File
save this as cards.bas
`converted to Include File
`27 June 2007
`by Norman E. Perry
`if not using norms debuger with globals
`enabled, copy the dims to main source file
`cards are organized by rank
`so, every 4th card is the same suit
`starting at 0 ending at 51
`special cards:
`52=Default Card Back (not pretty)
`54=Red X
`55=Green O
`58=Card Outline
Card_DLLS:
Dim CardDLL(1)
dim User32(1)
Function InitCards()
Dim CardDLL(1)
dim User32(1)
dim hDC(1)
dim hWin(1)
CardDLL(1)=loaddll( "cards.dll")
if CardDLL(1)=0
CardDLL(1)=loaddll( "cards32.dll")
if Carddll(1)=0
break "27 Unable to load cards.dll"
endif
endif
call dll CardDLL(1) , "cdtInit" , W$ , H$
User32(1) = loaddll( "User32")
endfunction
function FreeCards()
call dll CardDLL(1),"cdtTerm"
delete dll CardDLL(1)
CardDLL(1)=0
endfunction
function GetDLL(flag)
`Flag >0 gets next count
`Flag =0 gets current count
`flag = -1 cancel last count
`flag <-1 reset to 0
if flag
if flag>0
DLL = DLL +1
else
if flag<0-1
DLL = 0
else
DLL=DLL-1
endif
endif
endif
endfunction DLL
function FreeDLLs()
max=GetDLL(0)
if max
for n=1 to max
if dll exist(n) then delete dll n
next n
endif
GetDLL(-99)
endfunction
function LoadDLL(F$)
`returns DLL number on return
`or returns 0 on failure
DLL=GetDLL(1)
load dll F$,DLL
if dll exist(DLL)=0
break F$+"not found"
GetDLL(-1)
DLL=0
endif
endfunction DLL
function FullDraw(ID,X,Y,W,H)
`this function is verry slow,
`but show the calls required to
`draw a card
hWIN = call dll( User32(1) , "GetActiveWindow" , 0)
lock backbuffer
hdc=call dll( User32(1),"GetDC",hWIN)
Call dll CardDLL(1),"cdtDrawExt",hdc,X,Y,80,100,ID,0,0
call dll User32(1),"ReleaseDC",hWin,hdc
unlock backbuffer
endfunction
function GetImage(flag)
if flag>1 then flag=1
ImageID=ImageID+flag
if ImageID<0 then ImageID=0
endfunction ImageID
function FreeImages()
max=GetImage(0)
if max
for n=1 to max
if image exist(n) then delete image n
next n
GetImage(-99999)
endif
endfunction
function CopyCard(ID)
hWIN = call dll( User32(1) , "GetActiveWindow" , 0)
hdc=call dll( User32(1),"GetDC",hWIN)
`sync
image=GetImage(1)
do
`set current bitmap 0
Call dll CardDLL(1),"cdtDrawExt",hdc,0,0,80,100,ID,0,0
`copy bitmap 0,0,0,80,100,1,0,0,80,100
`set current bitmap 1
Get image image,0,0,80,100
paste image image,100,0
if point(170,5)>1 then exit
`break
loop
`Get image image,0,0,80,100
`set current bitmap 0
call dll User32(1),"ReleaseDC",hWin,hdc
endfunction
function CaptureDeck()
`this only works if the app is not windowed
`sync off
`create bitmap 1,81,101
Card0=GetImage(0)+1
for ID=0 to 51
CopyCard(ID)
next ID
CopyCard(52)
CopyCard(54)
CopyCard(55)
endfunction Card0
then, the actual game
_Top:
`Norms Solitair
`Based on Dads "Picture Frame" Solitair.
`Created 04 July 2007
Dim CardDLL(1)
dim User32(1)
#include "cards.bas"
_ReadyCards:
cls
InitCards()
Dim Card_ID(54)
dim Card_Rank(54)
Dim Card_Suit(54)
dim Card_Count(1)
Card_Count(1)=51
Card_Count(0)=51
Card_ID(0)=CaptureDeck()
for Suit=0 to 3
rank=1
for ID=Suit to 51 step 4
Card_ID(ID)=Card_ID(0)+ID
Card_Rank(ID)=rank
Card_Suit(ID)=Suit
rank=rank +1
next ID
next Suit
for ID=52 to 54
Card_ID(ID)=Card_ID(0)+ID
Card_Rank(ID)=ID
Card_Suit(ID)=ID
next ID
randomize timer()
`break "26 Shuffling"
Shuffle(51)
_Setup:
`create a windowed app
`maxx=screen width()
`maxy=screen height()
`set window on
`set window size maxx,maxy
`set window position maxx/4,maxy/4
`set window layout 1,1,1
`set window title "Picture Frame"
`creating a windowed app causes the
`texture (image) data to be corrupted
backdrop on
color backdrop 0
sync rate 0
cls
sync
disable escapekey
autocam off
position camera 0-150,0,0-400
_Holders:
`make card holders
dim Holder_Obj(4,4)
dim Holder_ID(4,4)
dim Holder_SX(4,4)
dim Holder_SY(4,4)
dim Holder_MX(4,4)
dim Holder_MY(4,4)
sync
for x=0 to 4
for y=1 to 4
HObj=HObj+1
Holder_Obj(x,y)=HObj
make object plain Hobj,80,100
if x
position object Hobj,((x*100)-300),(((0-y)*120)+360),100
else
position object HObj,0-400,(((0-y)*120)+360),100
endif
SET OBJECT HObj,1,1,0
show object HObj
Holder_SX(x,y)=object screen x(HObj)
Holder_SY(x,y)=object screen y(HObj)
next y
next x
HObj=HObj+1
Holder_Obj(0,0)=HObj
make object plain Hobj,80,100
position object HObj,0-400,(((0-y)*120)+360),100
SET OBJECT HObj,1,1,0
show object HObj
_Measure:
Holder_SX(0,0)=object screen x(HObj)
Holder_SY(0,0)=object screen y(HObj)
DW=(Holder_SX(2,1)-Holder_SX(1,1))-10
DY=(Holder_SY(1,2)-Holder_SY(1,1))-20
for X=0 to 4
for Y=0 to 4
if Holder_Obj(X,Y)
Holder_SX(X,Y)=Holder_SX(X,Y)-DW/2
Holder_SY(X,Y)=Holder_SY(X,Y)-DY/2
Holder_MX(X,Y)=Holder_SX(X,Y)+DW
Holder_MY(X,Y)=Holder_SY(X,Y)+DY
endif
next Y
next X
ClearHolders()
_Mouse:
dim MyMouse(3)
dim Kernel32(1)
Kernel32(1)=LoadDLL("kernel32")
_PlayGame:
BlockMouse=timer()+200
dim PlayMode(1)
do
if escapekey()
flag=0
do
text 0,0,"Do you desire a new game? (Y/N)"
if escapekey()=0 then exit
sync
loop
do
text 0,0,"Do you desire a new game? (Y/N)"
K=scancode()
if K=21
Card_Count(1)=Card_Count(0)
ClearHolders()
Shuffle(Card_Count(1))
PlayMode(1)=0
exit
endif
if K=49
flag=1
exit
endif
if escapekey() then exit
sync
loop
if flag then exit
endif
if returnkey() then exit
`FreeCamera()
if MyMouse(1) then Sprite 1,mousex(),mousey(),MyMouse(1)
if mouseclick()
if timer()>BlockMouse
BlockMouse=Timer()+200
HandleMouse()
endif
endif
if PlayMode(1)<0
flag=0
do
text 0,0,"Game Over"
text 0,30,"Play Again ?(Y/N)"
K=scancode()
if K=49
flag=1
exit
endif
if K=21
Card_Count(1)=Card_Count(0)
ClearHolders()
Shuffle(Card_Count(1))
PlayMode(1)=0
exit
endif
if escapekey()
flag=1
exit
endif
sync
loop
if flag then exit
endif
sync
loop
_TheEnd:
FreeImages()
FreeCards()
FreeDLLS()
end
function Beep(tone,time)
if Kernel32(1)
call dll Kernel32(1),"Beep",tone,time
endif
endfunction
function HandleMouse()
`check to see which x,y object mouse is over
tx=999
ty=999
mx=mousex()
my=mousey()
for x=0 to 4
for y=0 to 4
if Holder_Obj(x,y)
if mx>Holder_SX(x,y)
if mx<Holder_MX(x,y)
if my>Holder_SY(x,y)
if my<Holder_MY(x,y)
tx=x
ty=y
y=5
x=5
endif
endif
endif
endif
endif
next y
next x
if tx>4 then exitfunction
_HoldCards:
if tx=0 and PlayMode(1)=0
`clicked on left card holder
`msg$="mouse x/y="
`msg$=msg$+str$(mx)+"/"
`msg$=msg$+str$(my)+" tx/ty 0/"
`msg$=msg$+str$(ty)
`break msg$
if MyMouse(1)
`we already have a card, so just drop this one
tx=MyMouse(2)
ty=MyMouse(3)
Holder_ID(tx,ty)=MyMouse(0)
texture object Holder_Obj(tx,ty),MyMouse(1)
MyMouse(1)=0
MyMouse(0)=0
show mouse
hide sprite 1
Beep(90,20)
else
`see if this is a card we can pick up
if Holder_ID(0,ty)<52
`pick up this card
MyMouse(0)=Holder_ID(0,ty)
MyMouse(1)=Card_ID(MyMouse(0))
MyMouse(2)=0
MyMouse(3)=ty
Holder_ID(0,ty)=54
texture object Holder_Obj(0,ty),Card_ID(54)
hide mouse
sprite 1,mousex(),mousey(),MyMouse(1)
size sprite 1,Holder_MX(0,ty)-Holder_SX(0,ty),Holder_MY(0,ty)-Holder_SY(0,ty)
OFFSET SPRITE 1,(Holder_MX(0,ty)-Holder_SX(0,ty))/2, (Holder_MY(0,ty)-Holder_SY(0,ty))/2
show sprite 1
Beep(90,20)
else
if Holder_ID(0,ty)=54
`Count Cards In Play
InPlay=0
for X=0 to 4
for Y=0 to 4
if Holder_Obj(X,Y)
if Holder_ID(X,Y)<52 then InPlay=InPlay+1
endif
next Y
next X
if InPlay>15
Holder_ID(0,ty)=53
texture object Holder_Obj(0,ty),Card_ID(53)
Beep(500,100)
`recheck Hold Cards
InPlay=0
for Y=0 to 4
if Holder_ID(0,Y)<52 then InPlay=InPlay+1
next y
if InPlay=0 then PlayMode(1)=1
else
if Card_Count(1)>=0
Holder_ID(0,ty)=Card_Count(1)
texture object Holder_Obj(0,ty),Card_ID(Card_Count(1))
Card_Count(1)=Card_Count(1)-1
Beep(90,20)
else
`Game has been won
Holder_ID(0,ty)=53
texture object Holder_Obj(0,ty),Card_ID(53)
Beep(500,100)
PlayMode(1)=0-1
endif
endif
else
Beep(500,100)
endif
endif
endif
exitfunction
endif
_FieldCards:
`placing a card into the field
if PlayMode(1)<0 then exitfunction
if PlayMode(1)
`now to remove field cards
if MyMouse(1)
`check for matching card
CID=Holder_ID(tx,ty)
if CID<52
if Card_Rank(CID)+Card_Rank(MyMouse(0))=10
`remove both cards
Holder_ID(tx,ty)=54
texture object Holder_Obj(tx,ty),Card_ID(54)
MyMouse(0)=0
MyMouse(1)=0
hide sprite 1
show mouse
else
`return old card
Holder_ID(MyMouse(2),MyMouse(3))=MyMouse(0)
texture object Holder_Obj(MyMouse(2),MyMouse(3)),MyMouse(1)
MyMouse(0)=0
MyMouse(1)=0
hide sprite 1
show mouse
`and pick up new card removed, not too nice
`MyMouse(0)=CID
`MyMouse(1)=Card_ID(CID)
`MyMouse(2)=tx
`MyMouse(3)=ty
`Holder_ID(tx,ty)=54
`texture object Holder_Obj(tx,ty),Card_ID(54)
`sprite 1,mousex(),mousey(),MyMouse(1)
`size sprite 1,Holder_MX(tx,ty)-Holder_SX(tx,ty),Holder_MY(tx,ty)-Holder_SY(tx,ty)
`OFFSET SPRITE 1,(Holder_MX(tx,ty)-Holder_SX(tx,ty))/2, (Holder_MY(tx,ty)-Holder_SY(tx,ty))/2
endif
Beep(90,30)
else
`return card
Holder_ID(MyMouse(2),MyMouse(3))=MyMouse(0)
texture object Holder_Obj(MyMouse(2),MyMouse(3)),MyMouse(1)
MyMouse(0)=0
MyMouse(1)=0
hide sprite 1
show mouse
Beep(90,30)
endif
else
`check if can pick this card up
CID=Holder_ID(tx,ty)
if CID<52
if Card_Rank(CID)=10
`tens need no match, so just remove
Holder_ID(tx,ty)=54
texture object Holder_Obj(tx,ty),Card_ID(54)
Beep(100,30)
exitfunction
endif
if Card_Rank(CID)<11
`pick this card up
MyMouse(0)=CID
MyMouse(1)=Card_ID(CID)
MyMouse(2)=tx
MyMouse(3)=ty
Holder_ID(tx,ty)=54
texture object Holder_Obj(tx,ty),Card_ID(54)
hide mouse
sprite 1,mousex(),mousey(),MyMouse(1)
size sprite 1,Holder_MX(tx,ty)-Holder_SX(tx,ty),Holder_MY(tx,ty)-Holder_SY(tx,ty)
OFFSET SPRITE 1,(Holder_MX(tx,ty)-Holder_SX(tx,ty))/2, (Holder_MY(tx,ty)-Holder_SY(tx,ty))/2
show sprite 1
Beep(90,20)
else
Beep(500,100)
endif
else
if tx=0
`maybe ready for more cards
`count cards in play
InPlay=0
for x=1 to 4
for y=1 to 4
if Holder_ID(x,y)<52 then InPlay=InPlay+1
next y
next x
if InPlay<16
InPlay=16-InPlay
for y=0 to 4
if y<InPlay
Holder_ID(0,Y)=54
texture object Holder_Obj(0,y),Card_ID(54)
else
Holder_ID(0,Y)=53
texture object Holder_Obj(0,Y),Card_ID(53)
endif
next y
PlayMode(1)=0
HandleMouse()
exitfunction
else
Beep(500,100)
endif
else
Beep(500,100)
endif
endif
endif
exitfunction
else
if MyMouse(1)=0
`check cards in play
InPlay=0
for X=1 to 4
for Y=1 to 4
if Holder_Obj(X,Y)
if Holder_ID(X,Y)<52 then InPlay=InPlay+1
endif
next Y
next X
if InPlay>15
PlayMode(1)=1
HandleMouse()
endif
exitfunction
endif
endif
_BasicPlay:
`verify location is empty
if Holder_ID(tx,ty)=54
`check for special cards
CID=MyMouse(0)
rank=Card_Rank(CID)
flag=0
select rank
case 13
`kings can only go in one place
if ty=1 then flag=1
endcase
case 12
`queens
if ty=4 then flag=1
endcase
case 11
`jacks
if ty>1
if ty<4
if tx=1 then flag=1
if tx=4 then flag=1
endif
endif
endcase
case default
`this card can go anywhere
flag=1
endcase
endselect
if flag
Holder_ID(tx,ty)=CID
texture object Holder_Obj(tx,ty),Card_ID(CID)
MyMouse(0)=0
MyMouse(1)=0
hide sprite 1
show mouse
Beep(100,20)
else
Beep(500,50)
endif
else
Beep(500,50)
endif
endfunction
function FreeCamera()
text 0,0,"Camera position ="
text 0,30,"X="+str$(camera position x() )
text 0,60,"Y="+str$(camera position y() )
text 0,90,"Z="+str$(camera position z() )
if Upkey() then move camera 1
if downkey() then move camera 0-1
if leftkey() then turn camera left 1
if rightkey() then turn camera right 1
endfunction
function ClearHolders()
for x=0 to 4
for y=0 to 4
if Holder_Obj(x,y)
Holder_ID(x,y)=54
texture object Holder_Obj(x,y),Card_ID(54)
endif
next y
next x
endfunction
function Shuffle(max)
for n=1 to 3
for ID=0 to max
swop=rnd(max)
X=Card_ID(ID):Card_ID(ID)=Card_ID(swop):Card_ID(swop)=X
X=Card_rank(ID):Card_Rank(ID)=Card_Rank(swop):Card_Rank(swop)=X
X=Card_Suit(ID):Card_Suit(ID)=Card_Suit(swop):Card_Suit(swop)=X
next ID
next n
endfunction
and that's it
It does require DBC113 Enhanced for the DLL access,
but no other files required.
As is common with my games,
Its not pretty and the docs are lacking
Basically, the game is a solitair game called picture frame.
Its a game my dad taught me 30+ years ago.
I modified the rules to suit me (don't cheat, just changes the rules)
At program launch you will see some cards flashing ...
This is normal. You are not imagining things
That's my card lib capturing the cards from MS cards.dll.
Then, you will see a bunch of "green O's".
That's the game you wish to play.
the column on the far left are the cards you pick up.
the 4x4 grid in the center is where you place them.
Most cards can go anywhere ....
Kings can only go on the TOP row
Queens on the Bottom row
Jacks on the sides
When you have filled in the 4x4 grid you can
begin removing cards (not the King,Queen, or Jacks).
Cards are removed by making a pair that equal 10.
So, pick up an Ace and drop it on a 9 card and both go away.
When done removing cards, just click on the left colomn,
anywhere, and you can begin collecting new cards.
To redeal at any time,
press Escape and then 'Y'
to exit the game
press Escape and then 'N'
and for those that just want the full .exe ....
waffle
EDIT: just revised the code a bit to correct a few errors.
EDIT: just updated the EXE to reflect code changes
EDIT: just update the .ZIP to improve the Escape sequence.
The source in the ZIP is updated, just not the source here.
If you use the .EXE, press escape and you can answer the dialog
using the mouse now.
