mmbasic_original:hearts_and_bones_v1_0
Hearts and Bones v1.0
This module is part of the original MMBasic library. It is reproduced here with kind permission of Hugh Buckle and Geoff Graham. Be aware it may reference functionality which has changed or is deprecated in the latest versions of MMBasic.
Hearts.bas:
'*****************************************************
'*** Hearts and Bones v1.0 adapted from a game
'*** appearing on the HP 200LX palmtop computer.
'*** MMBasic version created by Hugh Buckle April 2012
'*** Requires MMBasic v3.2 or later and Hearts.fnt
'*****************************************************
'load hearts and bones font
Font Load "Hearts.fnt" As #4
'*** Grid definitions
x0=100: y0=40 'grid offset (top left)
x1=x0-1: y1=y0-4 'Cursor top left
x2=x1+16: y2=y1+18 'Cursor bottom right
xmin=0: ymin=0 'Cell range, x=columns and y=rows
xmax=14: ymax=8
'*** Cell definitions
UnmarkedCell =0 'These 3 variables are used to test a valid range of values
HeartCell =1 'in a cell using Int(cell(x,y)/10) thus testing
MarkedCell =2 'with a single test
Bone =40
MarkedBone =50
'*** Default direction key assigments - Numeric Keypad
GoSub DefaultKeys
'*** Other variables
true=1
false=0
NumHearts = 8
StartBones = 20 ' default number of bones
Score=0
Dim cell(xmax+1,ymax+1) ' stores cell content
Dim Stack((xmax+1)*(ymax+1)) ' used in revealing zero cells
Dim ZeroStack((xmax+1)*(ymax+1))
'*** date statements give x,y values for position of hearts
Data 0,4,0,8,7,0,7,4,7,8,14,0,14,4,14,8
Cls
GoSub PrintText
GoSub PrintGrid
GoSub PlaceHearts
'Load current player's HiScore, direction keys and starting bones
GoSub LoadGame
NumBones=StartBones
GoSub PrintInitialFnKeys
GoSub PrintHighScore
GoSub PrintScore
GoSub printBones
GoSub PrintMarks
Do
GoSub GetKey
GoSub ClearHelpText
GoSub ProcessFnKeys
If quit=true Then End
Loop Until Asc(k$)=145 ' F1 pressed
Line (0,0)-(90,19*12),0,BF
Start:
Do '*** Setup a new game
GameEnd=false
ZeroStackTop=0
CorrectMarks=0
GoSub ClearCells
GoSub PrintText
GoSub PrintGameFnKeys
GoSub PrintHighScore
GoSub PrintScore
GoSub printBones
GoSub PrintMarks
GoSub PrintGrid
GoSub PlaceHearts
GoSub PlaceBones
GoSub CountBones
x=0: y=0 'Cursor to top left
PrintNum(x,y,Cell(x,y))
GoSub AddCursor
If Cell(x,y)=0 Then GoSub FindAdjacentZeros
'*** main game loop starts here
Do
GoSub GetKey
GoSub DeleteCursor
GoSub ProcessMove
GoSub AddCursor
Loop While GameEnd=false And HeartsFound<NumHearts And Quit=false
If quit=false Then
If GameEnd Then
GoSub Finish
Score=0
NumBones=StartBones
GoSub getKey
If Asc(k$)=27 Then
Quit=true
EndIf
GoSub ClearMessage
Else
GoSub LevelCompleted
EndIf
EndIf
Loop Until quit=true
GoSub ClearMessage
Font #2,,1
Print @(13,0*10) " Bye "
Font #1,,0
Print @(5,3*10) " Thanks for"
Print @(5,4*10) " playing."
Print @(5,5*10) " Hope you had"
Print @(5,6*10) " fun."
Print @(0,300);
End
GetKey:
Do
k$=Inkey$
Loop While k$=""
Return
LevelCompleted:
Font #1,,1
Print @(5,0*10) " LEVEL "
Print @(5,1*10) " COMPLETED "
Font #1,,0
If CorrectMarks=NumBones And CorrectMarks=Marks Then
Score=Score+NumHearts
If Score>HighScore Then
HighScore=Score
EndIf
Print @(5,3*10) " All Hearts &"
Print @(5,4*10) "Bones located."
Print @(5,5*10) "BONUS 8 Hearts"
Else
Print @(5,3*10) "Not all bones"
Print @(5,4*10) " marked so"
Print @(5,5*10) " NO BONUS"
EndIf
NumBones=NumBones+2
Return
ProcessMove:
'*** up left arrow
If Asc(k$) = UL Then
If x>xmin And y>ymin Then
Move(-1,-1)
Else
GoSub MarkOff
EndIf
EndIf
'*** up arrow
If Asc(k$) = UN Or Asc(k$)= UA Then
If y>ymin Then
Move(0,-1)
Else
GoSub MarkOff
EndIf
EndIf
'*** up right arrow
If Asc(k$) = UR Then
If x<xmax And y>ymin Then
Move(1,-1)
Else
GoSub MarkOff
EndIf
EndIf
'*** left arrow
If Asc(k$) = LN Or Asc(k$)= LA Then
If x>xmin Then
Move(-1,0)
Else
GoSub MarkOff
EndIf
EndIf
'*** right arrow
If Asc(k$) = RN Or Asc(k$)= RA Then
If x<xmax Then
Move(1,0)
Else
GoSub MarkOff
EndIf
EndIf
'*** down left arrow
If Asc(k$) = DL Then
If x>xmin And y<ymax Then
Move(-1,1)
Else
GoSub MarkOff
EndIf
EndIf
'*** down arrow
If Asc(k$) = DN Or Asc(k$)= DA Then
If y<ymax Then
Move(0,1)
Else
GoSub MarkOff
EndIf
EndIf
'*** down right arrow
If Asc(k$) = DR Then
If x<xmax And y<ymax Then
Move(1,1)
Else
GoSub MarkOff
EndIf
EndIf
'*** Space toggle mark
If Asc(k$) = MK Then
If mark=1 Then
GoSub MarkOff
Else
mark=1
Print @(5,3*10) " Press a"
Print @(5,4*10) "direction key"
Print @(5,5*10) "to mark a BONE"
EndIf
EndIf
'*** F1 Re-Start
If Asc(k$) = 145 Then
GoTo Start
EndIf
'*** Esc Quit
If Asc(k$) = 27 Then
Quit=true
EndIf
' Clear Message area
If Not Mark Then
GoSub ClearMessage
EndIf
Return
ProcessFnKeys:
'*** F1 Play
If Asc(k$) = 145 Then
' Do nothing - starts play
'*** F2 Increase Bones
ElseIf Asc(k$) = 146 Then
GoSub IncBones
'*** Shift/F2 Decrease bones
ElseIf Asc(k$) = 178 Then
GoSub DecBones
'*** F3 Set Keys
ElseIf Asc(k$) = 147 Then
GoSub SetKeys
'*** F4 Help
ElseIf Asc(k$) = 148 Then
GoSub Help
'*** Esc Quit
ElseIf Asc(k$) = 27 Then
Quit=true
EndIf
Return
PrintGrid:
Line (x0-2,y0-5)-(x0-2+xmax*18+18,y0+15+ymax*20),0,BF 'Clear old grid
For i = 0 To xmax
For j = 0 To ymax
Line (x0-2+i*18,y0-5+j*20)-(x0-2+i*18+18,y0+15+j*20),1,B
Next j,i
Return
DeleteCursor:
' remove old Cursor
Line (x1+x*18,y1+20*y)-(x2+18*x,y2+20*y),0,b
Line (x1+x*18+1,y1+20*y+1)-(x2+18*x-1,y2+20*y-1),0,b
Return
AddCursor:
' draw new Cursor
Line (x1+x*18,y1+20*y)-(x2+18*x,y2+20*y),1,b
Line (x1+x*18+1,y1+20*y+1)-(x2+18*x-1,y2+20*y-1),1,b
Return
ClearCells:
For i=xmin To xmax
For j= ymin To ymax
cell(i,j)=0
Next j,i
Marks=0
HeartsFound=0
Return
ClearMessage:
Line (0,0)-(90,80),0,BF
Return
ClearHelpText:
Line (0,19*12)-(MM.HRes,MM.VRes),0,BF
Return
PrintText:
Font #2,1,1
Print @(MM.HRes/2-149,0) " Hearts and Bones "
Font #4
Print @(MM.HRes-62,0) "$"
Print @(MM.HRes-85,20) "&"
Print @(MM.HRes-40,20) "%"
Print @(MM.HRes-62,40) "$"
Font #1
Return
PrintHighScore:
Font #1,1,1
Print @(MM.HRes-85,7*12) "High score"
Font #1,1,0
Print @(MM.HRes-75,8*12) Format$(HighScore,"%5g")
Return
PrintScore:
Font #1,1,1
Print @(MM.HRes-85,10*12) " Score "
Font #1,1,0
Print @(MM.HRes-75,11*12) Format$(Score,"%5g")
Return
PrintBones:
Font #1,1,1
Print @(MM.HRes-85,13*12) " Bones "
Font #1,1,0
Print @(MM.HRes-75,14*12) Format$(NumBones,"%5g")
Return
PrintMarks:
Font #1,1,1
Print @(MM.HRes-85,16*12) " Marks "
Font #1,1,0
Print @(MM.HRes-75,17*12) Format$(Marks,"%5g")
Return
PrintInitialFnKeys:
Print @(10,7*12) "(F1) Play"
Print @(10,9*12) "(F2) Bones"
Print @(10,11*12) "(F3) Keys"
Print @(10,13*12) "(F4) Help"
Print @(10,17*12) "(Esc) Quit"
Return
PrintGameFnKeys:
Print @(10,13*12) "(F1) Re-Start"
Print @(10,15*12) "(Esc) Quit"
Return
Sub PrintNum(x,y,Count)
Print @(x0+x*18,y0+y*20) Count
End Sub
Sub PrintSprite(x,y,Txt$)
Font #4
Print @(x0+x*18,y0+y*20-3) Txt$
Font #1
End Sub
Sub ClearSprite(x,y)
Line (x1+x*18,y1+20*y)-(x2+18*x,y2+20*y),0,bf
End Sub
PlaceHearts:
Restore
Font #4
For i = 1 To 8
Read j,k
cell(j,k)=HeartCell*10 '*** will later have number of adjacent bones added
PrintSprite(j,k,"$")
Next
Font #1
Return
PlaceBones:
Cell(0,0)=1 '*** top left cell must not be a bone
For i=1 To numbones
Do
j=Int(Rnd()*xmax)
k=Int(Rnd()*ymax)
Loop Until cell(j,k)=0 'ignore if bone or heart already there
cell(j,k)=Bone 'place bone in cell
Next
Cell(0,0)=0 '*** clear top left cell
Return
CountBones:
For i=xmin To xmax 'look at each cell
For j=ymin To ymax
If cell(i,j)=Bone Then 'add one to each adjacent non-bone cell
For k=i-1 To i+1
For l=j-1 To j+1
If k>=xmin And k<=xmax And l>=ymin And l<=ymax Then
If cell(k,l)<>Bone Then 'if adjacent cell not a bone
cell(k,l)=cell(k,l)+1
If Int(cell(k,l)/10)=HeartCell Then
PrintSprite(k,l,"$")
EndIf
EndIf
EndIf
Next l,k
EndIf
Next j,i
Return
Sub Move(i,j)
If Mark=1 Then
MarkBone(i,j)
'Move if target cell is bone, unmarked cell or heart
ElseIf cell(x+i,y+j)=bone Or Int(cell(x+i,y+j)/10)=UnmarkedCell Or Int(cell(x+i,y+j)/10)=HeartCell Then
x=x+i
y=y+j
If Int(cell(x,y)/10)=HeartCell Then
GoSub AddToScore
'*** Once a heart cell has been visited,
'*** it becomes an ordinary visited cell
ClearSprite(x,y)
cell(x,y)=Cell(x,y)+10*(UnmarkedCell-HeartCell)
EndIf
If Cell(x,y)=0 And NotOnZeroStack(x,y,ZeroStackTop) Then
GoSub FindAdjacentZeros
EndIf
If cell(x,y)=Bone Then
GameEnd=true
Else
PrintNum(x,y,Cell(x,y))
EndIf
EndIf
End Sub
Sub MarkBone (i,j)
'You can mark only Bone and unmarked empty cells and
'you can un-mark only marked cells.
If cell(x+i,y+j)=Bone Then 'mark an existing bone
CorrectMarks=CorrectMarks+1
cell(x+i,y+j)=MarkedBone
PrintSprite(x+i,y+j,"&")
marks=marks+1
ElseIf cell(x+i,y+j)=MarkedBone Then 'unmark an existing bone
CorrectMarks=CorrectMarks-1
cell(x+i,y+j)=Bone
ClearSprite(x+i,y+j)
Marks=Marks-1
ElseIf Int(cell(x+i,y+j)/10)=UnmarkedCell Then
cell(x+i,y+j)=cell(x+i,y+j)+10*MarkedCell 'mark an empty cell
PrintSprite(x+i,y+j,"&")
Marks=marks+1
ElseIf Int(cell(x+i,y+j)/10)=MarkedCell Then
cell(x+i,y+j)=cell(x+i,y+j)-10*MarkedCell 'unmark an empty cell
ClearSprite(x+i,y+j)
' Don't show value 'cause it may not have been visited
Marks=Marks-1
EndIf
GoSub PrintMarks
GoSub MarkOff
End Sub
FindAdjacentZeros:
Savex=x ' Save current cursor position
Savey=y
StackPtr=0
StackTop=1
Stack(StackTop)=x*100+y ' put current location on stack
Do ' If you step on a zero then all adjacent zeros are displayed
' and the boardering non-zero cells.
StackAdded=false
For i=x-1 To x+1
For j=y-1 To y+1
If i>=xmin And i<=xmax And j>=ymin And j<=ymax Then
If Int(cell(i,j)/10)<>Heartcell And Int(cell(i,j)/20)<>MarkedCell Then
PrintNum(i,j,Cell(i,j))
'EndIf
EndIf
If Cell(i,j)=0 Or cell(i,j)-10*HeartCell=0 Then
GoSub IsCellOnStack
If NotOnStack Then
StackTop=StackTop+1 'inc stack pointer
Stack(StackTop)=i*100+j 'code cell address as xxyy
StackAdded=true
EndIf
EndIf
EndIf
Next j,i
If Not StackAdded Then 'If no new zero cells, point at previous one
StackPtr=StackPtr-1 ' Otherwise go to the top of the stack
Else
StackPtr=StackTop
EndIf
'get cell x,y from top of stack
If stackptr >=0 Then
x=Int(stack(stackPtr)/100)
y=stack(Stackptr)-x*100
Else
stackPtr=0
EndIf
Loop Until StackPtr=0
GoSub AccumulateStack
If StackTop > MaxStackTop Then
MaxStackTop=StackTop
EndIf
x=Savex 'Restore the entry cell
y=Savey
Return
AccumulateStack:
For i=0 To StackTop
ZeroStack(ZeroStackTop)=stack(i)
ZeroStackTop=zeroStackTop+1
Next
Return
Function NotOnZeroStack(i,j,z)
NotOnZeroStack=true
For k=0 To z
If ZeroStack(k)=i*100+j Then
NotOnZeroStack=false
Exit For
EndIf
Next k
End Function
IsCellOnStack: 'Checks to see if the cell is already on the stack
NotOnStack=true
For k=0 To StackTop
If Stack(k)=i*100+j Then
NotOnStack=false
Exit For
EndIf
Next k
Return
AddToScore: 'Score one point for each Heart visited
HeartsFound=HeartsFound+1
Score=Score+1
GoSub PrintScore
If Score>HighScore Then
HighScore=Score
GoSub PrintHighScore
EndIf
Return
ShowAllBones:
For i=0 To xmax
For j=0 To ymax
If Cell(i,j)=bone Then
PrintSprite(i,j,"&")
ElseIf Int(Cell(i,j)/10)=MarkedCell Then
PrintSprite(i,j,"%")
EndIf
Next j
Next i
Return
Markoff:
mark=0
Print @(12*10,MM.VRes-12*2) Space$(40)
Return
DefaultKeys:
UL=55 ' Up Left
UN=56 ' Up numeric
UA=128 ' Up arrow
UR=57 ' Up Right
LN=52 ' Left numeric
LA=130 ' Left Arrow
RN=54 ' Right numeric
RA=131 ' Right Arrow
DL=49 ' Down Left
DN=50 ' Down Numeric
DA=129 ' Down Arrow
DR=51 ' Down Right
MK=32 ' Mark (space)
Return
IncBones:
GoSub PrintF2Help
NumBones=NumBones+1
GoSub PrintBones
Return
DecBones:
GoSub PrintF2Help
If NumBones<19 Then
Print
Print Space$(10) "C'mon, let's not make it too easy!! 18 is small enough."
Else
NumBones=NumBones-1
GoSub PrintBones
EndIf
Return
PrintF2Help:
i=14 ' Left indent
j=MM.VRes-16*12 ' Lines from bottom of screen
Print @(0,j) Space$(i-1);
Font #1,,1
Print " Increase or reduce the starting number of Bones. "
Font #1,,0
Print
Print Space$(i) "<F2> increses the number of starting Bones."
Print Space$(i) "<shift+F2> reduces the number."
Return
Setkeys:
i=14 ' Left indent
j=MM.VRes-17*12 ' Lines from bottom of screen
Print @(0,j) Space$(i-1);
Font #1,,1
Print " Set the direction keys and the key to mark a bone. "
Font #1,,0
Print
Print Space$(i); "The defaults are the numeric keypad and spacebar."
Print Space$(i); "Press <Esc> to exit without saving, <Enter> for defaults,"
Print Space$(i); "or follow the prompts to set your own direction keys."
Print
Print Space$(i); "Press a key for... Up Left ? ";: GoSub getkey
i=i+19
If Asc(K$)=13 Then
GoSub defaultKeys
Print "<F1>"
ElseIf Asc(k$)<>27 Then
UL=Asc(k$): Print K$
Print Space$(i); "Up ? ";: GoSub getkey: UN=Asc(K$): Print k$
Print Space$(i); "Up Right ? ";: GoSub getkey: UR=Asc(K$): Print k$
Print Space$(i); "Left ? ";: GoSub getkey: LN=Asc(K$): Print k$
Print Space$(i); "Right ? ";: GoSub getkey: RN=Asc(K$): Print k$
Print Space$(i); "Down Left ? ";: GoSub getkey: DL=Asc(K$): Print k$
Print Space$(i); "Down ? ";: GoSub getkey: DN=Asc(K$): Print k$
Print Space$(i); "Down Right? ";: GoSub getkey: DR=Asc(K$): Print k$
Print Space$(i); "Mark Bone ? ";: GoSub getkey: MK=Asc(K$): Print k$
EndIf
' Clear the text
GoSub ClearHelpText
Return
Help:
Print @(0,MM.VRes-16*12);
?" Your task is to capture all of the Hearts without stepping on any Bones."
?" On capturing the last Heart, you move to a new level with 2 more Bones."
?" The game ends when you step on a Bone. All Bones (skulls) and any"
?" incorrectly marked Bones (crossed bones) then are revealed."
?" You score one point for each Heart captured and if you correctly mark all"
?" of the Bones, you score a bonus of 8 points for that level. You forfeit"
?" the bonus if you leave a mark on a square that doesn't contain a Bone."
?" You move the cursor using the numeric keypad and mark a Bone by pressing"
?" the space bar followed by a direction key. Un-mark a Bone in the same way."
?" Each square you step on reveals the number of Bones in adjacent squares."
?" Before you start a game you can set the starting number of Bones."
?" Press <F2> to increase; <Shift+F2> to reduce. As you may not have a numeric"
?" keypad, <F3> allows you to define direction keys and these are saved at the"
?" end of the game along with your highest score and starting number of Bones."
? Space$(17) "Good Luck! Press any key to exit Help."
Return
LoadGame:
Print @(0,21*12) Space$(10) "Please enter your name so I can load your highest score,"
Print Space$(10) "starting number of bones and direction keys";
Input FName$
If Len(FName$)>8 Then FName$=Left$(FName$,8)
FName$=FName$+".xls"
Option Error Continue
Open FName$ For input As #1
If MM.Errno=0 Then
Input #1,HighScore
Input #1,UL,UN,UA,UR,LN,LA ' direction key assignments
Input #1,RN,RA,DL,DN,DA,DR,MK
Input #1,StartBones
Close #1
EndIf
Option Error Abort
GoSub ClearHelpText
Return
SaveGame:
Open FName$ For output As #1
Print #1,HighScore
Print #1,UL","UN","UA","UR","LN","LA ' direction key assignments
Print #1,RN","RA","DL","DN","DA","DR","MK
Print #1,StartBones
Close #1
Return
Finish:
GoSub ShowAllBones
GoSub SaveGame
i=0:j=10
Font #2,,1
Print @(j,i*12) " Game "
Print @(j,(i+2)*12) " Over "
Font #1,,0
Print @(j-2,(i+4)*12) "No More Hearts"
Print @(j-2,(i+5)*12) " For You "
Font #2,,1
For k=1 To 3
Pause 300
Print @(j,i*12) Space$(6)
Print @(j,(i+2)*12) Space$(6)
Pause 300
Print @(j,i*12) " Game "
Print @(j,(i+2)*12) " Over "
Next
Font #1,,0
Print @(0,MM.VRes-6*12)
Return
mmbasic_original/hearts_and_bones_v1_0.txt · Last modified: 2024/01/19 09:39 by 127.0.0.1