07-14-2023, 08:27 PM (This post was last modified: 07-14-2023, 08:30 PM by bplus.)
Here is graphics Sliding Block, you pick the tile number 3x3 to 9x9 then use mouse to click block to move into space:
Code: (Select All)
_Title "GUI repeating Sliding Blocks Game "
Randomize Timer
' get from user the desired board size = s
Do
Locate CsrLin, 3: Input "(0 quits) Enter your number of blocks per side 3 - 9 you want > ", s
If s = 0 Then End
Loop Until s > 2 And s < 10
' screen setup: based on the square blocks q pixels a sides
q = 540 / s 'square size, shoot for 540 x 540 pixel board display
Screen _NewImage(q * s + 1, q * s + 1, 32): _ScreenMove 360, 60
Dim board(s, s)
restart:
'initialize board = solution
For r = 1 To s
For c = 1 To s
board(c, r) = c + (r - 1) * s
Next
Next
board(s, s) = 0: c0 = s: r0 = s
'scramble board for puzzle
For i = 0 To s ^ 5 ' mix blocks
Select Case Int(Rnd * 4) + 1
Case 1: If c0 < s Then board(c0, r0) = board(c0 + 1, r0): board(c0 + 1, r0) = 0: c0 = c0 + 1
Case 2: If c0 > 1 Then board(c0, r0) = board(c0 - 1, r0): board(c0 - 1, r0) = 0: c0 = c0 - 1
Case 3: If r0 < s Then board(c0, r0) = board(c0, r0 + 1): board(c0, r0 + 1) = 0: r0 = r0 + 1
Case 4: If r0 > 1 Then board(c0, r0) = board(c0, r0 - 1): board(c0, r0 - 1) = 0: r0 = r0 - 1
End Select
Next
t = Timer: update = -1: mc = 0 'OK user here you go!
Do
If update Then 'display status and determine if solved
solved = -1: update = 0
For r = 1 To s
For c = 1 To s
If board(c, r) Then
If board(c, r) <> (r - 1) * s + c Then solved = 0
Color _RGB32(255, 255, 255), _RGB32(0, 0, 255)
Line ((c - 1) * q + 1, (r - 1) * q + 2)-(c * q - 2, r * q - 2), _RGB32(0, 0, 255), BF
_PrintString ((c - 1) * q + .4 * q, (r - 1) * q + .4 * q), Right$(" " + Str$(board(c, r)), 2)
Else
If board(s, s) <> 0 Then solved = 0
Color _RGB32(0, 0, 0), _RGB32(0, 0, 0)
Line ((c - 1) * q, (r - 1) * q)-(c * q, r * q), , BF
End If
Next
Next
If solved Then 'flash the Solved Report until user closes window else report status
_Display
flash$ = "Solved!" + Str$(mc) + " Moves in " + Str$(Int(Timer - t)) + " secs."
For i = 1 To 20: _Title flash$: _Delay .2: _Title " ": _Delay .2: Next
Cls: Color _RGB32(255, 255, 0)
_PrintString (190, 260), "Another Round? y for yes"
k$ = "": _Display
Do
k$ = InKey$
Loop Until Len(k$)
If k$ = "y" Then Cls: GoTo restart Else End
Else
_Title Str$(mc) + " Moves in " + Str$(Int(Timer - t)) + " secs." + Str$(test)
End If
_Display
End If
'get next mouse click, check if on block next to empty space make move or beep
m = _MouseInput: mb = _MouseButton(1): mx = _MouseX: my = _MouseY
If mb And solved = 0 Then 'get last place mouse button was down
mb = _MouseButton(1): mx = _MouseX: my = _MouseY
While mb 'left button down, wait for mouse button release
m = _MouseInput: mb = _MouseButton(1): mx = _MouseX: my = _MouseY
Wend
'convert mouse position to board array (x, y) are we near empty space?
bx = Int(mx / q) + 1: by = Int(my / q) + 1: update = -1
If bx = c0 + 1 And by = r0 Then
board(c0, r0) = board(c0 + 1, r0): board(c0 + 1, r0) = 0: c0 = c0 + 1: mc = mc + 1
ElseIf bx = c0 - 1 And by = r0 Then
board(c0, r0) = board(c0 - 1, r0): board(c0 - 1, r0) = 0: c0 = c0 - 1: mc = mc + 1
ElseIf bx = c0 And by = r0 + 1 Then
board(c0, r0) = board(c0, r0 + 1): board(c0, r0 + 1) = 0: r0 = r0 + 1: mc = mc + 1
ElseIf bx = c0 And by = r0 - 1 Then
board(c0, r0) = board(c0, r0 - 1): board(c0, r0 - 1) = 0: r0 = r0 - 1: mc = mc + 1
Else
Beep
End If
End If
_Limit 500
Loop
here is game carlos brought to my attention at the other place
Code: (Select All)
_Title "Old SHMUP game"
Screen 0: Width 80: Color 15
Dim sk As String
Dim b$, m$, a$
Dim x, y, mx, my, ax, ay
x = 37
y = 23
b$ = " ÜÛÜ "
aa = 0
a$ = "*"
ma = 0
m$ = "|"
Do
If Inp(&H60) = 75 Then
x = x - 1
End If
If Inp(&H60) = 77 Then
x = x + 1
End If
If x < 1 Then x = 1
If x > 75 Then x = 75
If aa = 0 Then
ax = Int(Rnd(1) * 76) + 2
ay = Int(Rnd(1) * y)
aa = 1
Locate ay, ax
Print a$
End If
If Inp(&H60) = 57 And ma = 0 Then
mx = x + 2
my = y - 1
ma = 1
End If
Locate y, x
Print b$
If ma = 1 Then
Locate my, mx
Print " "
my = my - 1
If my < 1 Then
ma = 0
Else
Locate my, mx
If mx = ax And my = ay Then
aa = 0
ma = 0
Locate ay, ax
Print " "
ax = Int(Rnd(1) * 76) + 2
ay = Int(Rnd(1) * y)
Else
Print m$
End If
End If
End If
_Display
_Limit 20
Loop Until InKey$ = Chr$(27) ' Pressionar a tecla Esc para sair
he wanted to build a character editor to change the shape of canon. i showed how he might do that without building character editor (for screen 0 chars, which i'm not sure how to do, graphics screen easy but changing screen 0, don't know...) I went on to make over the whole game, kinda cute
SHMUP mod b+
Code: (Select All)
Option _Explicit
_Title "SHMUP mod 1 b+ 2024-05-02"
Screen 0: Width 80: Color 15
Dim cannon1$, cannon2$, missile$, alien$
Dim As Integer cannonX, cannonY, missileX, missileY, missileActive
Dim As Integer alienX, alienY, alienActive, invaded, repelled, frame
Dim As Long kh
cannonX = 37
cannonY = 23
cannon1$ = " ÜÛÜ " 'this works better
cannon2$ = "ÛÛ ÛÛ"
alienActive = 0
alien$ = "<" + Chr$(233) + ">"
missileActive = 0
missile$ = "|"
'invaded = 60
Do
Cls
kh = _KeyHit
If kh = 19200 Then 'LEFT
cannonX = cannonX - 1
ElseIf kh = 19712 Then ' RIGHT
cannonX = cannonX + 1
ElseIf kh = 32 And missileActive = 0 Then
missileX = cannonX + 2
missileY = cannonY
missileActive = 1
End If
If cannonX < 1 Then cannonX = 1
If cannonX > 75 Then cannonX = 75
If alienActive = 0 Then
alienX = Int(Rnd * 76) + 2 - 1
alienY = 1
alienActive = 1
frame = 0
Else
frame = frame + 1
If frame = 15 Then alienY = alienY + 1: frame = 0
If alienY = 23 Then
invaded = invaded + 1
alienActive = 0
End If
End If
Locate alienY, alienX 'draw invader
Print alien$
If missileActive = 1 Then ' handle missile
missileY = missileY - 1
If missileY < 1 Then
missileActive = 0
Else
Locate missileY, missileX
If missileX = alienX + 1 And missileY = alienY Then ' hit
alienActive = 0
missileActive = 0
Locate alienY, alienX
Print " * "
repelled = repelled + 1
_Display
_Delay .1
alienX = Int(Rnd(1) * 76) + 2 + 1 'new alien
alienY = Int(Rnd(1) * cannonY)
Else
Print missile$
End If
End If
End If
_Title "Shumps Invaded:" + Str$(invaded) + " Repelled:" + Str$(repelled)
_Display
_Limit 60
If Abs(invaded - repelled) > 25 Then Exit Do
Loop Until InKey$ = Chr$(27) ' Pressionar a tecla Esc para sair
If invaded - repelled > 25 Then
Locate 12, 27: Print "Game over Aliens took over ;("
ElseIf repelled - invaded > 25 Then
Locate 12, 28: Print "Game over Aliens defeated :)"
End If
_Display
End
_Title "lotto for carlos" ' b+ 2024-05-30
Randomize Timer
Width 80, 40 ' <<< 30 so can fit 25 rows on screen 0
Dim a$(1 To 3)
a$(1) = "02 03 05 06 09 10 11 13 14 16 18 20 23 24 25"
a$(2) = "01 04 05 06 07 09 11 12 13 15 16 19 20 23 24"
a$(3) = "01 04 06 07 08 09 10 11 12 14 16 17 20 23 24"
Locate 4
Print CountDigits$(a$(), 25)
Print " press any for TicketMaker Demo of 7 tickets of 3 numbers from 1 to 100..."
Sleep
Cls
Dim As Long n, numbers, i, top
n = 7: numbers = 3: top = 100
Dim tickets$(1 To n)
Print n; " tickets,"; numbers; " numbers from 1 to"; top; ":"
For i = 1 To n
tickets$(i) = TicketMaker$(numbers, top)
Print i, tickets$(i)
Next
Print: Print "Number Counts:"
Print CountDigits$(tickets$(), top)
Print: Print " press any to input your own specs for a multiple ticket purchase..."
Sleep
Cls
Print
Print " Multiple tickets purchase:"
Input "Limit 25 for space Please enter Top number limit "; top
Input "Limit 10 for space Please enter number of numbers on a ticket "; numbers
Input "Limit 5 for space Please enter number of tickets to purchase "; n
Cls
If top > 25 Then top = 25
If numbers > 10 Then numbers = 10
If n > 5 Then n = 5
Dim lotto$(1 To n)
Print: Print n; " tickets,"; numbers; " numbers from 1 to"; top; ":"
For i = 1 To n
lotto$(i) = TicketMaker$(numbers, top)
Print i, lotto$(i)
Next
Print: Print "Number Counts:"
Print CountDigits$(lotto$(), top)
Function CountDigits$ (digits$(), highest As Long)
Dim As Long i, j, num, count(1 To highest) ' variables to process digits strings
Dim rtn$ ' <<< prepare to set function to return this string when done
For i = LBound(digits$) To UBound(digits$) ' count the whole array of digit strings
For j = 1 To Len(digits$(i)) Step 3 ' one digit string break down to 3 digit parts
num = Val(Mid$(digits$(i), j, 3)) ' convert string to number
count(num) = count(num) + 1 ' add to count of that number
Next
Next
For i = 1 To highest ' if not 0, lines of counts put into one l o n g string
If count(i) Then
rtn$ = rtn$ + S2$(i) + " = " + TS2$(count(i)) + Chr$(10)
End If
Next
CountDigits$ = rtn$ ' <<< returns 25 rows of print in one string
End Function
Function TicketMaker$ (number As Long, highest As Long)
' number = number of 2 digit numbers you want
' lowest number allowed is always 1
' highest number allowed
' because no repeats digits, number can not exceed highest
' please return the numbers sorted from low to high
Dim As Long shuffle(1 To highest), sort(1 To number), i
Dim rtn$
For i = 1 To highest
shuffle(i) = i
Next
For i = highest To 2 Step -1
Swap shuffle(i), shuffle(Int(Rnd * i) + 1)
Next
For i = 1 To number
sort(i) = shuffle(i)
Next
QuickSort 1, number, sort()
For i = 1 To number
If Len(rtn$) Then rtn$ = rtn$ + " " + S2$(sort(i)) Else rtn$ = S2$(sort(i))
Next
TicketMaker$ = rtn$
End Function
Sub QuickSort (start As Long, finish As Long, array() As Long)
Dim Hi As Long, Lo As Long, Middle As Long
Hi = finish: Lo = start
Middle = array((Lo + Hi) / 2) 'find middle of array
Do
Do While array(Lo) < Middle: Lo = Lo + 1: Loop
Do While array(Hi) > Middle: Hi = Hi - 1: Loop
If Lo <= Hi Then
Swap array(Lo), array(Hi)
Lo = Lo + 1: Hi = Hi - 1
End If
Loop Until Lo > Hi
If Hi > start Then Call QuickSort(start, Hi, array())
If Lo < finish Then Call QuickSort(Lo, finish, array())
End Sub
Function TS$ (n As Long) ' Trim String for Long Type but integers should work as well
TS$ = _Trim$(Str$(n))
End Function
Function TS2$ (n As Long) ' Trim String for Long Type but integers should work as well
TS2$ = Right$(" " + TS$(n), 2)
End Function
Function S2$ (n As Long)
S2$ = Right$("00" + TS$(n), 2)
End Function
05-31-2024, 03:44 AM (This post was last modified: 05-31-2024, 03:46 AM by JRace.)
Neat program. It might be fun to experiment with, to make it select an optimum distribution of numbers across all tickets to increase the odds of winning something.
If the user is in the habit of pressing <ENTER> to continue from a Sleep statement (as I am), then they may need to add a _KEYCLEAR statement after line 24. My single press of <ENTER> was read as the <ENTER> key for the first two or three Inputs as well.
ah, I am in habit of spacebar for sleep, thanks for your report.
Carlos seems more interested in seeing the distribution of numbers from their actual history. But we should not count on using history to predict future, except when it comes to sun rises ;-))
Someone showed me some code not working and I updated it to QB64 and had fun doing this
Simple Game Update
Code: (Select All)
_Title "Simple Game Update" ' bplus 2024-07-17
' remember Locate works backwards from all graphics commands
' Y vertical is listed first then x horizontal.
' I call it Row, Col to distinguish from graphics (x, y)
DefInt A-Z ' using default screen 0, simplest of all screen commands is none!
Randomize Timer ' so we start in differnt places on board
Dim maze(1 To 14, 1 To 12) 'this is our game board
For x = 1 To 14 ' marks board borders and draws them
y = 1
maze(x, y) = 1
Locate y, x: Print "#";
y = 12
maze(x, y) = 1
Locate y, x: Print "#";
Next
For y = 2 To 11
x = 1
maze(x, y) = 1
Locate y, x: Print "#";
x = 14
maze(x, y) = 1
Locate y, x: Print "#";
Next
x = Int(Rnd * 7) + 3 ' set a random place to start
y = Int(Rnd * 5) + 3
Do
Locate 15, 2: Print "score:"; S ' udate score and player
Locate y, x
Print Chr$(1); ' this draw a cute little face
If maze(x, y) = 1 Then
Locate y, x: Print "*";
Locate 18, 1: Print "Wall! Game Over!"
End
End If
If maze(x + 1, y) = 1 Then ' is there a place to move
If maze(x - 1, y) = 1 Then
If maze(x, y + 1) = 1 Then
If maze(x, y - 1) = 1 Then
Locate 18, 1: Print "Trapped! Game Over!": End
End If
End If
End If
End If
kh& = _KeyHit
Select Case kh&
Case 18432: dry = -1
Case 20480: dry = 1
Case 19200: drx = -1
Case 19712: drx = 1
Case 27: End
End Select
If drx <> 0 Or dry <> 0 Then GoSub mover
_Limit 30
Loop
mover:
Locate y, x: Print " ";
x = x + drx
y = y + dry
drx = 0
dry = 0
tryAgain:
newx = x + Int(Rnd * 3) - 1
newy = y + Int(Rnd * 3) - 1
If newy = y And newx = x Then GoTo tryAgain
If maze(newx, newy) = 1 Then GoTo tryAgain
maze(newx, newy) = 1
Locate newy, newx: Print "#"; ' mark new block
S = S + 1 ' increase score
Return
Like calling heads or tails call red or green side:
Code: (Select All)
_Title "Circle Flip Game" 'b+ 2024-09-12
Randomize Timer
Screen _NewImage(800, 600, 32)
_ScreenMove 250, 60
imgRed& = _NewImage(103, 103, 32)
_Dest imgRed&
FC3 51, 51, 50, &HFFFF0000
imgGrn& = _NewImage(103, 103, 32)
_Dest imgGrn&
FC3 51, 51, 50, &HFF008800
_Dest 0
While _KeyDown(27) = 0
Locate 18, 20
Print "Your score"; score; "in"; flips; "flips."
Locate 20, 20
Input "Enter r for red, g for green any else quits "; rg$
If rg$ <> "r" And rg$ <> "g" Then End
If Rnd < .5 Then img& = imgRed& Else img& = imgGrn&
If img& = imgGrn& And rg$ = "g" Then score = score + 1
If img& = imgRed& And rg$ = "r" Then score = score + 1
flips = flips + 1
start = 1: fini = 0: stepper = -.02
cx = 180: cy = _Height - 50: dcy = -3
Do
For i = start To fini Step stepper
Cls
a = a + 1
cx = cx + .8
dcy = dcy + .009
cy = cy + dcy
If dcy = 0 Then dcy = -dcy
RotoZoom23d cx, cy, img&, i, 1, a
_Limit 240
_Display
Next
If start = 1 Then
start = 0: fini = 1: stepper = .02
If img& = imgRed& Then img& = imgGrn& Else img& = imgRed& ' flip colors on odd cycles
Else
start = 1: fini = 0: stepper = -.02
End If
Loop Until dcy > 2.50
_Delay 2
Wend
Sub RotoZoom23d (centerX As Long, centerY As Long, Image As Long, xScale As Single, yScale As Single, DRotation As Single)
Dim As Single px(3), py(3), sinr, cosr ' thanks to James D Jarvis who fixed this on 2023/01/18
Dim As Long IW, IH, i, x2, y2
IW& = _Width(Image&): IH& = _Height(Image&)
px(0) = -IW& / 2 * xScale: py(0) = -IH& / 2 * yScale: px(1) = -IW& / 2 * xScale: py(1) = IH& / 2 * yScale
px(2) = IW& / 2 * xScale: py(2) = IH& / 2 * yScale: px(3) = IW& / 2 * xScale: py(3) = -IH& / 2 * yScale
sinr! = Sin(-0.01745329 * DRotation): cosr! = Cos(-0.01745329 * DRotation)
For i& = 0 To 3
' x2& = (px(i&) * cosr! + sinr! * py(i&)) * xScale + centerX: y2& = (py(i&) * cosr! - px(i&) * sinr!) * yScale + centerY
x2& = (px(i&) * cosr! + sinr! * py(i&)) + centerX: y2& = (py(i&) * cosr! - px(i&) * sinr!) + centerY
px(i&) = x2&: py(i&) = y2&
Next
' might not need Seamless?
_MapTriangle _Seamless(0, 0)-(0, IH& - 1)-(IW& - 1, IH& - 1), Image& To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
_MapTriangle _Seamless(0, 0)-(IW& - 1, 0)-(IW& - 1, IH& - 1), Image& To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End Sub
Sub FC3 (cx, cy, r, clr~&) ' no suffix punctuation use the Global Default Type as Long or Single or Double
Dim r2, x, y ' for Option _Explicit
If r < 1 Then Exit Sub
Line (cx - r, cy)-(cx + r, cy), clr~&, BF
r2 = r * r
Do
y = y + 1
x = Sqr(r2 - y * y)
Line (cx - x, cy + y)-(cx + x, cy + y), clr~&, BF
Line (cx - x, cy - y)-(cx + x, cy - y), clr~&, BF
Loop Until y = r
End Sub
