| Welcome, Guest |
You have to register before you can post on our site.
|
| Forum Statistics |
» Members: 483
» Latest member: aplus
» Forum threads: 2,799
» Forum posts: 26,404
Full Statistics
|
|
|
| Variations on Peg Solitaire |
|
Posted by: PhilOfPerth - 08-08-2024, 09:32 AM - Forum: Games
- No Replies
|
 |
This game is another rendition of the old Peg Solitaire, with a few extra twists.
It uses a square grid, and players can choose between 3 modes, with horizontal+vertical jumps, diagonal jumps, or both, with a timer for each level. Hi-Scores are kept for the best 3 results for each mode. Score is based on pegs removed and time taken.
Code: (Select All) SW = 1020: SH = 780 ' select window size
Screen _NewImage(SW, SH, 32)
Common Shared CPL, MX, MY, FROM, FromH, FromV, TOO, MidCell, TooH, Toov, Cells(), Mode, Score
Common Shared Best$(), T1, Name$, Distance, OK$, Bad$, Pick$, HiFrame$
Dim Cells(49, 5), Best$(18) ' each cell has 4 positions and a char-number
OK$ = "l32o3cg": Bad$ = "l16o1gc": Pick$ = "o4l54g": HiFrame$ = "r145d83l145u83"
Data "40","HAMMER","30","HAMMER","20","HAMMER","35","HAMMER","25","HAMMER","15","HAMMER","30","HAMMER","20","HAMMER","10","HAMMER"
SetFont: f& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 20, "monospace"): _Font f& ' monospace font
SMode = 32
CPL = SW / _PrintWidth("X") ' chars per line for this window width
lhs = (_DesktopWidth - CPL) / 2 ' position for LHS of window
_ScreenMove (_DesktopWidth - SW) / 2, 90 ' place window there
Play OK$
PrepareBestList:
Cls
If Not (_FileExists("best")) Then ' if hi-score list is not found, create it
centre "Hi-Score list refreshed", 14: Play OK$: Sleep 1: Restore
refreshed = 1
ReDim Best$(18)
Open "best" For Output As #1
For a = 1 To 18
Read Best$(a)
Write #1, Best$(a)
Next
Close
End If
Open "best" For Input As #1
For a = 1 To 18: Input #1, Best$(a): Next ' place hi-scores in Best$()
Close
Intro
ShowBest
KeepOrKill:
If refreshed = 0 Then
k$ = ""
Yellow: centre "Keep these records (y/n) ?", 37
While k$ = "": k$ = InKey$: Wend
If UCase$(k$) = "N" Then
Kill "best": GoTo PrepareBestList ' if not wanted, delete and create a new one
End If
Cls
End If
Cls
Play OK$
PlayerPrefs:
centre "Your name (to 6 characters) ? ", 12 ' spaces move centre to left
Locate 12, 48: Input Name$
If Len(Name$) > 6 Then
Name$ = Left$(Name$, 6)
Else If Len(Name$) < 2 Then Name$ = "ANON"
End If
Name$ = UCase$(Name$): WIPE "12": centre Name$, 12
Play OK$
Sleep 1
Cls
centre "Select a mode (1 to 3)", 14: Sleep
While k$ < "1" And k$ > "3": Wend
k$ = InKey$
Mode = Val(k$)
Cls
SetPegs: ' 7*7 cells, 5 elements each
For a = 0 To 6
For b = 0 To 6
Cells(a * 7 + b + 1, 1) = a * 52 + 314 ' 1st element left top of cell
Cells(a * 7 + b + 1, 2) = a * 52 + 366 ' 2nd elementright top of cell
Cells(a * 7 + b + 1, 3) = b * 40 + 48 ' 3rd element left bottom of cell
Cells(a * 7 + b + 1, 4) = b * 40 + 88 ' 4th element right bottom of cell
'Set Cells(49,5) for all cells to 42
Cells(a * 7 + b + 1, 5) = 42 ' 5th element chr$(42) * in all cells
Next
Next
SetVacantCell: ' Select Vacant cell, not on edge of grid
Do
vac = Int(Rnd * 33) + 9 ' select (random) empty cell
Loop Until vac Mod (7) <> 0 And vac Mod (7) <> 1 ' if this is an edge cell, try again
vacv = 3 + Int(vac / 7) * 2 + 1 ' vacant cell vertical position in grid
vach = 19 + (vac Mod (7) + 1) * 4 ' vacant cell horizontal position in grid
Cells(vac, 5) = 32 ' mark vac as vacant in cells() array
Cells(vac, 5) = 32 ' mark vacant cell as chr$(32) space in cells() (32 is space)
ShowCells:
For a = 1 To 7 ' for each row of grid
For b = 1 To 7 ' for each cell of row
Locate 2 + a * 2, 23 + b * 4: Print "*" ' fill all with *
Next
Next
Green
Locate vacv, vach: Print "O" ' place green O in vacant cell to identify it
DrawGridFrame:
Play OK$
Yellow
H = 22 ' start frame from horizontal 22
For a = 0 To 6 ' 7 horizontal squares in frame
For b = 0 To 6 ' 7 vertical rows of squares
PSet (a * 52 + 316, b * 40 + 48)
Draw "r52d40l52u40"
Next
Next
ShowEnd:
Locate 18, 38: Print "END" ' show END cell
Yellow
PSet (473, 330): Draw "r52d36l52u36" ' draw END frame
ShowBest
T1 = Timer ' start timer
txt$ = "Mode" + Str$(Mode) + " selected"
centre txt$, 24
ChooseFROM:
GetFrom ' call sub to select FROM cell
If FROM < 0 Then Play Bad$: GoTo ChooseFROM
If FROM = 50 Then Done
ChooseTO:
GetToo
If TOO <= 0 Then Play Bad$: GoTo ChooseFROM
If TOO = 50 Then Done
FindMidCell
If Distance = 0 Then Play Bad$: GoTo ChooseFROM
ChangeCells
CalcScore
GoTo ChooseFROM
' *** Subs below here ***
Sub CreateBest
If _FileExists("best") Then Kill "best"
Restore
ReDim Best$(18)
Open "best" For Output As #1
For a = 1 To 18
Read Best$(a)
Write #1, Best$(a)
Next
Close
'End If
Open "best" For Input As #1
For a = 1 To 18: Input #1, Best$(a): Next
Close
End Sub
Sub ShowBest
Yellow: centre "Scores to Beat", 30
Locate 32, 17
Print "Mode 1"; Tab(37); "Mode 2"; Tab(57); "Mode 3": White
For a = 0 To 2
For b = 1 To 5 Step 2
Locate 33 + a, 10 * b + 4
Print Best$(a * 6 + b); Tab(10 * b + 8); Best$(a * 6 + b + 1)
Next
Next
Yellow: PSet (160, 618): Draw HiFrame$: PSet (420, 618): Draw HiFrame$: PSet (680, 618): Draw HiFrame$
End Sub
Sub GetFrom:
centre "Choose FROM location", 20
Do
While _MouseButton(1): m% = _MouseInput: Wend ' wait for left-mouse to restore
m% = _MouseInput ' prepare mouse
If _MouseButton(1) Then ' get left-mouse status
MX = _MouseX: MY = _MouseY ' horiz and vert position
If MX > 473 And MX < 526 And MY > 330 And MY < 371 Then FROM = 50: Exit Sub ' END cell, mark FROM as 50
If MX < 316 Or MX > 680 Or MY < 48 Or MY > 328 Then FROM = -2: Exit Sub ' outside the grid, mark FROM as -2
FromH = Int((MX - 316) / 52) + 1 ' horiz column of FROM cell
FromV = Int((MY - 48) / 40) + 1 ' vert row of FROM cell
FROM = (FromV - 1) * 7 + FromH ' number of FROM cell, 1 to 49
If Cells(FROM, 5) = 32 Then FROM = -1: Exit Sub ' vacant cell, mark From as -1
End If
Loop Until _MouseButton(1)
Play Pick$
End Sub
Sub GetToo
WIPE "20": centre "Choose TO location", 20
Do
While _MouseButton(1): m% = _MouseInput: Wend ' wait for left-mouse to restore
m% = _MouseInput ' prepare mouse
If _MouseButton(1) Then ' get left-mouse status
MX = _MouseX: MY = _MouseY ' horiz and vert position
If MX > 473 And MX < 526 And MY > 330 And MY < 371 Then TOO = 50: Exit Sub ' END cell, mark FROM as 50
If MX < 316 Or MX > 680 Or MY < 48 Or MY > 328 Then TOO = -2: Exit Sub ' outside the grid, mark FROM as -2
TooH = Int((MX - 316) / 52) + 1 ' horiz column of FROM cell
Toov = Int((MY - 48) / 40) + 1 ' vert row of FROM cell
TOO = (Toov - 1) * 7 + TooH ' number of FROM cell, 1 to 49
If Cells(TOO, 5) <> 32 Then TOO = -1: Exit Sub ' vacant cell, mark From as -1
End If
Loop Until _MouseButton(1)
Play Pick$
End Sub
Sub FindMidCell
Distance = Abs(FROM - TOO) ' FROM and TOO are selected cell numbers
CheckDistance: ' check relative positions of cells
Select Case Mode
Case 1 ' 2 horiz, vert or diag is +/- 2, 12, 14 or 16
If Distance <> 2 And Distance <> 12 And Distance <> 14 And Distance <> 16 Then
Distance = 0
Red: centre "Cells must be 2 cells apart", 22
Play Bad$: Sleep 2: Yellow
WIPE "22": Exit Sub
End If
Case 2 ' 2 horiz or vert is +/-2 or 14
If Distance <> 2 And Distance <> 14 Then
Distance = 0
centre "Horizontal or vertical hops of 2 cells only", 22
Play Bad$: Sleep 2: Yellow
WIPE "22": Exit Sub
End If
Case 3 ' 2 diag is +/- 12 or 16
If Distance <> 12 And Distance <> 16 Then
Distance = 0
Red: centre "Diagonal hops of 2 cells only", 22
Play Bad$: Sleep 2: Yellow
WIPE "22": Exit Sub
End If
End Select
MidCell = (FROM + TOO) / 2: MidCellv = (FromV + Toov) / 2 + 4: MidCellh = (FromH + TooH) / 2 + 4
If Cells(MidCell, 5) = 32 Then
Distance = 0
Red: centre "Middle cell must be occupied!", 22
Play Bad$: Sleep 2: Yellow
WIPE "22": Exit Sub ' if not, get another FROM cell
End If
End Sub
Sub ChangeCells ' update grid display
Cells(FROM, 5) = 32
Cells(MidCell, 5) = 32
Cells(TOO, 5) = 42
ShowChanges: ' show changed pegs
Yellow
Locate FromV * 2 + 2, FromH * 4 + 23: Print " "
Locate Toov * 2 + 2, TooH * 4 + 23: Print "*"
Locate (FromV * 2 + 2 + Toov * 2 + 2) / 2, (FromH * 4 + 23 + TooH * 4 + 23) / 2: Print " "
End Sub
Sub CalcScore ' update score
WIPE "2628"
Picks = Picks + 1
Score = Picks * 10 + Int(T1 - Timer)
txt$ = "Score:" + Str$(Score)
centre txt$, 26
txt$ = "Pegs Remaining:" + Str$(48 - Picks)
centre txt$, 28
Play OK$
End Sub
Sub Done ' Player has finished
Cls
Play OK$: Play OK$
txt$ = "You scored " + LTrim$(Str$(Score))
centre txt$, 17
CheckHi
Sleep: Run
End Sub
Sub CheckHi
txt$ = "Checking against Hi-Scores for Mode" + Str$(Mode) + "..."
centre txt$, 19
win = 0
sc1 = 1 + (Mode - 1) * 2: nm1 = 2 + (Mode - 1) * 2
sc2 = 7 + (Mode - 1) * 2: nm2 = 8 + (Mode - 1) * 2
sc3 = 13 + (Mode - 1) * 2: nm3 = 14 + (Mode - 1) * 2
Select Case Score
Case Is > Val(Best$(sc1)) ' better than first - move 2nd down, 1st down, place score and name in 1st
Best$(sc3) = Best$(sc2): Best$(nm3) = Best$(nm2)
Best$(sc2) = Best$(sc1): Best$(nm2) = Best$(nm1)
Best$(sc1) = LTrim$(Str$(Score)): Best$(nm1) = Name$
win = 1: txt$ = "Congratulations, you beat First place"
Case Is = Val(Best$(sc1)), Is > Val(Best$(sc2)) ' better than second - move 2nd down, place score and name in 2nd
Best$(sc3) = Best$(sc2): Best$(nm3) = Best$(nm2)
Best$(sc2) = LTrim$(Str$(Score)): Best$(nm2) = Name$
win = 1: txt$ = "Congratulations, you beat Second place"
Case Is = Val(Best$(sc2)), Is > Val(Best$(sc3)) ' better than third - place score and name in 3rd
Best$(sc3) = LTrim$(Str$(Score)): Best$(nm3) = Name$
win = 1: txt$ = "Congratulations, you beat Third place"
End Select
If win = 1 Then
centre txt$, 21: Sleep 3: Cls
Open "best" For Output As #1
For a = 1 To 18: Write #1, Best$(a): Next ' save new Best score
Close
End If
ShowBest: Sleep 3: Run
End Sub
Sub White
Color _RGB(255, 255, 255)
End Sub
Sub Red
Color _RGB(255, 0, 0)
End Sub
Sub Green
Color _RGB(0, 255, 0)
End Sub
Sub Yellow
Color _RGB(255, 255, 0)
End Sub
Sub centre (txt$, linenum) ' centres text on selected line
ctr = Int(CPL / 2 - Len(txt$) / 2) + 1 ' centre is half of chars per line minus half string-length
Locate linenum, ctr
Print txt$
End Sub
Sub WIPE (ln$) ' (ln$ is string of 2-digit line-numbers) "0122" wold mean lines 1 and 22
For a = 1 To Len(ln$) - 1 Step 2
wl = Val(Mid$(ln$, a, 2)) ' get 2 digits of line to be wiped (wl),
Locate wl, 1: Print Space$(CPL); ' and write full row of spaces to that line
Next
End Sub
Sub Intro
'Show intro text
Yellow
centre "LeapFrog", 2: White: Print: Print
Print " A board of 7x7 cells is displayed, all except one occupied by pegs."
Print " Remove as many pegs as you can, by hopping another peg over them, as"
Print " quickly as you can. Hops may be in any direction (but see";: Yellow: Print " Modes";: White: Print " below),"
Print " over a single occupied cell, and the landing cell must be vacant.": Print
Print " With the mouse, choose a ";: Yellow: Print "FROM";: White: Print " cell, then a ";: Yellow
Print "TO";: White: Print " cell, with one occupied"
Print " cell between them. If these conditions are met, the cell between them"
Print " is cleared, and the action can be repeated. Otherwise, the move is"
Print " rejected, and you must try again with different cells."
Print " Select the ";: Yellow: Print "END ";: White:
Print " cell when you can find no more moves.": Print
Print " You receive ten points for each hop, but the final score is reduced by"
Print " one point per second of game time, so you need to be quick!"
Print " Or you can ignore the timer and just play to remove maximum pegs.": Print
Yellow: centre "Modes", 20: White
Print " There are 3 Modes of play, each with different directions for hops:"
Print " 1: Hop in any direction, horizontal, vertical or diagonal (Easy)"
Print " 2: Horizontal or vertical hops only, any of four directions (Medium)"
Print " 3: Diagonal hops only, any of four directions (Hard).": Print
Print " A Hi-score list of the three best results for each mode is kept, and"
Print " if you beat one of these, your result will be placed on this list."
End Sub
|
|
|
| orange pi / arm board and linking libraries for SPI and other devices |
|
Posted by: Parkland - 08-08-2024, 05:21 AM - Forum: General Discussion
- Replies (3)
|
 |
Greetings,
I hate asking, but I burned up a wild amount of time already so hoping for some direction.
I have QB64PE running on orange pi zero 3 with ubuntu desktop orange pi release.
I'm trying to communicate over SPI using qb64 (and other connections eventually)
I spent a ton of time looking online but theres always a ddead end it seems.
A friend suggested AI, so here's an SPI program AI designed :
Code: (Select All) DECLARE DYNAMIC LIBRARY "C"
FUNCTION open (path AS STRING, flags AS LONG) AS LONG
FUNCTION ioctl (fd AS LONG, request AS LONG, argp AS _OFFSET) AS LONG
FUNCTION write (fd AS LONG, buffer AS _OFFSET, count AS LONG) AS LONG
FUNCTION read (fd AS LONG, buffer AS _OFFSET, count AS LONG) AS LONG
FUNCTION close (fd AS LONG) AS LONG
END DECLARE
CONST O_RDWR = &H2
CONST SPI_IOC_MAGIC = &H6B
CONST SPI_IOC_RD_MODE = (SPI_IOC_MAGIC << 8) + 1
CONST SPI_IOC_WR_MODE = (SPI_IOC_MAGIC << 8) + 1
DIM fd AS LONG
DIM spi_mode AS _BYTE
DIM tx_buffer(0 TO 2) AS _BYTE
DIM rx_buffer(0 TO 2) AS _BYTE
' Open the SPI device
fd = open("/dev/spidev1.0", O_RDWR)
IF fd < 0 THEN
PRINT "Failed to open SPI device."
END
ELSE
PRINT "SPI device opened successfully."
END IF
' Set SPI mode (0, 1, 2, or 3)
spi_mode = 0
IF ioctl(fd, SPI_IOC_WR_MODE, _OFFSET(spi_mode)) < 0 THEN
PRINT "Failed to set SPI mode."
CALL close(fd)
END
ELSE
PRINT "SPI mode set successfully."
END IF
' Prepare data to send
tx_buffer(0) = &H9F ' Example command
' Send and receive data
IF write(fd, _OFFSET(tx_buffer(0)), 1) <> 1 THEN
PRINT "Failed to write to SPI device."
CALL close(fd)
END
ELSE
PRINT "Data written to SPI device."
END IF
IF read(fd, _OFFSET(rx_buffer(0)), 3) <> 3 THEN
PRINT "Failed to read from SPI device."
CALL close(fd)
END
ELSE
PRINT "Data read from SPI device: ";
FOR i = 0 TO 2
PRINT HEX$(rx_buffer(i)); " ";
NEXT
PRINT
END IF
' Close the SPI device
CALL close(fd)
PRINT "SPI device closed."
END
I've honestly never linked a file or anything else to any QB before.
Does the program look plausible though?
I really need to make this work somehow, I love QB64 and too old to learn anything else lol.
And I really need to make this project work...
|
|
|
|
| How to Disable Windows Finish Setup Notifications. |
|
Posted by: Pete - 08-07-2024, 04:59 PM - Forum: General Discussion
- Replies (4)
|
 |
In a recent Windows update a push notifications was added to constantly remind you to back up your entire system and finish setting up all the BS folks like me don't want. One-Drive, Office 365, Windows HELLo, mobile phone sync, etc. The popup only lets you delay setup for 3 days each time you choose not the continue. To disable it, you need to go to settings.
1) Type "Notifications" in your Windows task bar search line and open the Turn Notifications on and off selection.
2) Near the top, UNCHECK the box that reads: "Suggest ways I can finish setting up my device to get the most out of Windows."
3) Close the Settings app.
That should get rid of the pesky popup for good! I'll let you know if it doesn't, in 3 days.
Pete
|
|
|
|
| Stopping _SNDPLAYCOPY ?Possible? |
|
Posted by: TerryRitchie - 08-06-2024, 09:29 PM - Forum: Help Me!
- Replies (13)
|
 |
_SNDPLAYCOPY is very handy for repeating a sound needed from multiple sources (sprites, etc..) at the same time, such as multiple gunshots or other sounds from various sources. However, there is no way to stop sounds initiated with _SNDPLAYCOPY that I'm aware of.
Perhaps another sound command such as:
_SNDSTOPCOPY could be considered by the developers?
I realize I can use _SNDCOPY to create a new handle and concurrently play it. However, one would need to keep track of all those handle copies and then cycle through them all with _SNDSTOP. Take a game like Robotron 2084 that has hundreds of sprites creating many identical sounds and you'll see where I'm going here.
|
|
|
|
| Does vwatch still work? |
|
Posted by: justsomeguy - 08-05-2024, 06:18 PM - Forum: General Discussion
- Replies (13)
|
|
I see references to vwatch in the code in the main.txt file and there is still some code in support folder in QB64 directory. Is this still supported? I don't see anything in the local wiki.
If so, is there any docs on it?
Thanks
|
|
|
|
| Code Challenge: Snacky Friends, a donkey, and Apples |
|
Posted by: CharlieJV - 08-04-2024, 02:12 AM - Forum: Programs
- Replies (33)
|
 |
You'll find my solution for this challenge (coded with BAM) here.
The gist of the challenge:
Quote:Once upon a time, 3 friends bought apples and carried them on a donkey.
When night came, they decided to sleep in the forest.
The first friend woke up hungry at midnight, so he divided the apples into three equal shares.
The one extra remaining apple, he gave it to the donkey. He then ate his share and went back to sleep.
A while later, the second friend woke up hungry, so he divided the remaining apples into three equal shares.
The one extra remaining apple, he gave it to the donkey. He then ate his share and went back to sleep.
A while later, the third friend woke up hungry, so he divided the remaining apples into three equal shares.
The one extra remaining apple, he gave it to the donkey. He then ate his share and went back to sleep.
In the morning, the 3 friends woke up hungry, so they divided the remaining apples into three equal shares.
The one extra remaining apple, they gave it to the donkey. They then ate each of their share.
How many apples did they initially buy, and how many apples did each of them eat?
|
|
|
|
| Problem lining up same font with different heights. |
|
Posted by: Pete - 08-02-2024, 03:01 PM - Forum: Help Me!
- Replies (10)
|
|
Code: (Select All)
$Color:32
Screen _NewImage(1300, 600, 32)
_ScreenMove 20, 0
Cls: _Display
Dim f&(6)
f&(1) = _LoadFont(Environ$("SYSTEMROOT") + "\Fonts\lucon.ttf", 16)
f&(2) = _LoadFont(Environ$("SYSTEMROOT") + "\Fonts\lucon.ttf", 20)
f&(3) = _LoadFont(Environ$("SYSTEMROOT") + "\Fonts\lucon.ttf", 24)
f&(4) = _LoadFont(Environ$("SYSTEMROOT") + "\Fonts\lucon.ttf", 30)
f&(5) = _LoadFont(Environ$("SYSTEMROOT") + "\Fonts\lucon.ttf", 38)
f&(6) = _LoadFont(Environ$("SYSTEMROOT") + "\Fonts\lucon.ttf", 48)
f& = 1: _Font f&(f&)
Line (20, 201)-(200, 201)
row = 200
_Font (f&(1))
fh& = _FontHeight
_PrintString (20, row - fh&), "O"
_Font (f&(2))
fh& = _FontHeight
_PrintString (50, row - fh&), "O"
_Font (f&(3))
fh& = _FontHeight
_PrintString (80, row - fh&), "O"
_Font (f&(4))
fh& = _FontHeight
_PrintString (110, row - fh&), "O"
_Font (f&(5))
fh& = _FontHeight
_PrintString (140, row - fh&), "O"
_Font (f&(6))
fh& = _FontHeight
_PrintString (170, row - fh&), "O"
_Font (f&(1))
I thought subtracting the height of the font from the row would make the bottoms of each character align themselves horizontally on the line. What I noticed is that as the font size is increased, the larger character prints progressively slightly higher, above the line. Is there a remedy for this, and not just with lucon fonts, but others as well?
Pete
|
|
|
|
|
