Hi there!
In this game of MEMORY there are 12 different categories to choose from, ARMY · BUTTERFLIES · DISCO · DOGS · FACES · GARDEN · KIDS · MISCELLANEOUS · NATIONAL COSTUMES · SHIELDS · SPORTS ANIMATION · TEENS
In each category there are 25 cards, each having a matching card as its pair.
To start play, all the cards are placed face down in the play area. In each turn, the player chooses a card and it is turned over, then chooses a second card and it is turned over.
If the cards match, they are removed from the play area. If the cards do not match, they are returned to their respective face-down positions.
For each match made, you are awarded a score and, when all matches have been made, you win.
You are also playing against the clock.
The category selection can be automatically random or manual.
The original code was written by Kevin Picone using PB V1.64j at
http://www.underwaredesign.com/forums/index.php?topic=3002.0
and has been adapted for PB V1.63v and is used here with permission.
I have posted the code here but it and necessary media are included in the attached .zip file.
[pbcode]
remstart
****************************************************************************
The Game of MEMORY (Also known as The Game of Pairs)
Original Code by Kevin Picone
Built Using PlayBasic V1.64j
Adapted for this game by geecee with permission
Built Using PlayBasic V1.63v
****************************************************************************
About:
======
This example is a version of the classic memory game, where you have to
flip cards to find the matching pairs. Each time a pair is located
you're awarded a score. When all pairs are matched you win.
Pretty simple game mechanic, but it can be a pretty enjoyable little
game.
Have Fun!
Controls:
========
Mouse = Select a card
ESC = EXIT
****************************************************************************
remend
rem ========================================================================
rem Initialize program
rem ========================================================================
rem Set the max frames per second this program should execute at
SetFps 61.7
rem Tell PB to include the input support library
#include "Input"
rem Load fonts used in game
StatusFont =loadnewfont("arial bold",24,0)
Arial40=loadnewfont("arial bold",40,0)
rem Card width/height and number of unique cards in pack
CardWidth=71
CardHeight=96
NumberOfCardsInDeck=25
rem Declare array/s
Dim CardIMages(1)
Dim cardimage(336)
Dim message$(30)
rem Pre-load media
global cardimage=loadnewimage("Cardback.bmp")
for lp=1 to 28
CardIMage(lp) = LoadNewImage("A"+Str$(lp)+".Bmp")
CardIMage(28+lp) = LoadNewImage("B"+Str$(lp)+".Bmp")
CardIMage(56+lp) = LoadNewImage("DI"+Str$(lp)+".Bmp")
CardIMage(84+lp) = LoadNewImage("D"+Str$(lp)+".Bmp")
CardIMage(112+lp) = LoadNewImage("F"+Str$(lp)+".Bmp")
CardIMage(140+lp) = LoadNewImage("G"+Str$(lp)+".Bmp")
CardIMage(168+lp) = LoadNewImage("K"+Str$(lp)+".Bmp")
CardIMage(196+lp) = LoadNewImage("M"+Str$(lp)+".Bmp")
CardIMage(224+lp) = LoadNewImage("N"+Str$(lp)+".Bmp")
CardIMage(252+lp) = LoadNewImage("S"+Str$(lp)+".Bmp")
CardIMage(280+lp) = LoadNewImage("SP"+Str$(lp)+".Bmp")
CardIMage(308+lp) = LoadNewImage("T"+Str$(lp)+".Bmp")
next
rem Make variables visible from not only within the main programme,
rem but from within functions/sub's also.
global category
global category$
global choice
rem Go to introduction subroutine
gosub intro
rem ========================================================================
rem Declare CARD STATE constants.
rem ========================================================================
rem These constants are used for the various 'states' each card can be in.
rem They exist to make the code more readible
Constant CardState_NotMatched=1
Constant CardState_Selected=2
Constant CardState_Matched=3
rem ========================================================================
rem Declare Type to represent CARDS within the game
rem ========================================================================
Type tCard
rem State of this card. Not matched/ Selected / or matched
State
rem The value (index) of card within pack
CardValue
rem Screen position of this card
Xpos
Ypos
rem Time until a selected card changes STATES
ChangeStateTime
rem The new state this card will change to after selection.
NewState
EndType
rem ========================================================================
rem Programs MAIN LOOP
rem ========================================================================
rem repeat / Until loop
repeat
rem Jump to Play a game
Gosub PLay_Game
rem Display the game complete page once the game sub routine has returned
Gosub Game_Complete
rem Check if the player wants to play again ?
SetFont Arial40
FadeAngle#=0
repeat
Cls 0
KeyPressed$=UPPER$(inkey$())
Xpos= GetScreenWidth()/2
Ypos= GetScreenHeight()*0.40
Ink rgbfade(rgb(255,255,255),50+sinRadius(FadeAngle#,25))
CenterText Xpos,Ypos,"Play Again (Y/N)?"
FadeAngle#=wrapangle(FadeAngle#,1)
Sync
until KeyPressed$="N" or KeyPressed$="Y"
rem Repeat this loop until the players chooses the N (NO) option.
Until KeyPressed$="N"
rem Call the end of program sub routine
gosub End_OF_Program:
rem END (TERMINATE) the PROGRAM
End
rem ========================================================================
rem End Program SubRoutine
rem ========================================================================
End_OF_Program:
rem
StartTime=Timer()
repeat
Cls 0
CurrentTime=Timer()
Timepast=ClipRange(Timer()-StartTime,1,1000)
Ink rgbfade(rgb(255,255,255),(1000-TimePast)/10.0)
Xpos= GetScreenWidth()/2
Ypos= GetScreenHeight()*0.40
CenterText Xpos,Ypos,"Thanks For Playing!"
Sync
until CurrentTime>(StartTime+1000)
return
rem ========================================================================
rem Play Game SubRoutine
rem ========================================================================
PLay_Game:
rem Create some images to represent the deck of cards.
Make_Card_Graphics(NumberOfCardsInDeck,CardWidth,CardHeight,CardImages())
rem Calc the Number OF cards that the player will be able to choose from
rem Each card apears twice so we double the number of cards in the pack
NumberOfCards=NumberOfCardsInDeck*2
rem Dimension the card array to hold the info about each of the cards
Dim Cards(NumberOfCards) as tCard
rem Create the and randomize card sequence
Dim CardSequence(NumberOfCards)
index=1
For lp=1 to NumberOfCards step 2
CardSequence(lp)=Index
CardSequence(lp+1)=Index
Inc index
next
rem Shuffle the cards to randomize them a bit. So the cards are not in order
ShuffleArray(CardSequence(),10)
rem Init cards position and layout upon the screen.
Row=0
CardsPerRow=10
CardPadX=4
CardPad=4
Ypos =80-(CardHeight+CardPadY)
For ThisCard=1 To NumberOfCards
if Row=0
Xpos=((CardWidth+CardPadX)*CardsPerRow)/2
Xpos=(GetScreenWidth()/2)-Xpos
Ypos=Ypos+CardHeight+CardPadY
endif
rem Set Card to it's not matched state
Cards(thiscard).state=CardState_NotMatched
rem Store which 'value' this card is
Cards(ThisCard).CardValue=CardSequence(ThisCard)
rem Position (top Left)
Cards(ThisCard).Xpos=Xpos
Cards(ThisCard).Ypos=Ypos
Xpos=Xpos+CardWidth+CardPadX
Row=Mod(Row+1,CardsPerRow)
Next
rem Set the Score Variable to it's starting value or 0
Score=0
rem This variable holds the time that this game started in milliseconds
StartOfGameTime=Timer()
rem Set the Time
TimeOfLastMatch=StartOfGameTime
rem Repeat / until loop
Repeat
rem Clear the Screen to Black
cls rgb(0,0,0)
rem Poll mouse state this frame
Mx=mouseX()
My=mouseY()
Mb=mouseButton()
rem Current Time
CurrentTime=Timer()
if (CurrentTime>=LastMouseInput) and (NumberOfCardStateChanges=0)
rem Detect if the LEFT mouse button and only that button, are pressed ?
if MB=1
rem If it was, lets check if this mouse is over a card ?
For ThisCard=1 To NumberOfCards
rem Query if this card exists ?
if Cards(ThisCard)
rem Get the Position of this card
Xpos=Cards(ThisCard).Xpos
Ypos=Cards(ThisCard).Ypos
rem Detect if the mouse is over this card ?
if PointInBox(mx,my,Xpos,Ypos,Xpos+CardWidth,Ypos+CardHeight)=true
if Cards(ThisCard).State=CardState_NotMatched
rem Check how many cards have currently selected ?
Select Get_Number_Of_Cards_With_state(CardState_Selected)
rem No cards are currently selected
rem ---------------------------------------
case 0
rem ---------------------------------------
rem This is the first card selected, so we tag this card as selected
Cards(ThisCard).State=CardState_Selected
rem Tell the program to not accept mouse input for the next 250 milliseconds
LastMouseInput=CurrentTime+250
rem ---------------------------------------
case 1
rem ---------------------------------------
rem If there's already one card selected, then we can compare the pair
Cards(ThisCard).State=CardState_Selected
MatchingCard=Find_Matching_Selected_Card(ThisCard)
IF MatchingCard=0
rem Selection didn't match, so we reset the selected cards to NotMatched
Set_Card_New_States(CardState_NotMatched,CurrentTime+500)
else
rem Selection Matched, so we can now cards states
Set_Card_New_States(CardState_Matched,CurrentTime+500)
rem If the pair match, add some score based upon how long
rem it took the person to find this pair
Score=Score+Calculate_Score_Amount_from_time_Past(TimeOfLastMatch,CurrentTime)
TimeOfLastMatch=CurrentTime
endif
LastMouseInput=CurrentTime+750
EndSelect
EndIf
endif
endif
rem End of the for next to detect mouse clicks on cards
next
endif
endif
rem Draw all of the cards and return the number of selected changes also
NumberOfCardStateChanges=DrawCards(NumberOfCards)
rem Display the Current Score + Time you've been playing for
SetFont StatusFont
Ink rgb(255,255,255)
XposIndent=20
Ypos=10
centertext 400,ypos,"The Game of MEMORY"
select val(category$)
case 1
category$="ARMY"
case 2
category$="BUTTERFLIES"
case 3
category$="DISCO"
case 4
category$="DOGS"
case 5
category$="FACES"
case 6
category$="GARDEN"
case 7
category$="KIDS"
case 8
category$="MISCELLANEOUS"
case 9
category$="NATIONAL COSTUMES"
case 10
category$="SHIELDS"
case 11
category$="SPORTS ANIMATION"
case 12
category$="TEENS"
endselect
centertext 400,ypos+30,"Now playing category "+category$
Score$="Score:"+Digits$(Score,6)
Time$="Time:"+ConvertTimeToHMS(CurrentTime-StartOfGameTime,0)
Text XposIndent,Ypos,Score$
Text (GetScreenWidth()-XposIndent)-GetTExtwidth(Time$),Ypos,Time$
rem Show the Display once
Sync
rem Count the number of cards that are currently tagged as Matched
Matches=Get_Number_Of_Cards_With_state(CardState_Matched)
rem repeat the GAME LOOP until all of cards are in the "matched" state
Until (NumberOfCards-Matches)=0
rem Return to where this sub routine was called
return
rem ========================================================================
rem Game Complete SubRoutine
rem ========================================================================
Game_Complete:
rem Display game completed information
Cls Rgb(0,0,0)
FlushKeys
FlushMouse
SetFont Arial40
Ink rgb(255,255,255)
Xpos=GetScreenWidth()/2
Ypos=GetScreenHeight()*0.30
Message$="Winner !"
rem Go to subroutine for flashing text
gosub flashtext
ypos=ypos+GettextHeight(Message$)*2
Score$="Score:"+Digits$(Score,6)
Time$ ="Time:"+ConvertTimeToHMS(CurrentTime-StartOfGameTime,0)
CenterText Xpos,Ypos,Score$
ypos=ypos+GettextHeight(Score$)*2
CenterText Xpos,Ypos,Time$
ypos=ypos+GettextHeight(Score$)*3
Message$="Press Any Key"
CenterText Xpos,Ypos,Message$
ypos=ypos+GettextHeight(Message$)*2
Sync
waitkey
return
rem ========================================================================
rem Introduction SubRoutine
rem ========================================================================
intro:
rem This command will hide the mouse pointer
Mouse off
rem Read in data statements
for a=1 to 22
s$=readdata$()
message$(a)=s$
next a
rem Set down coordinate
down=15
rem Set ink colour
ink rgb(255,255,255)
setfont statusfont
th=gettextheight("arial")
rem Write message lines to screen.
for b=1 to 22
tw=gettextwidth(message$(b))
down=down+th*1
text 400-tw/2,down,message$(b)
sync
next
rem Data statements
data "The Game of MEMORY (Also known as The game of Pairs)",""
data "In this game of MEMORY there are 12 different categories.",""
data "· ARMY · BUTTERFLIES · DISCO · DOGS · FACES · GARDEN · KIDS ·"
data "· MISCELLANEOUS · NATIONAL COSTUMES · SHIELDS ·"
data "· SPORTS ANIMATION · TEENS ·",""
data "In each category there are 25 cards, each having a matching card as its pair.",""
data "To start play, all the cards are placed face down in the play area.",""
data "In each turn, the player chooses a card and it is turned over, then chooses"
data "a second card and it is turned over. If the cards match, they are removed"
data "from the play area. If the cards do not match, they are returned to their"
data "respective face-down positions.",""
data "Each time a match is made, you are awarded a score.",""
data "The category selection can be Automatically Random or Manual."
data "","Left click mouse for Automatic ... Right click mouse for Manual."
rem Go to subroutine to determine automatic or manual selection
gosub automan
return
rem ========================================================================
rem Automatic or Manual selection SubRoutine
rem ========================================================================
automan:
rem This command will show the mouse pointer
Mouse on
rem Wait for mouse click
WaitMouse 0,3
mb=mousebutton()
if mb=1
choice=1
else
choice=2
endif
rem Wait Here until the mouse button is released
WaitNoInput
if choice=2
rem Draw box to hide previous text at location
boxc 2,62,798,598,1,rgb(0,0,0)
centertext 400,80,"You chose to select the category to play Manually"
rem Determine width of longest text string
tw=400-gettextwidth("NATIONAL COSTUMES")/2
rem Set down coordinate
down=160
rem Write text to screen
text tw,down,"1 ... ARMY"
text tw,down+20,"2 ... BUTTERFLIES"
text tw,down+40,"3 ... DISCO"
text tw,down+60,"4 ... DOGS"
text tw,down+80,"5 ... FACES"
text tw,down+100,"6 ... GARDEN"
text tw,down+120,"7 ... KIDS"
text tw,down+140,"8 ... MISCELLANEOUS"
text tw,down+160,"9 ... NATIONAL COSTUMES"
text tw-10,down+180,"10 ... SHIELDS"
text tw-10,down+200,"11 ... SPORTS ANIMATION"
text tw-10,down+220,"12 ... TEENS"
repeat
rem Set ink colour and draw a box to hide previous text at location
boxc 2,500,798,530,1,rgb(0,0,0)
rem Set cursor position
setcursor 400-gettextwidth("Choose from any one of the above categories and key in its number > ")/2,500
rem Determine category to play
answer$=staticinput("Choose from any one of the above categories and key in its number > ")
rem Convert string to non-string
category=val(answer$)
until category>0 and category<13
endif
return
rem ========================================================================
rem This function out works how long it took the player to find the last
rem match then converts this time into a number of point from 1 to 100.
rem ========================================================================
Function Calculate_Score_Amount_from_time_Past(TimeOfLastMatch,CurrentTime)
TimePast=CurrentTime-TimeOfLastMatch
rem the time past to a max of 30 seconds (30,000 milliseconds)
TimePast=ClipRange(TimePast,0,30000)
rem convert the milliseconds into a value from 100 to 0
ScoreAmount=((30000-TimePast)/300.0)
ScoreAmount=ClipRange(ScoreAmount,1,100)
EndFunction ScoreAmount
rem ========================================================================
rem Set Select Cards to change States
rem ========================================================================
Function Set_Card_New_States(NewSTate,ChangeAfterTime)
For ThisCard=1 To GetArrayElements(Cards().tcard,1)
rem Check this card exists
if Cards(ThisCard)
rem Check if this card currently selected ?
if Cards(ThisCard).State=CardState_Selected
rem set this cards NEw state after the state change delay
Cards(ThisCard).NewState=NewSTate
Cards(ThisCard).ChangeStateTime=ChangeAfterTime
endif
endif
next
EndFunction
rem ========================================================================
rem Find a Matching Selected Card to card of your choosing
rem ========================================================================
Function Find_Matching_Selected_Card(CompareCard)
Result=0
For ThisCard=1 To GetArrayElements(Cards().tcard,1)
rem Check this card exists
if Cards(ThisCard)
rem Excluded comparing with it's self
if ThisCard<>COmpareCard
rem Check if this card currently selected ?
if Cards(ThisCard).State=CardState_Selected
rem Compare the card values ??
if Cards(ThisCard).CardValue=Cards(CompareCard).CardValue
Result=ThisCard
exitfor
endif
endif
endif
endif
next
EndFunction result
rem ========================================================================
rem Get The Number of cards with a Certain State
rem ========================================================================
Function Get_Number_Of_Cards_With_state(ThisState)
For ThisCard=1 To GetArrayElements(Cards().tcard,1)
rem Check this card exists
if Cards(ThisCard)
rem Is this card the state we want ? ?
if Cards(ThisCard).State=ThisState
rem If so, add 1 to the count variable
inc MatchingState
endif
endif
next
EndFunction MatchingState
rem ========================================================================
rem Draw the Cards
rem ========================================================================
Function DrawCards(NumberOfCards)
CurrentTime=Timer()
StateChangesCount=0
For ThisCard=1 To NumberOfCards
rem Check this card exists
if Cards(ThisCard)
CardValue=Cards(ThisCard).CardValue
rem Position (top Left)
Xpos =Cards(ThisCard).Xpos
Ypos =Cards(ThisCard).Ypos
Select Cards(ThisCard).State
Case CardState_NotMatched
rem Since this card is not selected we show the 'blank' version of the card
ThisImage=cardimages(0)
DrawImage ThisImage,Xpos,Ypos,False
Case CardState_Selected
rem Show the card
ThisImage=cardimages(CardValue)
rem Get the width & Height
Width=GetIMageWidth(ThisImage)
Height=GetIMageHeight(ThisImage)
rem draw this card at this position
DrawImage ThisImage,Xpos,Ypos,False
rem Draw the hilight rect around this card
for HiLight=0 to 4
Xpos2=Xpos+Width+1+HiLight
Ypos2=Ypos+Height+1+HiLight
Boxc Xpos-HiLight,Ypos-HiLight,Xpos2,Ypos2,false,Rgb(255,255,0)
next
rem Check if this card needs to change from selection state to a new state
if Cards(ThisCard).ChangeStateTime<>0
if CurrentTime>Cards(ThisCard).ChangeStateTime
Cards(ThisCard).State=Cards(ThisCard).NewState
Cards(ThisCard).ChangeStateTime=0
Cards(ThisCard).NewState=0
endif
inc StateChangesCount
endif
Case CardState_Matched
rem Matched cards are not drawn
EndSelect
endif
Next
EndFunction StateChangesCount
rem ========================================================================
rem Shuffle the Values With An Array
rem ========================================================================
Function ShuffleArray(ThisArray(),Passes)
Size=GetArrayElements(ThisArray(),1)
For ThisPass=1 to Passes
For lp=1 to Size
Index=rndrange(1,Size)
Temp=ThisArray(lp)
ThisArray(lp)=ThisArray(Index)
ThisArray(Index)=Temp
Next
next
EndFunction
rem ========================================================================
rem Make Card Graphics
rem ========================================================================
Function Make_Card_Graphics(Number,Width,Height,Images())
rem Determine category to play
select choice
case 1
category=rnd(11)+1
category$=str$(category)
case 2
category$=str$(category)
endselect
Dim Images(Number)
oldfont=getcurrentfont()
OldSurface=GetSurface()
TempFont =loadnewfont("arial bold",50,0)
Setfont TempFont
For lp =0 to Number
Img=NewImage(width,Height)
Images(lp)=Img
rendertoimage Img
drawimage cardimage,0,0,false
select category
case 1
plus=0
case 2
plus=28
case 3
plus=56
case 4
plus=84
case 5
plus=112
case 6
plus=140
case 7
plus=168
case 8
plus=196
case 9
plus=224
case 10
plus=252
case 11
plus=280
case 12
plus=308
endselect
if lp
drawimage cardimage(lp+plus),0,0,false
endif
next
rendertoimage OldSurface
setfont oldFont
deletefont TempFont
EndFunction
rem ========================================================================
rem Convert Time(millisecondes) to Hours/Mins/Seconds
rem ========================================================================
rem
rem This function will convert a milli seconds timer value into digital
rem time format. This version supports Hours/Minutes and Seconds.
rem ========================================================================
Function ConvertTimeToHMS(ticks,format)
Seconds=ticks/1000
Minutes=mod((Seconds/60),60)
Hours=mod((seconds/3600),24)
Seconds=mod(seconds,60)
h$=Digits$(hours,2)
m$=Digits$(minutes,2)
s$=Digits$(seconds,2)
if format=0
result$=h$+":"+m$+":"+s$
else
result$=s$+":"+m$+":"+h$
endif
EndFunction result$
rem ========================================================================
rem Flash text SubRoutine
rem ========================================================================
flashtext:
repeat
rem Increment flashes counter
inc flashes
rem Draw box to hide previous text at location
boxc 2,180,798,220,1,rgb(0,0,0)
rem Flash the text on and off every 1/10 of a second.
if textTime <= timer()
textToggle = Not textToggle
textTime = timer()+100
endif
if textToggle <> 0
CenterText Xpos,Ypos,message$
endif
rem Display the Screen
sync
rem End loop
until flashes=80
CenterText Xpos,Ypos,message$
return
[/pbcode]
:)
Enjoy
geecee
Hi geecee
Nice game , well put together , even if a tad hard to complete
mick :)
Thanks for your reply micky4fun.
However, I cannot claim all credit for the "putting together" ...... The original code was by Kevin and I adapted it to suit.
:)
geecee
Hi there!
If you want to add an extra touch try this.
Find this part of the code ...... Do a search for winner.
Xpos=GetScreenWidth()/2
Ypos=GetScreenHeight()*0.30
Message$="Winner !"
CenterText Xpos,Ypos,Message$
ypos=ypos+GettextHeight(Message$)*2
Rem or delete
CenterText Xpos,Ypos,Message$
add this
rem Go to subroutine for flashing text
gosub flashtext
between
Message$="Winner !"
and
ypos=ypos+GettextHeight(Message$)*2
then add this subroutine at the end of the code
[pbcode]
rem ========================================================================
rem Flash text SubRoutine
rem ========================================================================
flashtext:
repeat
` Increment flashes counter
inc flashes
` Draw box to hide previous text at location
boxc 2,180,798,220,1,rgb(0,0,0)
` Flash the text on and off every 1/10 of a second.
if textTime <= timer()
textToggle = Not textToggle
textTime = timer()+100
endif
if textToggle <> 0
CenterText Xpos,Ypos,message$
endif
` Display the Screen
sync
` End loop
until flashes=80
CenterText Xpos,Ypos,message$
return
[/pbcode]
:)
geecee
hmmm... its easier to update the first post with original sourcecode :P
Quotehmmm... its easier to update the first post with original sourcecode
Point taken Big C.
The post has been updated and now also includes a routine for manual selection of the categories.
:)
geecee
Hi there!
The attachment is a screenshot from The Game of Memory ...... Due to the limitations on attachments, I couldn't attach to the original post.
:)
geecee