| Welcome, Guest |
You have to register before you can post on our site.
|
|
|
| Cube Game from scratch |
|
Posted by: bplus - 10-18-2023, 02:12 AM - Forum: Programs
- Replies (2)
|
 |
Before I saw the correct version of Cube from Morristown I thought the game would benefit from a mapping display for "You are here." But the way input was setup with Morristown code it was clear where you've been and where you could go next. Anyway here is my version made from scratch.
Oh a couple of mods to game:
1. to make input as easy and simple as possible you only enter one letter for your move
2. that one letter increases player one step on x, y or z plane
3. Wager is out but when you succeed to 3,3,3 you earn 1000 first time and are offered the opportunity to play again to double your money or lose it all and end game.
Code: (Select All) Option _Explicit ' best practice
DefLng A-Z ' all numbers are integers
Randomize Timer ' for different mining at start
_Title "Cube From Scratch" ' bplus 2023-10-17
' a demo of developing code from a commented text of code specs
' try standard demo screen for QB64
Const Xmax = 800, Ymax = 600 ' screen width and height
Screen _NewImage(Xmax, Ymax, 12) ' 12 is 16 color old QB system
_ScreenMove 240, 80
' Define all Shared variables here with caps
' So to do this game called Cube from scratch you need a Cube array (x, y, z)
' where each x, y, or z is a number from 1 to 3
Dim Shared Cube(1 To 3, 1 To 3, 1 To 3)
Dim Shared Px, Py, Pz ' players position
Dim Shared MoneyUnits ' points from success(es?)
Dim Shared GameOver ' player stepped on Mine flag
Dim Shared GameWin ' player made it to 3,3,3
Intro
Do ' how many times can you make it to 3,3,3 and double your money?
InitGame
Do ' game round
DisplayCube 0 ' display cube but not the mines
HandleRound ' <<< game ends in here
If GameWin Then Exit Do
_Limit 30
Loop
Loop
Sub DisplayCube (showMines) ' flags both GameOver and GameWin
Dim x, y, z, zz, yy, xx, rn
Cls
' 3 grids one for each z level
' x ascends going right
' y ascends going down
' z ascends going right
_PrintString (179, 170), "z = 1"
drawGrid 150, 50, 50, 50, 2, 2
_PrintString (379, 170), "z = 2"
drawGrid 350, 50, 50, 50, 2, 2
_PrintString (579, 170), "z = 3"
drawGrid 550, 50, 50, 50, 2, 2
For z = 1 To 3
zz = 150 + 200 * (z - 1)
For y = 1 To 3
yy = 50 + 50 * (y - 1)
For x = 1 To 3
xx = zz + 50 * (x - 1)
If Px = x And Py = y And Pz = z Then ' draw player
For rn = 0 To 6
Circle (xx, yy), rn, 9
Next
If Px = 3 And Py = 3 And Pz = 3 Then GameWin = -1 'celebrate!
End If
If Cube(x, y, z) Then ' a mine is here
If showMines Then
For rn = 1 To 10 Step 2
Circle (xx, yy), rn, 12
Next
End If
If Px = x And Py = y And Pz = z Then GameOver = -1 'doomed
End If
Next
Next
Next
End Sub
Sub HandleRound
Dim ok$, plane$
If GameOver Then ' Round ender
DisplayCube -1 ' show where mines were
Beep
Color 14
yCP 23, "BOOM!"
yCP 25, "Player you stepped on a mine."
yCP 27, "Game Over!"
Sleep
End
ElseIf GameWin Then ' Round ender
' made it! award 1000 or double money and offer to double it
DisplayCube -1 ' show where mines were
If MoneyUnits Then MoneyUnits = 2 * MoneyUnits Else MoneyUnits = 1000
yCP 12, "You have earned" + Str$(MoneyUnits)
yCP 14, "Do you want to play again for chance to double your money?"
yCP 16, "Just press y + enter or just enter for yes, any other + enter = quit."
Locate 23, 50: Input ok$
If ok$ = "" Or ok$ = "y" Then Else End
Else ' still going round get next move, get player move
Locate 20, 32
Input "Enter x, y, or z for the next step "; plane$
plane$ = LCase$(plane$)
If Px < 3 And plane$ = "x" Then
Px = Px + 1
ElseIf Py < 3 And plane$ = "y" Then
Py = Py + 1
ElseIf Pz < 3 And plane$ = "z" Then
Pz = Pz + 1
End If
End If
End Sub
Sub Intro ' Start with clear description of the Game as Intro:
Dim ok$
yCP 5, "*** Cube from scratch ***"
yCP 6, "bplus 2023-10-17"
yCP 10, "You, the player, are starting at position 1,1,1 on wire frame cube 3x3x3"
yCP 11, "and your objective is to reach 3,3,3 in single step moves."
yCP 12, "You move on x, y, or z planes by 1 step forward no side or back stepping."
yCP 14, "A Miner has preceeded you from 1,1,1 to 3,3,3 and laid mines down his path."
yCP 16, "If you step on a mine, BOOM Game Over, so sorry this is a stupid game of pure luck!"
yCP 18, "If you make it to 3,3,3 you will be awarded 1000 money units PLUS"
yCP 19, "you will be offered opportunity to double your money units and play again."
yCP 22, "Press enter to play, any other + enter quits..."
Locate 30, 50: Input ; ok$
If ok$ <> "" Then System
End Sub
Sub InitGame ' Reset variables and mine cube
Dim mx, my, mz ' Minor's position
Dim rn ' random number
Erase Cube
Px = 1: Py = 1: Pz = 1
mx = 1: my = 1: mz = 1
GameWin = 0
' Mine the cube by making one path from start to goal
' So where cube(x,y,z) = 0 it is safe for player to go ie move into.
While mx <> 3 Or my <> 3 Or mz <> 3
rn = rndI&(1, 3)
If rn = 1 Then
If mx < 3 Then
mx = mx + 1
ElseIf my < 3 Then
my = my + 1
Else
mz = mz + 1
End If
ElseIf rn = 2 Then
If my < 3 Then
my = my + 1
ElseIf mz < 3 Then
mz = mz + 1
Else
mx = mx + 1
End If
Else
If mz < 3 Then
mz = mz + 1
ElseIf mx < 3 Then
mx = mx + 1
Else
my = my + 1
End If
End If
If mx = 3 And my = 3 And mz = 3 Then Else Cube(mx, my, mz) = 1 ' mined
Wend
End Sub
Sub yCP (RowNum&, s$) ' for graphics screen Center Print rowNum * 20 per row = y
_PrintString ((_Width - _PrintWidth(s$)) / 2, RowNum& * 20), s$
End Sub
Function rndI& (n1 As Long, n2 As Long) 'return an integer between 2 numbers
Dim As Long l, h
If n1 > n2 Then l = n2: h = n1 Else l = n1: h = n2
rndI& = Int(Rnd * (h - l + 1)) + l
End Function
Sub drawGrid (x, y, xs, ys, xn, yn) ' top left x, y, x side, y side, number of x, nmber of y
Dim As Long i, dx, dy
dx = xs * xn: dy = ys * yn
For i = 0 To xn
_PrintString (x + xs * i - 4, y - 24), _Trim$(Str$(i + 1))
Line (x + xs * i, y)-(x + xs * i, y + dy)
Next
For i = 0 To yn
_PrintString (x - 20, y + ys * i - 8), _Trim$(Str$(i + 1))
Line (x, y + ys * i)-(x + dx, y + ys * i)
Next
End Sub
|
|
|
| Ascii ClipDoodle (text screen art) |
|
Posted by: James D Jarvis - 10-16-2023, 09:40 PM - Forum: Works in Progress
- Replies (10)
|
 |
A multi-window program to draw ASCII-art.
The program consists of the main program and 2 other programs that must also be compiled for this to function properly.
sorry V0.2 for Windows only due to the clipboard use. V0.3 doesn't use the clipboard commands
Thanks to SMcNeil for the excellent text screen saving routines.
EDIT: V0.3 entries for all 3 programs are in a later post to this thread. Hopefully it will work on other systems.
![[Image: image.png]](https://i.ibb.co/R3kx1vz/image.png)
Code: (Select All)
'Ascii Clipdoodle V 0.2
'an ascii doodle pad that opens control panel apps in other windows
'
'sorry windows only
'
'loadtextimage and savetextimage from SMcNeil at https://qb64phoenix.com/forum/showthread.php?tid=2022
'
'pickclip.exe and colorpick16.exe must be compiled before this program will function properly
Dim Shared reflag
reflag = -1
Dim Shared helpscreen As Long
Dim Shared twd, tht
twd = 80: tht = 25
helpscreen = _NewImage(twd, tht, 0)
Dim Shared mainscreen As Long
mainscreen = _NewImage(80, 25, 0) 'default size text screen. feel free to change it.
Screen mainscreen
_Title "Ascii ClipDoodle"
Cls
_Clipboard$ = "ClipDoodleOn" ' "clears" clipboard for use
Shell _DontWait "pickclip.exe" ' Open the pickclip control panel
Shell _DontWait "colorpick16.exe" ' Open the colorpick16 control panel
_ControlChr Off
AK = 42
Do
_Limit 100
Do While _MouseInput 'mouse status changes only
_Limit 2000
x = _MouseX
y = _MouseY
px = _MouseX: py = _MouseY
If _MouseButton(1) Then
_PrintString (x, y), brush$
End If
Loop
kk$ = InKey$
Select Case kk$
Case "t", "T" 'type on current line with current color characteristics
_KeyClear
Do
Do
_Limit 60
tk$ = InKey$
Loop Until tk$ <> ""
If tk$ = Chr$(8) Then
tk$ = ""
px = px - 1
End If
If tk$ <> Chr$(13) And tk$ <> "" Then
_PrintString (px, py), tk$
px = px + 1
If px > _Width Then tk$ = Chr$(13) 'exit type input if attempting to type outside screen
End If
Loop Until tk$ = Chr$(13)
Case "S" 'save text screen
filef = 0
file$ = _SaveFileDialog$("Save File", "", "*.SAV", "SAved text screen")
If file$ <> "" Then
filef = 1
_MessageBox "Information", "File will be saved to " + file$
End If
If filef = 1 Then
SaveTextImage 0, file$
_MessageBox "Image SAved", "Text Images SAVED to " + file$
End If
filef = 0
Case "L", "O" 'load text screen
file$ = _OpenFileDialog$("Open File", "", "*.SAV", "SAVed text screen", -1)
If file$ <> "" Then
_MessageBox "Information", "You selected " + file$
'mainscreen = LoadTextImage(file$)
Screen LoadTextImage(file$)
tht = _Height
twid = _Width
End If
Case "C" 'clear screen
cc = _MessageBox("CLEAR SCREEN", "Are you sure you want to clear the screen? The image will be lost if it has not been saved. ", "yesnocancel", "warning", 0)
If cc = 1 Then Cls
Case Chr$(27)
cc = _MessageBox("QUIT !", "Are you sure you wish to QUIT? The image will be lost if it has not been saved. ", "yesnocancel", "warning", 0)
If cc = 1 Then Else kk$ = ""
Case "R"
do_resize
Case "?" 'help
do_help
End Select
ik$ = _Clipboard$
If Left$(ik$, 2) = "AC" Then AK = Val(Right$(ik$, Len(ik$) - 2))
If Left$(ik$, 2) = "CK" Then
ff$ = " "
n = 2
Do
n = n + 1
A$ = Mid$(ik$, n, 1)
If A$ <> "/" Then ff$ = ff$ + A$
Loop Until A$ = "/"
bb$ = ""
Do
A$ = Mid$(ik$, n, 1)
If A$ <> "/" Then bb$ = bb$ + A$
n = n + 1
Loop Until n > Len(ik$)
FG = Val(ff$): BG = Val(bb$)
Color FG, BG
End If
brush$ = Chr$(AK)
Loop Until kk$ = Chr$(27)
_Clipboard$ = "QUITCOLORPICK16"
Sleep 1
_Clipboard$ = "QUITCLIPPICK"
System
Sub do_help
ls& = _Dest
Screen helpscreen
Cls
Print "HELP"
Print "------------------"
Print "use mouse to draw with ascii characters"
Print "select character to draw and colors from control panels"
Print " "
Print "<ESC> to quit program"
Print "t,T - To type a line of text in colors picked"
Print
Print "S - To Save Screen"
Print "L,O - to Load Saved Screen"
Print "C - to clear screen"
print "R - to Resize Screen (WARNING : DESTRUCTIVE)"
Print
Print "press any key to continue"
Sleep
Screen ls&
End Sub
Sub do_resize
ls& = _Dest
Screen helpscreen
Cls
Print "Resize"
Print "------------------"
Print "Current size "
Print "width "; twd, "Height "; tht
Print "Enter new coordinates"
Input "Width "; twd
Input "Height"; tht
_FreeImage ls&
Screen _NewImage(twd, tht, 0)
End Sub
Function LoadTextImage& (SaveFile As String) 'create and load to a new Screen 0 screen with our saved image
Dim As Integer Wide, Tall, Flag: Wide = 80: Tall = 25: Flag = 0
Dim As String ImageData
Dim As _MEM M
f = FreeFile
Open SaveFile For Binary As #f
compress$ = Space$(LOF(f))
Get #f, 1, compress$
Close #f
temp$ = _Inflate$(compress$)
Flag = Asc(temp$, 1): p = 2
If Flag And 1 Then Wide = CVI(Mid$(temp$, p, 2)): p = p + 2
If Flag And 2 Then Tall = CVI(Mid$(temp$, p, 2)): p = p + 2
If Flag And 4 Then _Blink On Else _Blink Off
If Flag And 8 Then _Font Asc(temp$, p): p = p + 1
ImageData = Mid$(temp$, p)
TempImage = _NewImage(Wide, Tall, 0)
M = _MemImage(TempImage): _MemPut M, M.OFFSET, ImageData: _MemFree M
LoadTextImage = TempImage
End Function
Sub SaveTextImage (ImageHandle As Long, SaveFile As String)
Dim As Integer Wide, Tall, Flag
Dim As Long ImageSize
Dim As String ImageData
Dim As _MEM M
If _PixelSize(ImageHandle) <> 0 Then Error 5: Exit Sub 'only text images for this routine
M = _MemImage(ImageHandle)
Wide = _Width(ImageHandle): Tall = _Height(ImageHandle)
temp$ = "0" 'placeholder for our finalized image flag which holds custom information
If Wide <> 80 Then Flag = Flag + 1: temp$ = temp$ + MKI$(Wide)
If Tall <> 25 Then Flag = Flag + 2: temp$ = temp$ + MKI$(Tall)
If _Blink Then Flag = Flag + 4 'Set a flag saying that this image uses _Blink
Select Case _Font(ImageHandle)
Case 8: Flag = Flag + 8: temp$ = temp$ + Chr$(8)
Case 9: Flag = Flag + 8: temp$ = temp$ + Chr$(9)
Case 14: Flag = Flag + 8: temp$ = temp$ + Chr$(14)
Case 15: Flag = Flag + 8: temp$ = temp$ + Chr$(15)
Case 16 '16 needs no flag as it's the default for screen 0
Case 17: Flag = Flag + 8: temp$ = temp$ + Chr$(17)
Case Else
'To be added once we get a _MemFont to retrieve custom font data back from QB64PE
End Select
ImageSize = Wide * Tall * 2
ImageData = Space$(ImageSize): _MemGet M, M.OFFSET, ImageData: _MemFree M
temp$ = temp$ + ImageData
Mid$(temp$, 1) = Chr$(Flag) 'replace our placeholder with the proper value of the custom flag
compress$ = _Deflate$(temp$)
f = FreeFile
Open SaveFile For Output As #f: Close #f
Open SaveFile For Binary As #f: Put #f, 1, compress$: Close #f
End Sub
The color picker
Code: (Select All)
'colorpick16 0.2
'
'a color picker for mode 0 screens.
'compile as colorpick16.exe
'
Screen _NewImage(32, 8, 0)
_ScreenMove 600, 400
_Title "colorpick16"
blinkflag = -1
hflag = -1
FB = 0
BB = 0
print_picker FB, BB
Do
_Limit 100
Do While _MouseInput 'mouse status changes only
x = _MouseX
y = _MouseY
If _MouseButton(1) Then
If y >= 1 And y <= 2 Then
fk = (y - 1) * 8 + Int(x / 4) + FB
End If
Color fk, 0
If fk = 0 Then Color fk, 8
_PrintString (12, 4), " "
_PrintString (12, 4), Str$(fk)
If y = 7 Then
bk = Int(x / 4) + BB
End If
Color fk, bk
_PrintString (12, 5), " "
_PrintString (12, 5), Str$(bk)
_Clipboard$ = "CK" + _Trim$(Str$(fk)) + "/" + _Trim$(Str$(bk))
If x = 31 And y = 4 Then
blinkflag = blinkflag * -1
Select Case blinkflag
Case -1
FB = 0
BB = 0
print_picker FB, BB
Case 1
FB = 16
BB = 8
print_picker FB, BB
End Select
End If
End If
Loop
kk$ = InKey$
Select Case kk$
Case "B"
FB = 16
BB = 8
print_picker FB, BB
Case "b"
FB = 0
BB = 0
print_picker FB, BB
Case Chr$(27)
cc = _MessageBox("QUIT !", "Are you sure you wish to QUIT? The program will lose functionality. ", "yesnocancel", "warning", 0)
If cc = 1 Then cc = 1 Else kk$ = ""
End Select
ccheck$ = _Clipboard$
If ccheck$ = "QUITCOLORPICK16" Then kk$ = "QUITCOLORPICK16"
Loop Until kk$ = Chr$(27) Or kk$ = "QUITCOLORPICK16"
_Clipboard$ = "pickcolor quit"
System
Sub print_picker (f, b)
For y = 0 To 1
For x = 0 To 7
fk = y * 8 + x + f
p$ = "[ ]"
a$ = _Trim$(Str$(fk))
If Len(a$) = 1 Then
Mid$(p$, 3, 1) = a$
Else
Mid$(p$, 2, 2) = a$
End If
Color fk, 0
If fk = 0 Then Color 0, 7
_PrintString ((x + 1) * 4 - 3, y + 1), p$
Next
Next
_PrintString (31, 4), "B"
_PrintString (1, 4), "Foreground"
_PrintString (1, 5), "Background"
For x = 0 To 7
bk = x + b
p$ = "[ ]"
a$ = _Trim$(Str$(bk))
If bk < 8 Then Mid$(p$, 3, 1) = a$ Else Mid$(p$, 2, 2) = a$
Color 0, bk
If bk = 0 Then Color 15, 0
_PrintString ((x + 1) * 4 - 3, 7), p$
Next
fk = 15: bk = 0
End Sub
The ascii character picker.
Code: (Select All)
'colorpick16 0.2
'
'a color picker for mode 0 screens.
'compile as colorpick16.exe
'
Screen _NewImage(32, 8, 0)
_ScreenMove 600, 400
_Title "colorpick16"
blinkflag = -1
hflag = -1
FB = 0
BB = 0
print_picker FB, BB
Do
_Limit 100
Do While _MouseInput 'mouse status changes only
x = _MouseX
y = _MouseY
If _MouseButton(1) Then
If y >= 1 And y <= 2 Then
fk = (y - 1) * 8 + Int(x / 4) + FB
End If
Color fk, 0
If fk = 0 Then Color fk, 8
_PrintString (12, 4), " "
_PrintString (12, 4), Str$(fk)
If y = 7 Then
bk = Int(x / 4) + BB
End If
Color fk, bk
_PrintString (12, 5), " "
_PrintString (12, 5), Str$(bk)
_Clipboard$ = "CK" + _Trim$(Str$(fk)) + "/" + _Trim$(Str$(bk))
If x = 31 And y = 4 Then
blinkflag = blinkflag * -1
Select Case blinkflag
Case -1
FB = 0
BB = 0
print_picker FB, BB
Case 1
FB = 16
BB = 8
print_picker FB, BB
End Select
End If
End If
Loop
kk$ = InKey$
Select Case kk$
Case "B"
FB = 16
BB = 8
print_picker FB, BB
Case "b"
FB = 0
BB = 0
print_picker FB, BB
Case Chr$(27)
cc = _MessageBox("QUIT !", "Are you sure you wish to QUIT? The program will lose functionality. ", "yesnocancel", "warning", 0)
If cc = 1 Then cc = 1 Else kk$ = ""
End Select
ccheck$ = _Clipboard$
If ccheck$ = "QUITCOLORPICK16" Then kk$ = "QUITCOLORPICK16"
Loop Until kk$ = Chr$(27) Or kk$ = "QUITCOLORPICK16"
_Clipboard$ = "pickcolor quit"
System
Sub print_picker (f, b)
For y = 0 To 1
For x = 0 To 7
fk = y * 8 + x + f
p$ = "[ ]"
a$ = _Trim$(Str$(fk))
If Len(a$) = 1 Then
Mid$(p$, 3, 1) = a$
Else
Mid$(p$, 2, 2) = a$
End If
Color fk, 0
If fk = 0 Then Color 0, 7
_PrintString ((x + 1) * 4 - 3, y + 1), p$
Next
Next
_PrintString (31, 4), "B"
_PrintString (1, 4), "Foreground"
_PrintString (1, 5), "Background"
For x = 0 To 7
bk = x + b
p$ = "[ ]"
a$ = _Trim$(Str$(bk))
If bk < 8 Then Mid$(p$, 3, 1) = a$ Else Mid$(p$, 2, 2) = a$
Color 0, bk
If bk = 0 Then Color 15, 0
_PrintString ((x + 1) * 4 - 3, 7), p$
Next
fk = 15: bk = 0
End Sub
|
|
|
|
| Cube Game Question |
|
Posted by: bplus - 10-16-2023, 01:06 PM - Forum: General Discussion
- Replies (19)
|
|
From game by D.Ahl BASIC COMPUTER GAMES
Can someone explain this game to me? I've seen Davids Morristown version (Before QB) and now MG's QB64 update, I don't get what's going on.
I'd share QB64 code from another forum but might upset mnr's cohorts so I better not ;-))
I just wanna have fun!
|
|
|
|
| Everything Date |
|
Posted by: SMcNeill - 10-16-2023, 04:41 AM - Forum: SMcNeill
- Replies (3)
|
 |
I thought a few of you guys might have use for some of these inside your own works. (Note that these are all going into my toolbox project as well. I just thought I'd share them independent here for a preview of sorts for folks to enjoy.)
Code: (Select All)
Print "Is the date in proper format? The skies say "; CheckDayFormat(Date$)
Print "The Date = "; Date$
Print "Weekday = "; GetWeekDayName(Date$); ", which is day number"; GetWeekDay(Date$); "of the week."
Print "Day ="; GetDay(Date$)
Print "Month ="; GetMonth(Date$)
Print "Year ="; GetYear(Date$)
Print
Print "And to reverse the process we take those values and make them a date with :"; MakeDate(GetMonth(Date$), GetDay(Date$), GetYear(Date$))
Print
Print
Print
Print "And we can always fancify our date to universal formats: "
Print UniDate$("mm/dd/yyyy", Date$)
Print UniDate$("w, MM dd, YYYY", Date$)
Print UniDate$("W, MM DD, YYYY", Date$)
Print UniDate$("dd/mm/yyyy", Date$)
Print UniDate$("W, E D, YYYY", Date$)
Print UniDate$("mm-dd-yy", Date$)
Function CheckDayFormat (Day As String) 'use MM/DD/YYYY format
Dim As String DD, MM, YYYY, TD, TM, TY
If Len(Day$) <> 10 Then Glitch = -1
DD = Left$(Day, 2)
MM = Mid$(Day, 4, 2)
YYYY = Right$(Day, 4)
TD = Right$("00" + _Trim$(Str$(Val(DD))), 2)
TM = Right$("00" + _Trim$(Str$(Val(MM))), 2)
TY = Right$("0000" + _Trim$(Str$(Val(YYYY))), 4)
If TD <> DD Then Glitch = -1
If TM <> MM Then Glitch = -1
If TY <> YYYY Then Glitch = -1
If Glitch = 0 Then CheckDayFormat = -1
End Function
Function GetDay& (Day As String) 'use MM/DD/YYYY format
If CheckDayFormat(Day$) = 0 Then GetDay = 0: Exit Function
GetDay = Val(Mid$(Day, 4, 2))
End Function
Function GetMonth& (Day As String) 'use MM/DD/YYYY format
If CheckDayFormat(Day$) = 0 Then GetMonth = 0: Exit Function
GetMonth = Val(Left$(Day, 2))
End Function
Function GetYear& (Day As String) 'use MM/DD/YYYY format
If CheckDayFormat(Day$) = 0 Then GetYear = 0: Exit Function
GetYear = Val(Right$(Day, 4))
End Function
Function GetWeekDay& (Day$) 'use MM/DD/YYYY format
'From Zeller's congruence: https://en.wikipedia.org/wiki/Zeller%27s_congruence
If CheckDayFormat(Day$) = 0 Then GetWeekDay = 0: Exit Function
Dim As Long century, zerocentury, result
Dim As Long MM, DD, YYYY
MM = GetMonth(Day$): DD = GetDay(Day$): YYYY = GetYear(Day$)
If MM < 3 Then MM = MM + 12: YYYY = YYYY - 1
century = YYYY Mod 100
zerocentury = YYYY \ 100
result = (DD + Int(13 * (MM + 1) / 5) + century + Int(century / 4) + Int(zerocentury / 4) + 5 * zerocentury) Mod 7
If result = 0 Then result = 7
GetWeekDay& = result 'results are 1 to 7, from Sunday to Saturday
End Function
Function GetWeekDayName$ (Day$) 'use MM/DD/YYYY format
Dim result As Long
result = GetWeekDay(Day$)
Select Case result
Case 1: GetWeekDayName = "Sunday"
Case 2: GetWeekDayName = "Monday"
Case 3: GetWeekDayName = "Tuesday"
Case 4: GetWeekDayName = "Wednesday"
Case 5: GetWeekDayName = "Thursday"
Case 6: GetWeekDayName = "Friday"
Case 7: GetWeekDayName = "Saturday"
End Select
End Function
Function MakeDate$ (MM As _Unsigned Long, DD As _Unsigned Long, YYYY As _Unsigned Long)
Dim As String TD, TM, TY
TM = Right$("00" + _Trim$(Str$(MM)), 2)
TD = Right$("00" + _Trim$(Str$(DD)), 2)
TY = Right$("0000" + _Trim$(Str$(YYYY)), 4)
MakeDate = TM + "-" + TD + "-" + TY
End Function
Function UniDate$ (format$, userdate$)
'some basic documentation for formatting:
'dates sent via userdate$ should be in the standardized QB64 DATE$ format -- MM/DD/YYYY
'To customize your return date format, use the following syntax
'w = short weekday names. (Mon, Tue, Wed, Thu, Fri, Sat, Sun)
'W = long weekday names. (Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday)
'E = Extended month names. (January, February, March....)
'M = long month names. (Jan, Feb, Mar...)
'm = short month names. (01, 02, 03...)
'D = long day names. (01st, 02nd, 03rd...)
'd = short day names. (01, 02, 03...)
'Y or y (case insensitive) = year. Number of Yy present determines the number of digits we return.
' YY = 2-digit year
' YYYY = 4 digit year
' Y with any additional number of y's = 4 digit year by default, so a typo of YYYYY is the same as YYYY.
'Any other character is simply considered part of the desired output and faithfully carried over into the proper spot.
' For example, "mm/dd/yyyy" gives us "02/10/2023" for Feb 10th, 2023.
' Second example, "dd.mm.yyyy" gives us "10.02.2023" for the same date.
' Third example, "dd EE YYYY" gives us "02 February 2023" for that same date.
'Note: Extra digits of most of these codes are simply ignored for error proofing purposes, with only the initial code being accepted.
' For example "mM YYYY" is actually processed as a simple "m YYYY". The process won't mix short, long, or extended results.
' Also for example, "m YY" is the *exact* same as "mm YY".
' Feel free to use extra digits as you desire to help you keep track of positional spacing in your format string.
' Even though "M D, yyyy" may process the same as "MMM DDDD, YYYY", the second may work better for you if you're trying to track
' position of formatted objects. (The output would be "Feb 10th, 2023", and those extra characters help hold that
' positioning for us easily.)
'And, I think that's it. Enjoy, guys!
Dim As String temp, m, d, y, firstchar, Day
Dim out$
Dim As Long MonthSet, DaySet, WeekdaySet, result, YearSet, mm, dd, yyyy, century, zerocentury
temp$ = userdate$
If temp$ = "" Then temp$ = Date$
m$ = Left$(temp$, 2)
d$ = Mid$(temp$, 4, 2)
y$ = Right$(temp$, 4)
temp$ = format$
Do
firstchar$ = Left$(temp$, 1)
Select Case firstchar$
Case "E" 'extended month
temp$ = Mid$(temp$, 2)
If Not MonthSet Then
MonthSet = -1
Select Case Val(m$)
Case 1: out$ = out$ + "January"
Case 2: out$ = out$ + "February"
Case 3: out$ = out$ + "March"
Case 4: out$ = out$ + "April"
Case 5: out$ = out$ + "May"
Case 6: out$ = out$ + "June"
Case 7: out$ = out$ + "July"
Case 8: out$ = out$ + "August"
Case 9: out$ = out$ + "September"
Case 10: out$ = out$ + "October"
Case 11: out$ = out$ + "November"
Case 12: out$ = out$ + "December"
End Select
End If
Case "M" 'long month
temp$ = Mid$(temp$, 2)
If Not MonthSet Then
MonthSet = -1
Select Case Val(m$)
Case 1: out$ = out$ + "Jan"
Case 2: out$ = out$ + "Feb"
Case 3: out$ = out$ + "Mar"
Case 4: out$ = out$ + "Apr"
Case 5: out$ = out$ + "May"
Case 6: out$ = out$ + "Jun"
Case 7: out$ = out$ + "Jul"
Case 8: out$ = out$ + "Aug"
Case 9: out$ = out$ + "Sep"
Case 10: out$ = out$ + "Oct"
Case 11: out$ = out$ + "Nov"
Case 12: out$ = out$ + "Dec"
End Select
End If
Case "m" 'short month
temp$ = Mid$(temp$, 2)
If Not MonthSet Then
MonthSet = -1
Select Case Val(m$)
Case 1: out$ = out$ + "01"
Case 2: out$ = out$ + "02"
Case 3: out$ = out$ + "03"
Case 4: out$ = out$ + "04"
Case 5: out$ = out$ + "05"
Case 6: out$ = out$ + "06"
Case 7: out$ = out$ + "07"
Case 8: out$ = out$ + "08"
Case 9: out$ = out$ + "09"
Case 10: out$ = out$ + "10"
Case 11: out$ = out$ + "11"
Case 12: out$ = out$ + "12"
End Select
End If
Case "D" 'long day
temp$ = Mid$(temp$, 2)
If Not DaySet Then
DaySet = -1
out$ = out$ + Right$("00" + _Trim$(d$), 2)
Select Case Val(d$)
Case 1, 11, 21, 31: out$ = out$ + "st"
Case 2, 22: out$ = out$ + "nd"
Case 3, 23: out$ = out$ + "rd"
Case Else: out$ = out$ + "th"
End Select
End If
Case "d" 'short day
temp$ = Mid$(temp$, 2)
If Not DaySet Then
DaySet = -1
out$ = out$ + Right$("00" + _Trim$(d$), 2)
End If
Case "W" 'long weekday
temp$ = Mid$(temp$, 2)
If Not WeekdaySet Then
GoSub getday
Select Case result
Case 0: Day$ = "Saturday"
Case 1: Day$ = "Sunday"
Case 2: Day$ = "Monday"
Case 3: Day$ = "Tuesday"
Case 4: Day$ = "Wednesday"
Case 5: Day$ = "Thursday"
Case 6: Day$ = "Friday"
End Select
out$ = out$ + Day$
End If
Case "w" 'short weekday
temp$ = Mid$(temp$, 2)
If Not WeekdaySet Then
GoSub getday
Select Case result
Case 0: Day$ = "Sat"
Case 1: Day$ = "Sun"
Case 2: Day$ = "Mon"
Case 3: Day$ = "Tue"
Case 4: Day$ = "Wed"
Case 5: Day$ = "Thr"
Case 6: Day$ = "Fri"
End Select
out$ = out$ + Day$
End If
Case "Y", "y" 'year
If Not YearSet Then
YearSet = -1
If Left$(UCase$(temp$), 4) = "YYYY" Then
temp$ = Mid$(temp$, 5)
out$ = out$ + y$
ElseIf Left$(UCase$(temp$), 2) = "YY" Then
temp$ = Mid$(temp$, 3)
out$ = out$ + Right$(y$, 2)
Else
temp$ = Mid$(temp$, 2)
out$ = out$ + y$
End If
Else
temp$ = Mid$(temp$, 2)
End If
Case Else 'seperator
temp$ = Mid$(temp$, 2)
out$ = out$ + firstchar$
End Select
Loop Until temp$ = ""
UniDate$ = out$
Exit Function
getday:
WeekdaySet = -1
'From Zeller's congruence: https://en.wikipedia.org/wiki/Zeller%27s_congruence
mm = Val(m$): dd = Val(d$): yyyy = Val(y$)
If mm < 3 Then mm = mm + 12: yyyy = yyyy - 1
century = yyyy Mod 100
zerocentury = yyyy \ 100
result = (dd + Int(13 * (mm + 1) / 5) + century + Int(century / 4) + Int(zerocentury / 4) + 5 * zerocentury) Mod 7
Return
End Function
|
|
|
|
| MouseMovement Demo |
|
Posted by: SMcNeill - 10-15-2023, 11:42 PM - Forum: SMcNeill
- No Replies
|
|
Code: (Select All)
SCREEN _NEWIMAGE(1024, 720, 32)
arrow = _NEWIMAGE(75, 100, 32)
font = _LOADFONT("courbd.ttf", 100, "monospaced")
_DEST arrow
_FONT font
_CONTROLCHR ON
PRINT "";
_DEST 0
DO
WHILE _MOUSEINPUT
angle = angle + _MOUSEMOVEMENTX
WEND
CLS , 0
PRINT "Angle:"; angle
DisplayImage arrow, 512, 360, 3, 3, angle, 0
_LIMIT 15
_DISPLAY
LOOP UNTIL _MOUSEBUTTON(2)
SUB DisplayImage (Image AS LONG, x AS INTEGER, y AS INTEGER, xscale AS SINGLE, yscale AS SINGLE, angle AS SINGLE, mode AS _BYTE)
'Image is the image handle which we use to reference our image.
'x,y is the X/Y coordinates where we want the image to be at on the screen.
'angle is the angle which we wish to rotate the image.
'mode determines HOW we place the image at point X,Y.
'Mode 0 we center the image at point X,Y
'Mode 1 we place the Top Left corner of oour image at point X,Y
'Mode 2 is Bottom Left
'Mode 3 is Top Right
'Mode 4 is Bottom Right
DIM AS INTEGER px(3), py(3), w, h, w1, h1
DIM sinr AS SINGLE, cosr AS SINGLE, i AS _BYTE
w = _WIDTH(Image): h = _HEIGHT(Image)
w1 = w * xscale: h1 = h * yscale
SELECT CASE mode
CASE 0 'center
px(0) = -w1 / 2: py(0) = -h1 / 2: px(3) = w1 / 2: py(3) = -h1 / 2
px(1) = -w1 / 2: py(1) = h1 / 2: px(2) = w1 / 2: py(2) = h1 / 2
CASE 1 'top left
px(0) = 0: py(0) = 0: px(3) = w1: py(3) = 0
px(1) = 0: py(1) = h1: px(2) = w1: py(2) = h1
CASE 2 'bottom left
px(0) = 0: py(0) = -h1: px(3) = w1: py(3) = -h1
px(1) = 0: py(1) = 0: px(2) = w1: py(2) = 0
CASE 3 'top right
px(0) = -w1: py(0) = 0: px(3) = 0: py(3) = 0
px(1) = -w1: py(1) = h1: px(2) = 0: py(2) = h1
CASE 4 'bottom right
px(0) = -w1: py(0) = -h1: px(3) = 0: py(3) = -h1
px(1) = -w1: py(1) = 0: px(2) = 0: py(2) = 0
END SELECT
sinr = SIN(angle / 57.2957795131): cosr = COS(angle / 57.2957795131)
FOR i = 0 TO 3
x2 = (px(i) * cosr + sinr * py(i)) + x: y2 = (py(i) * cosr - px(i) * sinr) + y
px(i) = x2: py(i) = y2
NEXT
_MAPTRIANGLE (0, 0)-(0, h - 1)-(w - 1, h - 1), Image TO(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
_MAPTRIANGLE (0, 0)-(w - 1, 0)-(w - 1, h - 1), Image TO(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
END SUB
I think a lot of folks misunderstand what MouseMovementX and MouseMovementY are for.
First thing to note: They're NOT for tracking your mouse's absolute position on the screen. There's _MouseX and _MouseY for that.
So what are they for??
Let's move our thinking from QB64PE out to just playing some game. Now, in this game, you're in a spaceship flying through outer space. To control your ship, it's set up to use a simple scroll ball as the navigation tool.
Scroll that ball right, and the ship turns right.
Scroll that ball left, and the ship turns left.
Scroll that ball up, and the ship flys down. (The arse end goes up, the nose goes down.)
Scroll that ball down, and the ship flys up. (The arse end goes down, the nose goes up.)
Now, tracking mouse position in this situation is just foolish. You scroll right.... right... right.... right.... Hit the edge of the screen with the mouse, and BOOM!! Your ship can no longer rotate to the right in outer space!!
See the problem with trying to use _MouseX in this situation? You can turn right and go around in circles till the end of time. Your mouse cursor, however, is going to stop at the edge of your screen.
So, how to track this "ball rotated right" event?? _MouseMovementX. Even if the mouse is at the right edge of the screen, you can scroll that mouseball on your desk endlessly to the right. It won't move the mouse pointer -- it's already at the limit -- but _MouseMovementX will record that rotation and report it to you.
MouseMovementX simply tells you if your mouseball has rotated left or right.
MouseMovementY tells you if that mouseball has rotated up or down.
It has nothing to do with screen coordinates. Just mouse wheel scrolling itself. I hope the demo above helps to highlight what these commands are actually used for, for us. 
|
|
|
|
| Can _MOUSEMOVEMENTX & Y be used for something like this? |
|
Posted by: Dav - 10-15-2023, 11:17 PM - Forum: Help Me!
- Replies (4)
|
 |
I'm trying to grasp using_MOUSEMOVEMENTX & Y in a program, not sure I fully understand these two functions yet. I have run the wiki examples, but I'm not seeing how they could be used for something like below. Could those functions be used to easier compute mouse movement for like grabing an object and move it only for as much as the mouse has moved since clicking on it?
Here's some code I was playing with for testing. Could something like this be streamlined with _MOUSEMOVEMENTX & Y instead of using another DO/LOOP to calculate mouse movement?
- Dav
Code: (Select All)
Screen _NewImage(800, 600, 32)
cx = 400: cy = 400
Do
Cls , _RGB(32, 0, 0)
Locate 1, 1: Print "Click on and drag curves to shape...";
While _MouseInput: Wend
'grabbed screen
If _MouseButton(1) Then
startmx = _MouseX: startmy = _MouseY
'=====================================================
'Can _MOUSEMOVEMENTX/Y be used instead of below?
Do
Cls , _RGB(32, 0, 0)
While _MouseInput: Wend
newcx = cx + (_MouseX - startmx)
newcy = cy + (_MouseY - startmy)
For c = -300 To 300 Step 20
Curve 400, 100, 400, 500, newcx + c, newcy, _RGB(255, 0, 0)
Next
_Limit 30
_Display
Loop Until _MouseButton(1) = 0
cx = newcx: cy = newcy
'=====================================================
End If
For c = -300 To 300 Step 20
Curve 400, 100, 400, 500, cx + c, cy, _RGB(255, 0, 0)
Next
_Limit 30
_Display
Loop
Sub Curve (x1, y1, x2, y2, cx, cy, clr&)
'Draws a curved line using a quadratic bezier curve formula
'x1/y1 = start point
'x2/y2 = end point
'cx.cy = control point
Do While t <= 1
x = (1 - t) ^ 2 * x1 + 2 * (1 - t) * t * cx + t ^ 2 * x2
y = (1 - t) ^ 2 * y1 + 2 * (1 - t) * t * cy + t ^ 2 * y2
PSet (x, y), clr&
t = t + .001
Loop
End Sub
|
|
|
|
| Help a lazy developer! |
|
Posted by: SMcNeill - 10-15-2023, 08:14 PM - Forum: General Discussion
- Replies (22)
|
|
Terry posted an idea for improving QB64PE here: https://qb64phoenix.com/forum/showthread.php?tid=2075
Basically, his idea was simple -- Add an optional parameter to CLS so you don't have to change _DEST when using it.
And hey, let's be honest, that's a GREAT idea!! But, let's take it a step further: How many times have you wished you could just do a simple PSET (x, y), color, optional_imagehandle? Set a color of a pixel on an image, without having to alter source and dest to do so!
And how many other commands are there that could benefit from this type improvement? Off the top of my head, I can think of:
CLS ,background, imagehandle
PSET (x, y), color, imagehandle
LINE (x, y) - (x,y), color, BF, imagehandle
CIRCLE (though I'm too lazy to look up all its syntax), imagehandle
Now, here's my question for you guys, and here's where you can help with some easy development tasks: Give me a list of any and all other commands which could benefit from this simple optional parameter addition. A change like this won't affect existing code at all. Your old stuff won't break. All it'll do is allow a little more flexibility to be added to new stuff, and make it just a little simpler to code things in the future. And, honestly, making such changes is more or less a trivial matter which even someone like myself can push into the repo with just a few hours work and a couple lines of code.
Wrack your brain and help list what needs this style improvement. Heck, if you're brain damaged like me, yet have a ton of free time, pop over to the wiki and scroll down the command list and see what it seems like an optional parameter could help improve.
List those ideas here, and I'll see about taking a little free time this week and next weekend, and making the changes for us and push them into the repo for folks to enjoy in future versions of QB64PE. I'm getting older, and my eyes go all crosseyed and I fall asleep scrolling up and down lists of raw documentation anymore. You guys make me a list, and I'll make what changes I can. You won't get a better offer than that for $1.29 at your local McDonalds!
|
|
|
|
| Pixel life |
|
Posted by: James D Jarvis - 10-15-2023, 04:11 PM - Forum: Programs
- Replies (9)
|
|
An attempt to do Conways' game of life as two images without using defined arrays. Not sure it works right but it simulates working right. The overall program can surely be trimmed down. I posted this on a facebook group a couple weeks a go and figured.. heck why not post it here?
Code: (Select All)
'pixel_life
' an attmept to repilicate Conway's game of life without arrays by using 2 images
'not sure if I got it working right just yet
'feel free to fiddle with it, press <esc> to exit the program at any time
'there are multiple start states you can change by editing the comments
Dim Shared xmax, ymax
xmax = 400: ymax = 400 'change these as you wish , high numbers may be slow on older machines
Dim Shared s0 As Long
Dim Shared s1 As Long
Dim Shared klr As _Unsigned Long
s0 = _NewImage(xmax, ymax, 32)
s1 = _NewImage(xmax, ymax, 32)
Screen s0
_Title "Pixel Life <esc> to exit"
'_FullScreen
Randomize Timer
klr = _RGB32(30, 200, 0)
'use comments to change starting population of dots
'rand_gen0
test_genA
'test_genB
'test_mousepop
t = 0
rr = 0: gg = 80: bb = 0
Do
_Limit 6 'I want to be able to see the changes as the generations go on
gg = gg + 2
t = t + 1
_PutImage (0, 0), s1, s0
update_gen
Loop Until InKey$ = Chr$(27)
_Dest s0
Print t, " generations"
End
Sub test_genA
_Dest s1
Cls , _RGB32(0, 0, 0)
PSet (xmax \ 2, ymax \ 2 - 2), klr
PSet (xmax \ 2, ymax \ 2 - 1), klr
PSet (xmax \ 2, ymax \ 2), klr
PSet (xmax \ 2, ymax \ 2 + 1), klr
PSet (xmax \ 2, ymax \ 2 + 2), klr
PSet (xmax \ 2 + 1, ymax \ 2), klr
PSet (xmax \ 2 - 1, ymax \ 2), klr
End Sub
Sub test_genB
_Dest s1
Cls , _RGB32(0, 0, 0)
PSet (xmax \ 2, ymax \ 2), klr
PSet (xmax \ 2 + 1, ymax \ 2), klr
PSet (xmax \ 2 + 2, ymax \ 2 + 1), klr
PSet (xmax \ 2, ymax \ 2 + 2), klr
PSet (xmax \ 2 + 1, ymax \ 2 + 2), klr
PSet (xmax \ 2 + 2, ymax \ 2 + 2), klr
PSet (xmax \ 2 + 3, ymax \ 2 + 2), klr
End Sub
Sub test_mousepop
_Dest s1
Screen s1
Cls , _RGB32(0, 0, 0)
Do
' press space when done drawing
Do While _MouseInput
mx = _MouseX
my = _MouseY
If mx > 0 And mx < xmax And my > 0 And my < ymax Then
If _MouseButton(2) Then
PSet (mx, my), klr
End If
End If
Loop
Loop Until InKey$ = Chr$(32)
Screen s0
_Dest s0
End Sub
Sub rand_gen0
_Dest s1
Cls , _RGB32(0, 0, 0)
For y = 0 To ymax - 1
For x = 0 To xmax - 1
If Rnd * 30 < 2 Then PSet (x, y), klr
Next
Next
_Dest s0
End Sub
Sub update_gen
'change each generation
_Dest s1
Cls , _RGB32(0, 0, 0)
_Dest s0
For y = 0 To ymax - 1
For x = 0 To xmax - 1
update_cell x, y
Next
Next
End Sub
Sub update_cell (sx, sy)
'check each cell for neighbors and update life
_Source s0
_Dest s1
ds = -1 'set to -1 because we are going to count the cell itself and ignore it this way
If sx > 1 Then x0 = sx - 1 Else x0 = 0
If sy > 1 Then y0 = sy - 1 Else y0 = 0
If sx < xmax - 1 Then x1 = sx + 1 Else x1 = xmax - 1
If sy < ymax - 1 Then y1 = sy + 1 Else y1 = ymax - 1
For y = y0 To y1
For x = x0 To x1
If Point(x, y) <> _RGB32(0, 0, 0) Then ds = ds + 1
Next
Next
Select Case ds
Case 0, 1
PSet (sx, sy), _RGB32(0, 0, 0)
Case 2,3
PSet (sx, sy), klr
' Case 3 'yeah this was strange... keeping it here as comments for reasons
' If Point(sx, sy) = _RGB32(0, 0, 0) Then PSet (sx, sy), klr Else PSet (sx, sy), klr
Case Is > 3
PSet (sx, sy), _RGB32(0, 0, 0)
End Select
End Sub
|
|
|
|
| Is my Logic wrong or QB64's ? |
|
Posted by: bplus - 10-15-2023, 08:15 AM - Forum: Help Me!
- Replies (10)
|
|
I am doing a demo of setting up Conways Game of Life at other forum and run into a problem getting proper neighbor counts of a cell with this code:
Code: (Select All) nc = 0
For yy = y - 1 To y + 1
For xx = x - 1 To x + 1
If (xx <> x) And (yy <> y) Then 'dont count cell(x, y) the cell whose neighbors we are counting
If Cells(xx, yy) Then nc = nc + 1 ' : Beep ' debug OK
End If
Next
Next
If I rework that first IF line to this:
Code: (Select All) nc = 0
For yy = (y - 1) To (y + 1)
For xx = (x - 1) To (x + 1)
If xx = x And yy = y Then
'dont count cell(x, y) the cell whose neighbors we are counting
Else
If Cells(xx, yy) Then nc = nc + 1: Beep ' debug OK
End If
Next
Next
All is well! Fine I can get the code to work as expected with 2nd block but I am not understanding what is going wrong with the first code example?
A professional Basic coder (non QB64 fan) said the logic is correct, has QB64 another glitch?
BTW he showed a much better method to do count without IF.
If anyone a connoisseur of methods it was this:
Code: (Select All) nc = 0
For yy = y - 1 To y + 1
For xx = x - 1 To x + 1
nc = nc + Cells(xx, yy) ' no ifs
Next
Next
nc = nc - Cells(x, y)
As I recall my debug checks with the first block of code was messing up neighbor counts of live cells not that it should matter but with either -1 or 1 for live cell signal.
oh wait, I see it now, the logic is wrong because if I break the first IF line into 2 it becomes obvious why the counts were failing:
Code: (Select All) nc = 0
For yy = y - 1 To y + 1
For xx = x - 1 To x + 1
If (xx <> x) Then
If (yy <> y) Then
'dont count cell(x, y) the cell whose neighbors we are counting
If Cells(xx, yy) Then nc = nc + 1 ' : Beep ' debug OK
End If
End If
Next
Next
OK never mind, I got it now
|
|
|
|
|
