Welcome, Guest
You have to register before you can post on our site.

Username/Email:
  

Password
  





Search Forums

(Advanced Search)

Forum Statistics
» Members: 494
» Latest member: johtopoz3021
» Forum threads: 2,840
» Forum posts: 26,603

Full Statistics

Latest Threads
Chr$(135) and _Keyhit
Forum: Help Me!
Last Post: DSMan195276
30 minutes ago
» Replies: 1
» Views: 10
Might not be able to be o...
Forum: Announcements
Last Post: Pete
5 hours ago
» Replies: 0
» Views: 13
Aloha from Maui guys.
Forum: General Discussion
Last Post: Pete
5 hours ago
» Replies: 13
» Views: 270
Fun with Ray Casting
Forum: a740g
Last Post: Bhsdfa
7 hours ago
» Replies: 1
» Views: 34
Box_Bash game
Forum: Works in Progress
Last Post: Pete
10 hours ago
» Replies: 2
» Views: 56
another variation of "10 ...
Forum: Programs
Last Post: bplus
11 hours ago
» Replies: 20
» Views: 295
Next small EQ step - EQ D...
Forum: Petr
Last Post: Petr
Yesterday, 07:43 PM
» Replies: 10
» Views: 561
1990's 3D Doom-Like Walls...
Forum: Programs
Last Post: a740g
01-11-2025, 09:31 PM
» Replies: 5
» Views: 188
Sound Effects Generator (...
Forum: Petr
Last Post: a740g
01-11-2025, 09:05 PM
» Replies: 1
» Views: 68
_SndRaw and _MemFree
Forum: General Discussion
Last Post: a740g
01-11-2025, 09:04 PM
» Replies: 1
» Views: 56

 
  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:

   

   

   

Print this item

  Bouncing Scatter Circles
Posted by: CharlieJV - 02-05-2023, 07:41 PM - Forum: QBJS, BAM, and Other BASICs - No Replies

https://basicanywheremachine.neocities.o...tercircles

Scroll down the page to see source code.

Print this item

  Seek
Posted by: Dimster - 02-05-2023, 02:51 PM - Forum: Site Suggestions - Replies (3)

Wonder if SEEK function and statement might be a Word of the Day candidate?

Print this item

  QB64 Galaga
Posted by: RokCoder - 02-04-2023, 10:06 PM - Forum: Games - Replies (3)

I may have jumped into the deep end with my second QB64 project but it's been quite an interesting journey!

This is as close to the original arcade version of Galaga as I'm likely to get. There are a few little bits missing - I've implemented the first four challenge stages but can't find video recording of the latter four so haven't been able to reproduce them; I also haven't added the Transforms (Scorpions, Spy Ships and Flag Ships) that turn up on the later levels yet. I'll come back to those bits at a later time if I can get decent video footage to base them on.

The ZIP file contains galaga.bas along with a subfolder called assets which contains all the sound effects, graphics, etc. After building the project, the EXE must reside in the same folder as the BAS file. It accesses the assets folder relatively so won't find it if the EXE is in the wrong place.

Other than the few missing features, I'd also like to work out how I can allow the window to be maximised and not lose a large portion of the game off the top and bottom of the screen. Going full screen via Alt+Enter is fine but maximising the window... not so much. Also, I haven't tested on anything other than Windows 10 yet. I think this version can be considered a beta release as I'm sure there are bugs yet to surface!

EDIT: Definitely beta! Bugs found since sharing -

  • No stars displayed during back-end game stats display
  • Scores and hi-scores turning negative
  • When hi-score updates during game it is overwriting previous hi-score without erasing it
  • Dying just before challenge stage resulted in READY and CHALLENGE STAGE overwriting each other
  • In the fourth challenge stage, tractor beams keep appearing!
  • If you get the hi-score, the music from the leader-board continues to play after leaving the hi-score entry board
Please feel free to report bugs in this thread or as issues in GitHub

Anyway, that's enough rambling. Hope you have fun!

.zip   galaga.zip (Size: 769 KB / Downloads: 106)

       

Print this item

  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

Print this item

  Profile Pong Game Development
Posted by: bplus - 02-04-2023, 08:30 PM - Forum: bplus - Replies (29)

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

   

Print this item

  Anyone know how frostbite thresholds are calculated?
Posted by: SMcNeill - 02-04-2023, 08:46 AM - Forum: Help Me! - Replies (13)

Something small I was working on to go with my home weather system:

Code: (Select All)
SCREEN _NEWIMAGE(800, 600, 32)
$COLOR:32
PRINT "  ";
count = 1
FOR temp = 40 TO -45 STEP -5
    LOCATE , 4 * count
    PRINT temp;
    count = count + 1
NEXT
PRINT


FOR windspeed = 5 TO 60 STEP 5
    COLOR White, Black
    PRINT windspeed;
    COLOR Black, SkyBlue
    count = 1
    FOR temp = 40 TO -45 STEP -5
        wc& = WindChill(temp, windspeed)
        LOCATE , 4 * count
        count = count + 1
        SELECT CASE wc&
            CASE IS > -18: COLOR Black, LightBlue
            CASE IS > -32: COLOR White, SkyBlue
            CASE IS > -48: COLOR White, Blue
            CASE ELSE: COLOR White, Purple
        END SELECT

        PRINT wc&; " ";
    NEXT
    PRINT
NEXT

COLOR White, Black


FUNCTION WindChill& (temp AS _FLOAT, windspeed AS _FLOAT)
    WindChill = 35.74 + 0.6215 * temp - 35.75 * windspeed ^ 0.16 + 0.427 * temp * windspeed ^ 0.16
END FUNCTION


Now, as you can see, my chart matches the values from the chart here: WindChill (weather.gov)


[Image: image.png]

Only issue is my color values don't match.  Anyone know why -62 windchills are light blue at the top of the chart, but then are purple at the bottom?  If the implied temperature is -52 in both cases, shouldn't frostbite occur at the same time?  Isn't that basically what windchill is for -- to give an equal representation of what the temperature would feel like it the wind wasn't blowing?

How's that frostbite time calculated?  Anyone have a clue, just so I can get my color scheme to match?

Print this item

  Where's Pete?
Posted by: bplus - 02-03-2023, 12:28 AM - Forum: Programs - Replies (3)

Code: (Select All)
'Option _Explicit
_Title "Signal" 'b+ 2023-01-23
Randomize Timer
Screen _NewImage(800, 600, 32)
Dim As Long d, spot, back, i, x, y, w, h, r, mx, my
Dim dx, dy
d = _LoadFont("ARIALBD.ttf", 64) ' <<<<  easy for Windows probably no one else sorry

spot = _NewImage(200, 200, 32)
_Dest spot
_Font d
_PrintMode _KeepBackground
Color _RGB32(0, 0, 0, 60)
_PrintString ((200 - _PrintWidth("Pete")) / 2, (200 - _FontHeight(d)) / 2 + 10), "Pete"
_Dest 0

back = _NewImage(800, 600, 32)
_Dest back
For y = 0 To 600
    Line (0, y)-(800, y), _RGB32(50, 0, y / 600 * 128)
Next
For i = 1 To 20
    w = Rnd * 100 + 30: y = Rnd * 200 + 400: x = Rnd * (800 - w)
    Line (x, y)-(x + w, 600), &HFF000000, BF
Next
Line (0, 550)-(800, 600), &HFF000000, BF
_Dest 0
r = 100
Do
    _PutImage , back, 0
    10 If _MouseInput Then GoTo 10
    mx = _MouseX: my = _MouseY
    For i = r To 0 Step -1
        fcirc mx, my, i, _RGB32(255, 255, 255, 1)
    Next
    h = ((mx + 10) ^ 2 + (my - 550) ^ 2) ^ .5
    dx = (mx + 10) / h: dy = (my - 550) / h
    For i = 0 To h Step 2
        fcirc -10 + i * dx, 550 + i * dy, i / h * 100, _RGB32(255, 255, 255, 1)
    Next
    _PutImage (mx - 100, my - 100), spot, 0
    _Display
    _Limit 30
Loop Until _KeyDown(27)

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
    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
                Line (CX - Y, CY + X)-(CX + Y, CY + X), C
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        Line (CX - X, CY - Y)-(CX + X, CY - Y), C
        Line (CX - X, CY + Y)-(CX + X, CY + Y), C
    Wend
End Sub

Print this item

  Exit Sub from inner loop?
Posted by: PhilOfPerth - 02-02-2023, 09:32 AM - Forum: Help Me! - Replies (9)

Is it "safe" to exit  a subroutine while in a While/Wend loop inside the Sub, or does this cause problems with things like the Stack or "memory leak" etc?  Undecided

Print this item

  a simple Palette Builder
Posted by: James D Jarvis - 02-01-2023, 04:42 PM - Forum: Programs - Replies (7)

Needed a palette editor for another 256 color mode program screen so I wrote this program.  This makes use of dialog commands, the mouse, and simple keyboard commands.  Loads and save the palette files as a simple data file. Also saves out the palette as lines of basic code.   

EDIT: added commands to copy and paste individual colors cells.

Code: (Select All)
'Palette_Builder
'by James D. Jarvis , Feb 2/1/2023
'
'a simple 256 color palette builder for QB64 PE
' saves and loads simple palette data files or basic source code to build a palette
Dim klr(0 To 255) As _Unsigned Long
Dim tklr As _Unsigned Long
Screen _NewImage(1100, 400, 256)
_Title "Palette_Builder"
Dim Shared showpalnos
showpalnos = 0
klr(0) = _RGB32(0, 0, 0)
klr(1) = _RGB32(0, 0, 255)
klr(2) = _RGB32(0, 128, 0)
klr(3) = _RGB32(0, 217, 217)
klr(4) = _RGB32(255, 0, 0)
klr(5) = _RGB32(193, 0, 193)
klr(6) = _RGB32(149, 5, 5)
klr(7) = _RGB32(192, 192, 192)
klr(8) = _RGB32(100, 100, 100)
klr(9) = _RGB32(0, 128, 255)
klr(10) = _RGB32(128, 255, 128)
klr(11) = _RGB32(128, 255, 255)
klr(12) = _RGB32(255, 128, 0)
klr(13) = _RGB32(255, 128, 255)
klr(14) = _RGB32(255, 255, 128)
klr(15) = _RGB32(250, 250, 250)
klr(255) = _RGB32(250, 250, 250)
For k = 16 To 254
    klr(k) = _RGB32(k, Int(k * .8), Int(k * .4))
Next k
klr(101) = _RGB32(100, 100, 100)
For k = 16 To 255
    _PaletteColor k, klr(k)
Next k
Color 255, 0
drawgrid

Do
    _Limit 500
    kk$ = InKey$
    Mouser mx, my, mb
    If mb = -1 And lb = 0 Then 'open color dialog on left button mouse click over grid position for color
        If mx > -1 And mx < 1024 And my > -1 And my < 256 Then
            px = mx \ 32
            py = my \ 32
            pk = py * 32 + px
            Line (10, 310)-(800, 340), klr(0), BF
            pm$ = "Color #: " + Str$(pk) + " R,G,B: " + Str$(_Red32(klr(pk))) + "," + Str$(_Green32(klr(pk))) + "," + Str$(_Blue32(klr(pk)))
            _PrintString (10, 312), pm$
        End If
    End If
    If mb = 0 And lb = -2 Then 'open color dialog on right button mouse release over grid position for color
        If mx > -1 And mx < 1024 And my > -1 And my < 256 Then
            px = mx \ 32
            py = my \ 32
            pk = py * 32 + px
            If pk > -1 And pk < 256 Then
                klr(pk) = _ColorChooserDialog("Choose Color", _RGB32(_Red32(klr(pk)), _Green32(klr(pk)), _Blue32(klr(pk))))
                _PaletteColor pk, klr(pk)
            End If
        End If
    End If
    lb = mb 'record mouse button just clicked as last button clicked
    Select Case kk$
        Case "s", "S" 'save palette
            savefile$ = _SaveFileDialog$("Save File", "", "*.*", "")
            If savefile$ <> "" Then
                _MessageBox "Information", "File will be saved to " + savefile$
                Open savefile$ For Output As #1
                For k = 0 To 255
                    Print #1, klr(k)
                Next k
                Close #1
            End If
        Case "l", "L" 'load palette
            loadfile$ = _OpenFileDialog$("Open File", "", "*.*", "*.*", -1)
            If loadfile$ <> "" Then
                _MessageBox "Information", "You selected " + loadfile$
                k = 0
                Open loadfile$ For Input As #1
                Do Until EOF(1)
                    Input #1, klr(k)
                    _PaletteColor k, klr(k)
                    k = k + 1
                Loop
                Close #1
                drawgrid
            End If
        Case "b", "B" 'save basic code for palette to a file
            savefile$ = _SaveFileDialog$("Save Basic Code to File", "", "*.*", "")
            If savefile$ <> "" Then
                _MessageBox "Information", "File will be saved to " + savefile$
                Open savefile$ For Output As #1
                Print #1, "'256 color palette uncomment lines as needed for use"
                Print #1, "'Screen _NewImage(600, 400,256) "
                Print #1, "'dim shared klr(0 to 255) as _unsigned long"
                For k = 0 To 255
                    bc$ = ""
                    bc$ = "klr(" + _Trim$(Str$(k)) + ") = _rgb32(" + _Trim$(Str$(_Red32(klr(k)))) + "," + _Trim$(Str$(_Green32(klr(k)))) + "," + _Trim$(Str$(_Blue32(klr(k)))) + ")"
                    Print #1, bc$
                Next k
                Print #1, "'For k = 0 To 255 "
                Print #1, "' _PaletteColor k, klr(k) "
                Print #1, "' Next k"
                Close #1
            End If
        Case "n", "N" 'toggle display of color numbers on palette grid
            If showpalnos = 0 Then showpalnos = 1 Else showpalnos = 0
            drawgrid
        Case "c", "C"
            Mouser mx, my, mb
            If mx > -1 And mx < 1024 And my > -1 And my < 256 Then
                px = mx \ 32
                py = my \ 32
                pk = py * 32 + px
                Line (10, 310)-(800, 340), klr(0), BF
                pm$ = "Color #: " + Str$(pk) + " R,G,B: " + Str$(_Red32(klr(pk))) + "," + Str$(_Green32(klr(pk))) + "," + Str$(_Blue32(klr(pk)))
                _PrintString (10, 312), pm$
                If pk > 0 And pk < 256 Then tklr = klr(pk)
            End If
        Case "p", "P"
            Mouser mx, my, mb
            If mx > -1 And mx < 1024 And my > -1 And my < 256 Then
                px = mx \ 32
                py = my \ 32
                pk = py * 32 + px
                If pk > 0 And pk < 256 Then klr(pk) = tklr
                _PaletteColor pk, klr(pk)
            End If


    End Select
Loop Until kk$ = Chr$(27)
System

'draw the palette grid
Sub drawgrid
    _PrintMode _KeepBackground
    For y = 0 To 7
        For x = 0 To 31
            yy = y * 32
            xx = x * 16
            dk = yy + x
            xx = xx * 2
            Line (xx, yy)-(xx + 30, yy + 30), dk, BF
            If showpalnos = 1 Then
                _PrintString (xx + 2, yy + 6), _Trim$(Str$(dk))
            End If
    Next x, y
    _PrintString (10, 257), "S - Save File   L - Load File   B - Save Basic Code  N - show color #'s <ESC> -QUIT "
    _PrintString (10, 275), "Left Click - show RGB values    Right Click - change RGB values "
    _PrintString (10, 293), "C - Copy color    P - Paste color"
End Sub
'mouse sub from wiki with added check for mouse(2)
Sub Mouser (x, y, b)
    mi = _MouseInput
    b = _MouseButton(1)
    If _MouseButton(2) = -1 Then b = -2
    x = _MouseX
    y = _MouseY
End Sub

Print this item