| Welcome, Guest |
You have to register before you can post on our site.
|
| Latest Threads |
The QB64 IDE shell
Forum: Utilities
Last Post: JasonPag
09-16-2024, 05:37 PM
» Replies: 9
» Views: 762
|
Importance regarding Ches...
Forum: Utilities
Last Post: JasonPag
09-01-2024, 06:34 PM
» Replies: 0
» Views: 31
|
Chess and Analysis and En...
Forum: Utilities
Last Post: JasonPag
08-28-2024, 02:37 PM
» Replies: 0
» Views: 32
|
DAY 009:_PutImage
Forum: Keyword of the Day!
Last Post: grymmjack
09-02-2023, 02:57 PM
» Replies: 54
» Views: 2,034
|
Fall Banner Contest?
Forum: Site Suggestions
Last Post: grymmjack
08-31-2023, 11:50 PM
» Replies: 36
» Views: 1,261
|
ColorPicker - Function th...
Forum: Dav
Last Post: Dav
08-31-2023, 11:04 PM
» Replies: 3
» Views: 315
|
Goals(1) = New Tile()
Forum: Works in Progress
Last Post: RhoSigma
08-31-2023, 09:45 PM
» Replies: 3
» Views: 127
|
micro(A)v11
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:14 PM
» Replies: 90
» Views: 3,589
|
Updating The Single Most ...
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:13 PM
» Replies: 7
» Views: 254
|
QBJS Image Question
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 05:49 PM
» Replies: 5
» Views: 155
|
|
|
| Spoilers |
|
Posted by: SMcNeill - 02-07-2023, 02:08 AM - Forum: Site Suggestions
- Replies (8)
|
 |
mnrv posted elsewhere about "It'd be nice if this site offered spoiler type code to hide stuff"... (Or similar as I didn't bother to find the exact quote. I'm lazy.)
We do!!
Show Content
SpoilerThis is a default spoiler
Show Content
You guys will never believe this! This is a spoiler with a custom highlight title!
And that's basically it for the two formats our spoiler command supports. Code to produce the above is in the code box below:
Code: (Select All) [spoiler]This is a default spoiler[/spoiler]
[spoiler=You guys will never believe this! ]This is a spoiler with a custom highlight title![/spoiler]
It's not part of the quick edit box buttons, but it *is* something we support. 
|
|
|
| JSON in QB64 |
|
Posted by: SpriggsySpriggs - 02-06-2023, 09:26 PM - Forum: General Discussion
- Replies (3)
|
 |
You all can mostly ignore this. I'm posting this so I don't lose it. However, I'll make a full post once I make it better.
Code: (Select All) Option Explicit
$NoPrefix
$Console:Only
Print GetEdiSchemaKey("$edi.transactionSets.heading.beginning_segment_for_ship_notice_BSN")
Function GetEdiSchemaKey$ (keyPath As String)
GetEdiSchemaKey = pipecom_lite("PowerShell -NoProfile $edi = (Get-Content -Path " + Chr$(34) + "C:\Users\zspriggs\Downloads\edi856.json" + Chr$(34) + " ^| ConvertFrom-Json);" + keyPath + " ^| ConvertTo-Json")
End Function
'$Include:'pipecomqb64.bas'
|
|
|
|
| Why does my Loop end after 11 Loops? |
|
Posted by: Dimster - 02-06-2023, 07:08 PM - Forum: Help Me!
- Replies (69)
|
 |
I have a file with over 28,000 data items. They are stored in the file in groups of 7. I have often OPENed this file, Inputed 7 items at a time and worked on each item before grabbing the next 7 data items.
The code goes
Open File
Do While Not EOF
For i = 1 to 7:Input DataItem(i): Next
Call Subroutine to work on these 7 data items
Loop
I have never had a problem looping thru the entire data file however recently I been working with Recursion and changed the routine to
Open File
Recur
Sub Recur
LoopRecur = LoopRecur + 1
Seek #1, 1
for i = 1 to 7:Input DataItem(i):Next
DataCount = DataCount + 7
Call Subroutine to work on these 7 data items
if DataCount < 4000 then Recur
End Sub
So I'm scratching my head when this recursive routine only performs 11 loops and the program just stops running. That number 11 brings to mind a possible un-dimensioned variable or perhaps a dynamic array that has gobbled up memory. I can't find anything like that in my program (which has thousands of lines of code so I could be missing it). On the other hand, could this recursive code simply be the culprit in memory munch whereas the original Do While did not munch memory?
|
|
|
|
| Limited Time Programs |
|
Posted by: SMcNeill - 02-05-2023, 09:44 PM - Forum: Utilities
- Replies (10)
|
|
Ever wanted to give someone a timed trial of your program? Let them download it, play around for a few days, and then pop up a nag screen telling them to buy your junk? Well, now you can!!
First the timestamper!
Code: (Select All) INPUT "File to stamp TimeStamp to =>"; file$
OPEN file$ FOR BINARY AS #1
filesize = LOF(1)
DIM TS AS _FLOAT
TS = TimeStamp(DATE$, TIMER)
PUT #1, filesize + 1, TS
t$ = "TS"
PUT #1, , t$
CLOSE #1
PRINT "TimeStamp Added"
SLEEP
SYSTEM
FUNCTION TimeStamp## (d$, t##) 'date and timer
'Based on Unix Epoch time, which starts at year 1970.
DIM l AS _INTEGER64, l1 AS _INTEGER64, m AS _INTEGER64
DIM d AS _INTEGER64, y AS _INTEGER64, i AS _INTEGER64
DIM s AS _FLOAT
l = INSTR(d$, "-")
l1 = INSTR(l + 1, d$, "-")
m = VAL(LEFT$(d$, l))
d = VAL(MID$(d$, l + 1))
y = VAL(MID$(d$, l1 + 1))
IF y < 1970 THEN 'calculate shit backwards
SELECT CASE m 'turn the day backwards for the month
CASE 1, 3, 5, 7, 8, 10, 12: d = 31 - d '31 days
CASE 2: d = 28 - d 'special 28 or 29.
CASE 4, 6, 9, 11: d = 30 - d '30 days
END SELECT
IF y MOD 4 = 0 AND m < 3 THEN 'check for normal leap year, and we're before it...
d = d + 1 'assume we had a leap year, subtract another day
IF y MOD 100 = 0 AND y MOD 400 <> 0 THEN d = d - 1 'not a leap year if year is divisible by 100 and not 400
END IF
'then count the months that passed after the current month
FOR i = m + 1 TO 12
SELECT CASE i
CASE 2: d = d + 28
CASE 3, 5, 7, 8, 10, 12: d = d + 31
CASE 4, 6, 9, 11: d = d + 30
END SELECT
NEXT
'we should now have the entered year calculated. Now lets add in for each year from this point to 1970
d = d + 365 * (1969 - y) '365 days per each standard year
FOR i = 1968 TO y + 1 STEP -4 'from 1968 onwards,backwards, skipping the current year (which we handled previously in the FOR loop)
d = d + 1 'subtract an extra day every leap year
IF (i MOD 100) = 0 AND (i MOD 400) <> 0 THEN d = d - 1 'but skipping every year divisible by 100, but not 400
NEXT
s## = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
TimeStamp## = -(s## + 24 * 60 * 60 - t##)
EXIT FUNCTION
ELSE
y = y - 1970
END IF
FOR i = 1 TO m 'for this year,
SELECT CASE i 'Add the number of days for each previous month passed
CASE 1: d = d 'January doestn't have any carry over days.
CASE 2, 4, 6, 8, 9, 11: d = d + 31
CASE 3 'Feb might be a leap year
IF (y MOD 4) = 2 THEN 'if this year is divisible by 4 (starting in 1972)
d = d + 29 'its a leap year
IF (y MOD 100) = 30 AND (y MOD 400) <> 30 THEN 'unless..
d = d - 1 'the year is divisible by 100, and not divisible by 400
END IF
ELSE 'year not divisible by 4, no worries
d = d + 28
END IF
CASE 5, 7, 10, 12: d = d + 30
END SELECT
NEXT
d = (d - 1) + 365 * y 'current month days passed + 365 days per each standard year
FOR i = 2 TO y - 1 STEP 4 'from 1972 onwards, skipping the current year (which we handled previously in the FOR loopp)
d = d + 1 'add an extra day every leap year
IF (i MOD 100) = 30 AND (i MOD 400) <> 30 THEN d = d - 1 'but skiping every year divisible by 100, but not 400
NEXT
s## = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
TimeStamp## = (s## + t##)
END FUNCTION
And, a program set up to showcase the basic workings of it:
Code: (Select All) TYPE SYSTIME
year AS INTEGER
month AS INTEGER
weekday AS INTEGER
day AS INTEGER
hour AS INTEGER
minute AS INTEGER
second AS INTEGER
millis AS INTEGER
END TYPE
DECLARE DYNAMIC LIBRARY "Kernel32"
SUB GetSystemTime (lpSystemTime AS SYSTIME)
SUB GetLocalTime (lpSystemTime AS SYSTIME)
END DECLARE
AppendTimeStamp
SUB AppendTimeStamp
DIM AS _FLOAT TS
f = FREEFILE
OPEN COMMAND$(0) FOR BINARY AS #f
FileSize = LOF(f)
check$ = " "
GET #f, FileSize - 1, check$
SELECT CASE UCASE$(check$)
CASE "VC" 'verified copy. All is good
PRINT "You have a paid copy of this software. All is good, kindly feel free to carry on with your existence, puny human."
CASE "TS" 'already has a timestamp, is a limited time test version. Toss NAG Screen.
GET #1, FileSize - 33, TS
PRINT "Original TimeStamp:"; TS
PRINT "Current TimeStamp: "; TimeStamp(DATE$, TIMER)
PRINT USING "This is a trial version of the program. You have been testing it for ###,####.#### seconds"; TimeStamp(DATE$, TIMER) - TS
CASE ELSE 'first run.
PRINT "Illegal copy of software! Terminating Now!"
SLEEP
SYSTEM
END SELECT
CLOSE #f
END SUB
FUNCTION TimeStamp## (d$, t##) 'date and timer
'Based on Unix Epoch time, which starts at year 1970.
DIM l AS _INTEGER64, l1 AS _INTEGER64, m AS _INTEGER64
DIM d AS _INTEGER64, y AS _INTEGER64, i AS _INTEGER64
DIM s AS _FLOAT
l = INSTR(d$, "-")
l1 = INSTR(l + 1, d$, "-")
m = VAL(LEFT$(d$, l))
d = VAL(MID$(d$, l + 1))
y = VAL(MID$(d$, l1 + 1))
IF y < 1970 THEN 'calculate shit backwards
SELECT CASE m 'turn the day backwards for the month
CASE 1, 3, 5, 7, 8, 10, 12: d = 31 - d '31 days
CASE 2: d = 28 - d 'special 28 or 29.
CASE 4, 6, 9, 11: d = 30 - d '30 days
END SELECT
IF y MOD 4 = 0 AND m < 3 THEN 'check for normal leap year, and we're before it...
d = d + 1 'assume we had a leap year, subtract another day
IF y MOD 100 = 0 AND y MOD 400 <> 0 THEN d = d - 1 'not a leap year if year is divisible by 100 and not 400
END IF
'then count the months that passed after the current month
FOR i = m + 1 TO 12
SELECT CASE i
CASE 2: d = d + 28
CASE 3, 5, 7, 8, 10, 12: d = d + 31
CASE 4, 6, 9, 11: d = d + 30
END SELECT
NEXT
'we should now have the entered year calculated. Now lets add in for each year from this point to 1970
d = d + 365 * (1969 - y) '365 days per each standard year
FOR i = 1968 TO y + 1 STEP -4 'from 1968 onwards,backwards, skipping the current year (which we handled previously in the FOR loop)
d = d + 1 'subtract an extra day every leap year
IF (i MOD 100) = 0 AND (i MOD 400) <> 0 THEN d = d - 1 'but skipping every year divisible by 100, but not 400
NEXT
s## = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
TimeStamp## = -(s## + 24 * 60 * 60 - t##)
EXIT FUNCTION
ELSE
y = y - 1970
END IF
FOR i = 1 TO m 'for this year,
SELECT CASE i 'Add the number of days for each previous month passed
CASE 1: d = d 'January doestn't have any carry over days.
CASE 2, 4, 6, 8, 9, 11: d = d + 31
CASE 3 'Feb might be a leap year
IF (y MOD 4) = 2 THEN 'if this year is divisible by 4 (starting in 1972)
d = d + 29 'its a leap year
IF (y MOD 100) = 30 AND (y MOD 400) <> 30 THEN 'unless..
d = d - 1 'the year is divisible by 100, and not divisible by 400
END IF
ELSE 'year not divisible by 4, no worries
d = d + 28
END IF
CASE 5, 7, 10, 12: d = d + 30
END SELECT
NEXT
d = (d - 1) + 365 * y 'current month days passed + 365 days per each standard year
FOR i = 2 TO y - 1 STEP 4 'from 1972 onwards, skipping the current year (which we handled previously in the FOR loopp)
d = d + 1 'add an extra day every leap year
IF (i MOD 100) = 30 AND (i MOD 400) <> 30 THEN d = d - 1 'but skiping every year divisible by 100, but not 400
NEXT
s## = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
TimeStamp## = (s## + t##)
END FUNCTION
So, to start with, run the second file first. It'll make an EXE for you and tell you that it's illegal! You're not allowed to use it. This is all someone that grabs your program out of the blue will see.
Now, if you want to send someone a timestamped trial version, run the first program and point it to your other program's compiled EXE. It'll stick a timestamp to the end of it for you, and now you can now run that EXE and have it make use of that timestamp however you want.
If they buy your junk, send (or change) the last 2 bytes of the EXE to "VC" for "Verified Copy", and they're good to go without any message for illegal downloading or nag screen to buy your stuff.
Screenshots follow:
|
|
|
|
| Blank Line Remover |
|
Posted by: bplus - 02-04-2023, 10:00 PM - Forum: Utilities
- No Replies
|
 |
Quick little code for Windows .bas code that got double spaced at a forum:
Code: (Select All) _Title "Blank Line Remover" ' b+ 2023-02-04
FixMe$ = _OpenFileDialog$("Select .bas file to remove blank lines from", _CWD$, "*.bas", "Basic files")
t$ = Mid$(FixMe$, 1, _InStrRev(FixMe$, "\")) + "temp.bas"
cancel& = _MessageBox("Check Names", "Fix file: " + FixMe$ + Chr$(10) + "Temp: " + t$, "okcancel", "question")
If cancel& = 1 Then
Open FixMe$ For Input As #1
Open t$ For Output As #2
While EOF(1) = 0
Line Input #1, fline$
If _Trim$(fline$) <> "" Then Print #2, fline$
Wend
Close
Kill FixMe$
Name t$ As FixMe$
Print "File converted."
End If
|
|
|
|
| Profile Pong Game Development |
|
Posted by: bplus - 02-04-2023, 08:30 PM - Forum: bplus
- Replies (12)
|
|
Ever since I saw Rosy's video at RCBasic (where I lurk) I have been meaning to do a version in QB64.
We all know the Classic Pong and this Perspective is very amusing, to me any way!
Rosy's video, just click into it about halfway through and watch until you get an idea how it should go...
https://www.youtube.com/watch?v=jfod2O5Oq7s
I thought I'd show the evolution of my version of development over last couple of days.
So here, my starter I just get started on images and some basic ball handling:
Code: (Select All) Option _Explicit
_Title "Profile Pong 0-1" ' b+ 2023-02-01 started inspired by Rosy game at RCBasic
Const Xmax = 1200, Ymax = 700, PaddleR = 30, BallR = 5, TableL = 100, TableR = 1100
Const TableY = Ymax - 80
Const NetY = TableY - 40
Const NetL = 598
Const NetR = 602
Const Gravity = .1
Const BallSpeed = 8
Dim Shared As Long Table, LPaddle, RPaddle ' images
Screen _NewImage(Xmax, Ymax, 32)
_ScreenMove 0, 0 ' <<<<<<< you may want different
Dim As Long mx, my, playerX, playerY, ballX, ballY, computerX, computerY, playerPt, computerPt, flagPt
Dim As Double ballDX, ballDY, a
makeTableImg
makeLeftPaddle
makeRightpaddle
computerX = 50
Do
flagPt = 0
ballY = 300: ballX = TableR - BallR: ballDX = .01
Do
_PutImage , Table, 0
_PrintString (100, 100), "Computer:" + Str$(computerPt)
_PrintString (1100 - _PrintWidth("Player:" + Str$(playerPt)), 100), "Player:" + Str$(playerPt)
' player is RPaddle
10 If _MouseInput Then GoTo 10
mx = _MouseX: my = _MouseY
If mx > NetR + PaddleR Then
If mx > 1100 + PaddleR Then
playerX = mx: playerY = my
Else
If my + PaddleR < TableY Then playerX = mx: playerY = my
End If
End If
_PutImage (playerX - PaddleR, playerY - PaddleR)-Step(PaddleR, 2 * PaddleR), RPaddle, 0
' computer opponent
computerY = ballY + 5
_PutImage (computerX, computerY - PaddleR)-Step(PaddleR, 2 * PaddleR), LPaddle, 0
' ball handling
ballDY = ballDY + Gravity
ballX = ballX + ballDX: ballY = ballY + ballDY
' collide player
If Sqr((ballX - playerX) ^ 2 + (ballY - playerY) ^ 2) < (BallR + PaddleR) And ballDX > 0 Then
a = _Atan2(ballY - playerY, ballX - playerX)
ballDX = BallSpeed * Cos(a)
ballDY = BallSpeed * Sin(a)
ballX = ballX + 2 * ballDX ' boost
ballY = ballY + 2 * ballDY
End If
' collide computer
If Sqr((ballX - computerX) ^ 2 + (ballY - computerY) ^ 2) < (BallR + PaddleR) And ballDX < 0 Then
a = _Atan2(ballY - computerY, ballX - computerX)
ballDX = BallSpeed * Cos(a)
ballDY = BallSpeed * Sin(a)
ballX = ballX + 2 * ballDX ' boost
ballY = ballY + 2 * ballDY
End If
' collide net
If ballY + BallR > NetY Then
If ballDX > 0 Then ' going towards player
If ballX > NetL - BallR And ballX < NetR + BallR Then ' collide
playerPt = playerPt + 1
flagPt = 1
fcirc ballX, ballY, BallR, &HFFFFFFFF
_Display
_Delay 1
End If
Else ' going towards computer
If ballX > NetL - BallR And ballX < NetR + BallR Then ' collide
computerPt = computerPt + 1
flagPt = 1
fcirc ballX, ballY, BallR, &HFFFFFFFF
_Display
_Delay 1
End If
End If
End If
' collide table
If ballY + BallR > TableY And ((ballX > TableL) Or (ballX < TableR)) Then
ballY = TableY - BallR
ballDY = -ballDY
End If
' collide floor
If ballY + BallR > Ymax Then
If ballX + BallR < TableL Then
playerPt = playerPt + 1
flagPt = 1
ElseIf ballX - BallR > TableR Then
computerPt = computerPt + 1
flagPt = 1
End If
End If
' collide left
If ballX - BallR < 0 Then
playerPt = playerPt + 1
flagPt = 1
ElseIf ballX + BallR > Xmax Then 'collide right
computerPt = computerPt + 1
flagPt = 1
End If
fcirc ballX, ballY, BallR, &HFFFFFFFF
_Display
_Limit 60
Loop Until flagPt
_Delay 1
If computerPt >= 21 Then
_MessageBox "Sorry,", "The Computer out did you this game."
computerPt = 0: playerPt = 0
ElseIf playerPt >= 21 Then
_MessageBox "Congrats!", "You beat the Computer."
computerPt = 0: playerPt = 0
End If
Loop
Sub makeLeftPaddle
LPaddle = _NewImage(PaddleR, 2 * PaddleR, 32)
_Dest LPaddle
fcirc -1, PaddleR, PaddleR, &HFFBB6600
_Dest 0
End Sub
Sub makeRightpaddle
RPaddle = _NewImage(PaddleR, 2 * PaddleR, 32)
_Dest RPaddle
fcirc PaddleR, PaddleR, PaddleR, &HFFFFAA00
_Dest 0
End Sub
Sub makeTableImg
Table = _NewImage(_Width, _Height, 32)
_Dest Table
Cls
Line (TableL, TableY)-(TableR, TableY + 20), &HFF008855, BF
Line (TableL + 40, TableY + 20)-(TableL + 50, _Height), &HFF444444, BF
Line (TableR - 50, TableY + 20)-(TableR - 40, _Height), &HFF444444, BF
Line (NetL, NetY)-(NetR, TableY), &HFF444444, BF
Line (NetL + 1, NetY)-(NetR - 1, NetY + 20), &HFFFFFFFF, BF
_Dest 0
End Sub
Sub fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
|
|
|
|
|
