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,843
» Forum posts: 26,643

Full Statistics

Latest Threads
another variation of "10 ...
Forum: Programs
Last Post: JRace
9 hours ago
» Replies: 35
» Views: 513
QBJS v0.9.0 - Release
Forum: QBJS, BAM, and Other BASICs
Last Post: hsiangch_ong
11 hours ago
» Replies: 8
» Views: 78
Extended KotD #22: _MOUSE...
Forum: Keyword of the Day!
Last Post: SMcNeill
11 hours ago
» Replies: 0
» Views: 40
micro(A)v11
Forum: QBJS, BAM, and Other BASICs
Last Post: aurel
Yesterday, 09:10 PM
» Replies: 111
» Views: 5,572
QB64PE v4.0 is now live!!
Forum: Announcements
Last Post: Kernelpanic
Yesterday, 04:08 PM
» Replies: 44
» Views: 2,224
Next small EQ step - EQ D...
Forum: Petr
Last Post: Petr
Yesterday, 02:52 PM
» Replies: 11
» Views: 595
Chr$(135) and _Keyhit
Forum: Help Me!
Last Post: SMcNeill
Yesterday, 02:29 PM
» Replies: 3
» Views: 53
New QBJS Samples Site
Forum: QBJS, BAM, and Other BASICs
Last Post: DANILIN
Yesterday, 12:55 PM
» Replies: 32
» Views: 1,259
Might not be able to be o...
Forum: Announcements
Last Post: Pete
Yesterday, 03:26 AM
» Replies: 0
» Views: 30
Aloha from Maui guys.
Forum: General Discussion
Last Post: Pete
Yesterday, 03:00 AM
» Replies: 13
» Views: 296

 
  What's with "RUN" and "CLS"?
Posted by: PhilOfPerth - 01-09-2023, 03:13 AM - Forum: Help Me! - Replies (3)

Probably two of the simplest instructions,  Run and Cls are confusing the hell out of me!
When I run this code:
Screen 1
Print "ABC"
Print "DEF"
_Delay 1
Print "XXX"
_Delay 1
Cls
Run
I would expect either the Cls, or the Run, to wipe the screen clean. According to Help, Run clears the current programme (and I assume this means its screen as well) but it doesn't!

So, I added the Cls, expecting that this, at least, would clear the screen, but it only cleans down to the first  _Delay (or Sleep) line. Why does the text after _Delay not get wiped?  Huh

Print this item

  Suggestion: Preallocated file open
Posted by: doppler - 01-09-2023, 01:01 AM - Forum: General Discussion - Replies (14)

Windows can do it and I think Linux can too.

On a file open "preallocate" space to be used.  AKA: no fragmentation is possible.

A command to open would look like: open "foo.txt" for output as #1 size=4096  <-- This would preallocate a file 4096k in size.

Of course this would not work for appending.  I only suggest this because a lot of huge files I write out become fragmented.

Just a thought.......
It could get very messy........

Print this item

  Nonograms (Hanjie)
Posted by: RokCoder - 01-08-2023, 10:48 PM - Forum: Games - Replies (25)

Though I've programmed since being a young kid, I haven't dabbled in BASIC for decades (since Apple II and then BBC Micro) but thought I'd try my hand at a Nonograms game. I was going to target the BBC Micro but ultimately decided to give QB64pe a spin and I'm so glad I did. Such a fun few days deep diving into the nuances and differences that have expanded upon the BASIC that I remember from my youth.

Hopefully some of you might have some fun with this.

   
   

Disclaimer: My BASIC-fu is rusty, my QB64pe knowledge is puny and I take no responsibility for the sanity of anyone digging through the source!

Here's the repository - https://github.com/rokcoder-qb64/nonograms 

I've also attached the source BAS file and assets in a ZIP file (but the GitHub code has been updated so that's the best place to grab it from)

.zip   nonograms.zip (Size: 3.08 MB / Downloads: 54)

Print this item

  Rainbow Text
Posted by: SMcNeill - 01-08-2023, 09:47 PM - Forum: SMcNeill - No Replies

You guys are *really* making me feel odd now, digging up remnants of the past as you are.  What is this, an eulogy for poor Steve?  "He was a great guy, that poor old Steve.  Why just the other day, I found this on my drive that he did/helped me with/whatever...."

I'm not dead yet, dang it!!

Sheesh!!   But, eulogistic or not, there's still no reason not to share some of these old gems.  Thanks go to Terry for finding this one and returning it back into the fold with the rest that I've preserved here in this little Steve(tm) subforum.  Wink

Code: (Select All)
fg& = _NewImage(1280, 720, 32)
white& = _RGB32(255, 255, 255)
Screen fg&
Print "This is a demostration of a simple RainbowText routine."
Print "One Command is being used to generate all the text which follows."
Print "Press any key to see some quick samples."
junk$ = Input$(1)

Cls
text$ = "This is sample text"
RainbowText text$, 0, 0, 380, 220, 0, 0, 0, 0, 0
RainbowText text$, 0, 180, 380, 380, 0, 0, 100, 100, 100
RainbowText text$, 0, 90, 300, 300, 0, 0, 150, 150, 150
RainbowText text$, 0, 270, 460, 300, 0, 0, 50, 100, 150
RainbowText text$, 1, 0, 100, 100, 0, 0, 10, 200, 0
RainbowText text$, -1, 0, 300, 100, 0, 0, 200, 200, 0

Locate 35, 40: Print "Press any key to watch what else you can do!"

junk$ = Input$(1)

Color , _RGB32(0, 0, 255)
direction = .25

Do
    Cls
    i = i + direction
    RainbowText text$, 0, i, 500, 500, 0, 0, r, g, b
    If i > 360 Or i < 0 Then direction = -direction
Loop Until InKey$ <> ""
_AutoDisplay
Locate 10, 10: Print "HA!  Rotating text, and all from 1 simple routine."

Cls


f& = _LoadFont("times.ttf", 100)
Do
    RainbowText text$, 0, 0, 500, 200, f&, 0, 255, 100, b
Loop Until InKey$ <> ""
_AutoDisplay


End


Sub RainbowText (text$, slant%, angle%, x%, y%, font&, b&, r, g, b)
    A = _AutoDisplay: F = _Font: D = _Dest
    dc& = _DefaultColor: bg& = _BackgroundColor
    slant% = slant% + 1 'This keeps slant 0 as neutral
    bgi& = _NewImage(100, 100, 32): _Dest bgi& 'temporary for sizing
    If font& <> 0 Then _Font font&
    length% = _PrintWidth(text$): height% = _FontHeight
    _FreeImage bgi&
    bgi& = _NewImage(length%, height%, 32) 'screen to draw to, the proper size
    _Dest bgi&: If font& <> 0 Then _Font font&
    Color _RGB32(255, 255, 255), b&
    _PrintString (0, 0), text$
    TLC$ = "BL" + Str$(length% \ 2) + "BU" + Str$(height% \ 2)
    RET$ = "BD BL" + Str$(length%)
    _Source bgi&
    _Dest D
    Draw "BM" + Str$(x%) + "," + Str$(y%) + "TA=" + VarPtr$(angle%) + TLC$
    For y = 0 To height% - slant%
        For x = 0 To length% - slant%
            If Point(x, y) <> b& Then
                r = r + 5
                If r > 255 Then r = 0: g = g + 5
                If g > 255 Then g = 0: b = b + 5
                If b > 255 Then b = 0: r = 0
                Draw "C" + Str$(_RGB32(r, g, b)) + "R1" 'color and DRAW each pixel
            Else
                Draw "B R1" 'color and DRAW each pixel
            End If
        Next
        Draw RET$
    Next
    If Not A Then _Display: _AutoDisplay 'Remark this line out if you want to manually use _DISPLAY to show the text
    _FreeImage bgi&
    If font& <> 0 Then _Font F
    Color dc&, bg&
End Sub

Print this item

  3D Terrain
Posted by: james2464 - 01-08-2023, 09:24 PM - Forum: Help Me! - Replies (25)

I've managed to figure out how to produce random terrain using a grid of triangles, and then assigning a slightly random z value to the points.   It's very primitive but could be useful to build on.   

But for now I'm stuck on how to detect or collide with this terrain.   It might be very complicated, or perhaps not.   Right now the spectator viewing is just like ghost mode, as in you can fly around and go through everything.   I'd like to make it so you can't pass through the textures at all.   Then if I can choose some textures as OK to pass throught (such as water surface) and others NOT OK to pass through, such as land, that would be ideal.   And later on, I'd like to be able to put a character on the surface and control it.    For now though, I'd like to understand how to detect these surfaces.    A square/rectangle room is not a problem, because you can just set limits on X,Y,Z movement.   Any flat surface is easy this way.   But the random terrain seems to need a different approach.

Code: (Select All)
'3d terrain on water - james2464 - Jan 2023
'Credit to 3D program and tutorial by MasterGy

Option _Explicit
Randomize Timer

Screen _NewImage(1000, 1000, 32)

Const pip180 = 3.141592 / 180

Dim Shared c(100) As Long
Dim scr, da, db, da2, dega, db2, degb, ss, ap, sqa
Dim sky_points, sky_image, actual_point, asq
Dim wx0, wy0, wz0, wx1, wy1, wz1, wx2, wy2, wz2, wx3, wy3, wz3, sx0, sy0, sx1, sy1, sx2, sy2, sx3, sy3
Dim mousex, mousey, mw, mouse_sens, vec_x, vec_y, vec_z, speed, moving
Dim sp3
Dim t, x, y, h, b, tz
Dim Shared trx(5000), try(5000), trz(5000) 'terrain points
Dim Shared fr1(5000), fr2(5000), fr3(5000), fr4(5000), fr5(5000), fr6(5000) 'terrain point groups  (hex)
Dim Shared maxterrain, maxp, shx, shy, shz

Cls


colour1

Dim Shared floor1, wall1, wall2, ground1, sky1, cbx(20)



wall1 = _NewImage(500, 100, 32): makewall
wall2 = _NewImage(500, 100, 32): makewall2
ground1 = _NewImage(500, 500, 32): makeground
'ground1 = _LoadImage("painting.jpg", 32)
sky1 = _NewImage(750, 750, 32): makesky

maketerrain

For t = 0 To 10: cbx(t) = _NewImage(400, 400, 32): Next t: makepallette

Dim Shared tximage(200)
For t = 0 To 10: tximage(t) = _CopyImage(cbx(t), 33): Next t

tximage(11) = _CopyImage(ground1, 33)
tximage(12) = _CopyImage(wall1, 33) 'office wall solid
tximage(13) = _CopyImage(wall2, 33) 'office wall with 3 windows


Type mapobject
    n As Integer 'object number
    x As Single 'x origin
    y As Single 'y origin
    z As Single 'z origin
    x1 As Single
    y1 As Single
    z1 As Single
    x2 As Single
    y2 As Single
    z2 As Single
    x3 As Single
    y3 As Single
    z3 As Single
    x4 As Single
    y4 As Single
    z4 As Single
    ix As Single 'image x
    iy As Single 'image y
    in As Integer 'image number - tximage()
End Type
Dim Shared raw(100) As mapobject, oo(900) As mapobject

'create texture point data array
Dim Shared tx(500, 19), txtot, rawtxtot

'objects and data points
Data 1,0,0,0,-1000,0,200,-1000,0,-200,1000,0,200,1000,0,-200,500,100,12: 'wall
Data 2,0,0,0,-4000,-4000,0,-4000,4000,0,4000,-4000,0,4000,4000,0,500,100,3: 'water

rawtxtot = 2: txtot = rawtxtot

'read data into array tx()
Dim t2
For t = 1 To txtot
    For t2 = 1 To 19
        Read tx(t, t2)
    Next t2
    'create 'raw' objects
    raw(t).n = tx(t, 1): raw(t).x = tx(t, 2): raw(t).y = tx(t, 3): raw(t).z = tx(t, 4)
    raw(t).x1 = tx(t, 5): raw(t).y1 = tx(t, 6): raw(t).z1 = tx(t, 7)
    raw(t).x2 = tx(t, 8): raw(t).y2 = tx(t, 9): raw(t).z2 = tx(t, 10)
    raw(t).x3 = tx(t, 11): raw(t).y3 = tx(t, 12): raw(t).z3 = tx(t, 13)
    raw(t).x4 = tx(t, 14): raw(t).y4 = tx(t, 15): raw(t).z4 = tx(t, 16)
    raw(t).ix = tx(t, 17): raw(t).iy = tx(t, 18): raw(t).in = tx(t, 19)
Next t


'object copies
Dim nn, nc, xc, yc, zc, ac
'nn = 1: nc = 1: xc = 0: yc = 0: zc = 400: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'wall
nn = 1: nc = 2: xc = 0: yc = 0: zc = 500: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'water


'create spectator
Dim Shared sp(6)
sp(0) = 0 'X position
sp(1) = 1500 'Y
sp(2) = 400 'Z
sp(3) = 0 'looking in the direction of the observer XZ
sp(4) = 0 'looking in the direction of the observer YZ
sp(5) = 1 'multiplier X-Y see
sp(6) = 1 'multiplier Z see

'create screen
scr = _NewImage(1000, 1000 / _DesktopWidth * _DesktopHeight, 32)
Screen scr
_MouseHide
_FullScreen
_Dest scr
_DisplayOrder _Hardware , _Software


'sky install
da = 11 'resolution sphere X
db = 7 'resolution sphere Y

sky_points = da * db
Dim sky_points(sky_points - 1, 9), sq(sky_points - 1, 7)
'sky_image = _LoadImage("sky.jpg", 33)
sky_image = _CopyImage(sky1, 33)

For da2 = 0 To da - 1
    dega = 360 / (da - 1) * da2 * pip180
    For db2 = 0 To db - 1
        degb = 180 / (db - 1) * db2 * pip180
        ss = 4000
        ap = da2 * db + db2
        sky_points(ap, 0) = Sin(degb) * Cos(dega) * ss
        sky_points(ap, 1) = Sin(degb) * Sin(dega) * ss
        sky_points(ap, 2) = Cos(degb) * ss
    Next db2
Next da2

For da2 = 0 To da - 2
    For db2 = 0 To db - 2
        sqa = da2 * db + db2
        sq(sqa, 0) = sqa
        sq(sqa, 1) = sq(sqa, 0) + 1
        sq(sqa, 2) = sq(sqa, 0) + db
        sq(sqa, 3) = sq(sqa, 2) + 1
        sq(sqa, 4) = _Width(sky_image) - (_Width(sky_image) / (da - 1) * da2) - 1
        sq(sqa, 5) = _Width(sky_image) - (_Width(sky_image) / (da - 1) * (da2 + 1)) - 1
        sq(sqa, 6) = Int(_Height(sky_image) / (db - 1) * db2)
        sq(sqa, 7) = Int(_Height(sky_image) / (db - 1) * (db2 + 1))
    Next db2
Next da2


'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================

Do
    _Limit 40

    processterrain
    processtextures



    'draw sky    *********************************************************************************
    't = 1  'use for checkered sky

    'rotating
    For actual_point = 0 To sky_points - 1
        sky_points(actual_point, 4) = sky_points(actual_point, 0)
        sky_points(actual_point, 5) = sky_points(actual_point, 1)
        sky_points(actual_point, 6) = sky_points(actual_point, 2)
        r2m sky_points(actual_point, 4), sky_points(actual_point, 5), sky_points(actual_point, 6)
    Next actual_point

    For asq = 0 To sky_points - 1
        wx0 = sky_points(sq(asq, 0), 4) + 0: wy0 = sky_points(sq(asq, 0), 5) + 0: wz0 = sky_points(sq(asq, 0), 6)
        wx1 = sky_points(sq(asq, 1), 4) + 0: wy1 = sky_points(sq(asq, 1), 5) + 0: wz1 = sky_points(sq(asq, 1), 6)
        wx2 = sky_points(sq(asq, 2), 4) + 0: wy2 = sky_points(sq(asq, 2), 5) + 0: wz2 = sky_points(sq(asq, 2), 6)
        wx3 = sky_points(sq(asq, 3), 4) + 0: wy3 = sky_points(sq(asq, 3), 5) + 0: wz3 = sky_points(sq(asq, 3), 6)
        sy0 = sq(asq, 6): sx0 = sq(asq, 4): sy1 = sq(asq, 7): sx1 = sq(asq, 4): sy2 = sq(asq, 6): sx2 = sq(asq, 5): sy3 = sq(asq, 7): sx3 = sq(asq, 5)
        't = t * -1 'use for checkered sky
        'If t > 0 Then 'use for checkered sky
        _MapTriangle (sx0, sy0)-(sx1, sy1)-(sx2, sy2), sky_image To(wx0, wy0, wz0)-(wx1, wy1, wz1)-(wx2, wy2, wz2), , _Smooth
        _MapTriangle (sx3, sy3)-(sx1, sy1)-(sx2, sy2), sky_image To(wx3, wy3, wz3)-(wx1, wy1, wz1)-(wx2, wy2, wz2), , _Smooth
        'End If 'use for checkered sky
    Next asq
    ' ****************************************************************************************************

    _Display


    '-------------------------------------------------------------
    'mouse input axis movement and mousewheel
    '-------------------------------------------------------------
    mousex = mousex * .6
    mousey = mousey * .6
    mw = 0
    While _MouseInput: mousex = mousex + _MouseMovementX: mousey = mousey + _MouseMovementY: mw = mw + _MouseWheel: Wend 'movement data read

    'control spectator
    mouse_sens = .0007 'mouse rotating sensitive
    sp(3) = sp(3) - mousex * mouse_sens
    sp(4) = sp(4) + mousey * mouse_sens
    If Abs(sp(4)) > _Pi / 2 Then sp(4) = _Pi / 2 * Sgn(sp(4))
    sp3 = sp(3) + (_KeyDown(Asc("d")) - _KeyDown(Asc("a"))) * 90 * pip180
    vec_x = (Sin(sp3) * (Cos(sp(4) + _Pi)))
    vec_y = (Cos(sp3) * (Cos(sp(4) + _Pi)))
    vec_z = -Sin(sp(4) + _Pi)
    If _KeyDown(Asc("a")) Or _KeyDown(Asc("d")) Then vec_z = 0
    speed = 2.5 'moving speed
    moving = Abs(_MouseButton(1) Or _KeyDown(Asc("w")) Or _KeyDown(Asc("a")) Or _KeyDown(Asc("d"))) * speed - Abs(_MouseButton(2) Or _KeyDown(Asc("s"))) * speed
    sp(0) = sp(0) + vec_x * moving
    sp(1) = sp(1) + vec_y * moving
    sp(2) = sp(2) + vec_z * moving

    'If sp(0) > 465 Then sp(0) = 465
    'If sp(1) > 465 Then sp(1) = 465
    'If sp(0) < -465 Then sp(0) = -465
    'If sp(1) < -465 Then sp(1) = -465

Loop Until _KeyDown(27)



'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================



Sub r2m (x, y, z)
    Dim x2, y2, z2
    x2 = x - sp(0)
    y2 = y - sp(1)
    z2 = z - sp(2)
    rotate_2d x2, y2, sp(3)
    rotate_2d y2, z2, sp(4) + _Pi / 2
    x = x2 * sp(5)
    y = y2 * sp(5)
    z = z2 * sp(6)
End Sub

Sub rotate_2d (x, y, ang)
    Dim x1, y1
    x1 = x * Cos(ang) - y * Sin(ang)
    y1 = x * Sin(ang) + y * Cos(ang)
    x = x1: y = y1
End Sub



Sub processtextures
    Dim t, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4

    For t = 1 To txtot
        x1 = oo(t).x1: y1 = oo(t).y1: z1 = oo(t).z1
        x2 = oo(t).x2: y2 = oo(t).y2: z2 = oo(t).z2
        x3 = oo(t).x3: y3 = oo(t).y3: z3 = oo(t).z3
        x4 = oo(t).x4: y4 = oo(t).y4: z4 = oo(t).z4
        x = oo(t).ix: y = oo(t).iy
        r2m x1, y1, z1
        r2m x2, y2, z2
        r2m x3, y3, z3
        r2m x4, y4, z4
        _MapTriangle (0, 0)-(0, y)-(x, 0), tximage(oo(t).in) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
        _MapTriangle (x, y)-(0, y)-(x, 0), tximage(oo(t).in) To(x4, y4, z4)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
    Next t

End Sub

Sub processterrain
    Dim t, t2, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
    Dim xx1, yy1, zz1, xx2, yy2, zz2, xx3, yy3, zz3, xx4, yy4, zz4
    Dim flag, ct, scale1, txm
    flag = 0
    ct = 0
    scale1 = 2.
    shx = -500 'shift x position
    shy = -500 'shift y position
    shz = 502 'shift z position

    Do
        ct = ct + 1

        x1 = trx(fr1(ct)): y1 = try(fr1(ct)): z1 = trz(fr1(ct))
        x2 = trx(fr2(ct)): y2 = try(fr2(ct)): z2 = trz(fr2(ct))
        x3 = trx(fr3(ct)): y3 = try(fr3(ct)): z3 = trz(fr3(ct))

        xx1 = x1: yy1 = y1
        xx2 = x2: yy2 = y2
        xx3 = x3: yy3 = y3


        x1 = x1 * scale1: y1 = y1 * scale1: 'z1 = z1 * scale1
        x2 = x2 * scale1: y2 = y2 * scale1: 'z2 = z2 * scale1
        x3 = x3 * scale1: y3 = y3 * scale1: 'z3 = z3 * scale1


        x1 = x1 + shx: y1 = y1 + shy: z1 = z1 + shz
        x2 = x2 + shx: y2 = y2 + shy: z2 = z2 + shz
        x3 = x3 + shx: y3 = y3 + shy: z3 = z3 + shz


        r2m x1, y1, z1
        r2m x2, y2, z2
        r2m x3, y3, z3

        txm = 11
        _MapTriangle (xx1, yy1)-(xx2, yy2)-(xx3, yy3), tximage(txm) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth

        If ct >= maxp Then flag = 1
    Loop Until flag = 1

End Sub


Sub objectcopy (nn, nc, xc, yc, zc, ac)
    Dim ct, t, t2, xt, yt
    ct = 0
    For t = 1 To rawtxtot
        If raw(t).n = nc Then
            ct = ct + 1
            t2 = txtot + ct
            oo(t2).n = nn: oo(t2).x = xc: oo(t2).y = yc: oo(t2).z = zc
            xt = raw(t).x1: yt = raw(t).y1: xyrotation xt, yt, ac: oo(t2).x1 = xt + xc: oo(t2).y1 = yt + yc: oo(t2).z1 = raw(t).z1 + zc
            xt = raw(t).x2: yt = raw(t).y2: xyrotation xt, yt, ac: oo(t2).x2 = xt + xc: oo(t2).y2 = yt + yc: oo(t2).z2 = raw(t).z2 + zc
            xt = raw(t).x3: yt = raw(t).y3: xyrotation xt, yt, ac: oo(t2).x3 = xt + xc: oo(t2).y3 = yt + yc: oo(t2).z3 = raw(t).z3 + zc
            xt = raw(t).x4: yt = raw(t).y4: xyrotation xt, yt, ac: oo(t2).x4 = xt + xc: oo(t2).y4 = yt + yc: oo(t2).z4 = raw(t).z4 + zc
            oo(t2).ix = raw(t).ix: oo(t2).iy = raw(t).iy: oo(t2).in = raw(t).in
        End If
    Next t
    txtot = txtot + ct
End Sub



Sub xyrotation (x, y, a)
    Dim xt, yt, h, h1, h2, xt2, yt2
    xt = x: yt = y
    h = _Hypot(yt, xt)
    h1 = _Atan2(xt, yt)
    h2 = h1 - a
    xt2 = Sin(h2) * h
    yt2 = Cos(h2) * h
    x = xt2
    y = yt2
End Sub



Sub makefloor
    Dim t, x1, y1
    Cls
    Line (0, 0)-(500, 500), c(18), BF 'floor background

    For t = 1 To 6000
        x1 = Int(Rnd * 500): y1 = Int(Rnd * 500): PSet (x1, y1), c(0)
        x1 = Int(Rnd * 500): y1 = Int(Rnd * 500): PSet (x1, y1), c(2)
        x1 = Int(Rnd * 500): y1 = Int(Rnd * 500): PSet (x1, y1), c(3)
    Next t
    '_Display
    _PutImage (0, 0)-(500, 500), 0, floor1, (0, 0)-(500, 500)
    'Sleep
End Sub



Sub makewall
    Dim t, x1, y1
    Cls
    Line (0, 0)-(500, 100), c(7), BF 'wall background
    For t = 1 To 6000
        x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(8)
        x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(9)
    Next t
    '_Display
    _PutImage (0, 0)-(500, 100), 0, wall1, (0, 0)-(500, 100)
    _ClearColor c(0), wall1
    'Sleep
End Sub


Sub makewall2
    Dim t, x1, y1
    Cls
    Line (0, 0)-(500, 100), c(7), BF 'wall2 background
    For t = 1 To 6000
        x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(8)
        x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(9)
    Next t
    Line (70, 25)-(150, 75), c(0), BF
    Line (210, 25)-(290, 75), c(0), BF
    Line (350, 25)-(430, 75), c(0), BF
    '_Display
    _PutImage (0, 0)-(500, 100), 0, wall2, (0, 0)-(500, 100)
    _ClearColor c(0), wall2
    'Sleep
End Sub




Sub makeground
    Dim t, x1, y1, s, s2
    s = 220
    s2 = (500 - s) / 2
    Cls
    Line (0, 0)-(500, 500), c(14), BF 'border/beach
    Line (0, 0)-(500, 500), c(40), BF 'ground background
    For t = 1 To 155
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        Line (x1 - 30, y1 - 30)-(x1 + 30, y1 + 30), c(41), BF
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        Line (x1 - 50, y1 - 50)-(x1 + 50, y1 + 50), c(42), BF
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        Line (x1 - 20, y1 - 20)-(x1 + 20, y1 + 20), c(43), BF
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        Line (x1 - 20, y1 - 20)-(x1 + 20, y1 + 20), c(44), BF
    Next t
    s = 790
    s2 = (500 - s) / 2

    For t = 1 To 7500
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        PSet (x1, y1), c(41)
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        PSet (x1, y1), c(42)
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        PSet (x1, y1), c(43)
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        PSet (x1, y1), c(44)
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        PSet (x1, y1), c(41)
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        PSet (x1, y1), c(42)
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        PSet (x1, y1), c(43)
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        PSet (x1, y1), c(44)

    Next t
    'Line (5, 5)-(495, 10), c(31), BF
    'Line (5, 495)-(495, 490), c(32), BF
    'Line (490, 5)-(495, 495), c(33), BF
    'Line (5, 5)-(10, 495), c(34), BF
    '_Display
    _PutImage (0, 0)-(500, 500), 0, ground1, (0, 0)-(500, 500)
    'Sleep
End Sub







Sub maketerrain
    Dim t, s, x, y, x1, y1, p, q, p2, ct, ct2, flag
    Dim xt, yt, xh, yh, vc, fx, fx1, fx2, mx, oldct
    Cls
    Line (0, 0)-(500, 500), c(1), B
    t = 0
    x1 = 500: y1 = 500
    s = 25
    fx = 1
    maxterrain = 0
    'create points  (trx,try,trz)
    For y = 0 To y1 Step s

        fx = Int(fx * -1)
        If fx > 0 Then
            fx1 = 0
        Else fx1 = s / 2
        End If

        For x = fx1 To x1 Step s
            t = t + 1
            trx(t) = x: try(t) = y
            Circle (x, y), 3, c(1)
            If x > s And x < x1 - s Then
                If y > s And y < y1 - s Then
                    'trz(t) = 0
                    trz(t) = 0 - Int(Rnd * 17) - 5
                    xh = Abs(trx(t) - x1 / 2)
                    yh = Abs(try(t) - y1 / 2)
                    vc = _Hypot(xh, yh)
                    vc = 170 - vc
                    trz(t) = trz(t) - vc / 4
                    'trz(t) = trz(t) - (Int(Rnd * vc))
                End If
            End If
        Next x
    Next y
    '_Display
    'Sleep
    maxterrain = t


    'display points
    p = Int(x1 / s) + 1
    q = Int(y1 / s) - 1
    fx = 1
    t = 0
    oldct = 0

    For y = 0 To y1 Step s
        fx = Int(fx * -1)
        If fx > 0 Then
            fx1 = 0
        Else fx1 = s / 2
        End If
        For x = fx1 To x1 Step s
            t = t + 1
            If y > s Then
                If x > s Then
                    If x < x1 - s Then
                        If y < y1 - s Then
                            Circle (trx(t), try(t)), 2, c(1)
                            Circle (trx(t), try(t)), 1, c(1)
                            Circle (trx(oldct), try(oldct)), 2, c(0)
                            Circle (trx(oldct), try(oldct)), 1, c(0)
                            'Line (trx(t), try(t))-(trx(t - p), try(t - p)), c(1)
                            'Line (trx(t), try(t))-(trx(t - p + 1), try(t - p + 1)), c(1)
                            'Line (trx(t), try(t))-(trx(t + p - 1), try(t + p - 1)), c(1)
                            'Line (trx(t), try(t))-(trx(t + p), try(t + p)), c(1)
                            'Line (trx(t), try(t))-(trx(t - 1), try(t - 1)), c(1)
                            'Line (trx(t), try(t))-(trx(t + 1), try(t + 1)), c(1)
                            oldct = t
                            '_Display
                            'Sleep
                            'Line (trx(t), try(t))-(trx(t - p), try(t - p)), c(0)
                            'Line (trx(t), try(t))-(trx(t - p + 1), try(t - p + 1)), c(0)
                            'Line (trx(t), try(t))-(trx(t + p - 1), try(t + p - 1)), c(0)
                            'Line (trx(t), try(t))-(trx(t + p), try(t + p)), c(0)
                            'Line (trx(t), try(t))-(trx(t - 1), try(t - 1)), c(0)
                            'Line (trx(t), try(t))-(trx(t + 1), try(t + 1)), c(0)

                        End If
                    End If
                End If
            End If
        Next x
    Next y

    '_Display
    'Sleep


    'create point groups (fr1,fr2,fr3)
    p = Int(x1 / s) + 1
    q = Int(y1 / s) - 1
    fx = 1
    t = 0
    ct = 0
    oldct = 0

    For y = 0 To y1 - 1 Step s
        fx = Int(fx * -1)
        If fx > 0 Then
            fx1 = 0
        Else fx1 = s / 2
        End If
        For x = fx1 To x1 Step s
            t = t + 1
            If fx > 0 Then

                ct = ct + 1
                fr1(ct) = t
                fr2(ct) = t - p
                fr3(ct) = t - p + 1
                Line (trx(t), try(t))-(trx(t - p), try(t - p)), c(32)
                Line (trx(t), try(t))-(trx(t - p + 1), try(t - p + 1)), c(32)
                Line (trx(t - p), try(t - p))-(trx(t - p + 1), try(t - p + 1)), c(32)
                '_Display
                'Sleep

                ct = ct + 1
                fr1(ct) = t
                fr2(ct) = t + p
                fr3(ct) = t + p - 1
                Line (trx(t), try(t))-(trx(t + p), try(t + p)), c(1)
                Line (trx(t), try(t))-(trx(t + p - 1), try(t + p - 1)), c(1)
                Line (trx(t + p), try(t + p))-(trx(t + p - 1), try(t + p - 1)), c(1)
                '_Display
                'Sleep

            Else

                ct = ct + 1
                fr1(ct) = t
                fr2(ct) = t + p
                fr3(ct) = t + p - 1
                Line (trx(t), try(t))-(trx(t + p), try(t + p)), c(33)
                Line (trx(t), try(t))-(trx(t + p - 1), try(t + p - 1)), c(33)
                Line (trx(t + p), try(t + p))-(trx(t + p - 1), try(t + p - 1)), c(33)
                '_Display
                'Sleep

                ct = ct + 1
                fr1(ct) = t + p + p - 1
                fr2(ct) = t + p
                fr3(ct) = t + p - 1
                Line (trx(t + p + p - 1), try(t + p + p - 1))-(trx(t + p), try(t + p)), c(34)
                Line (trx(t + p + p - 1), try(t + p + p - 1))-(trx(t + p - 1), try(t + p - 1)), c(34)
                Line (trx(t + p), try(t + p))-(trx(t + p - 1), try(t + p - 1)), c(34)
                '_Display
                'Sleep
            End If


            oldct = t
            Locate 35, 1
            Print t, ct
            '_Display
            'Sleep
        Next x
    Next y
    maxp = ct


    'fr1(t) = t - p
    'fr2(t) = t - p + 1
    'fr3(t) = t + p - 1




    'Cls
    't = t + 1
    'For ct = 1 To t
    'Print fr1(ct), fr2(ct), fr3(ct)
    'Next ct



    '_Display
    'Sleep

End Sub





Sub makesky
    Dim t, y, m
    Cls
    y = 750
    For t = 1 To y
        m = 255 * ((750 - t * .65) / 750)
        c(99) = _RGBA(200, 200, 255, m)
        Line (0, t)-(750, t), c(99)
    Next t
    'For t = 0 To 750 Step 25 'longituge lines
    'Line (t, 0)-(t, 750), c(1)
    'Next t
    'For t = 0 To 750 Step 25 'latitude lines
    'Line (0, t)-(750, t), c(1)
    'Next t
    '_Display
    _PutImage (0, 0)-(750, 750), 0, sky1, (0, 0)-(750, 750)
    'Sleep
End Sub




Sub makepallette
    Dim t
    For t = 0 To 10
        Cls
        Line (0, 0)-(400, 400), c(t), BF
        _PutImage (0, 0)-(400, 400), 0, cbx(t), (0, 0)-(400, 400)
        '_Display
        'Sleep
    Next t
End Sub



Sub colour1
    c(0) = _RGB(0, 0, 0)
    c(1) = _RGB(255, 255, 255)
    c(2) = _RGB(35, 25, 10)
    c(3) = _RGB(10, 45, 65)
    c(4) = _RGB(40, 50, 10)
    c(5) = _RGB(0, 25, 75)
    c(6) = _RGB(45, 35, 20)
    c(7) = _RGB(150, 150, 150)
    c(8) = _RGB(125, 125, 125)
    c(9) = _RGB(100, 100, 100)
    c(10) = _RGBA(75, 75, 75, 151)
    c(11) = _RGB(0, 0, 0)
    c(12) = _RGB(35, 25, 10)
    c(13) = _RGB(0, 45, 85)
    c(14) = _RGB(160, 150, 100)
    c(15) = _RGB(0, 25, 75)
    c(16) = _RGB(55, 25, 30)
    c(17) = _RGB(175, 175, 175)
    c(18) = _RGB(100, 100, 100)
    c(20) = _RGB(20, 30, 15)
    c(31) = _RGB(255, 255, 255)
    c(32) = _RGB(255, 0, 0)
    c(33) = _RGB(0, 55, 255)
    c(34) = _RGB(255, 255, 0)
    c(40) = _RGBA(45, 20, 25, 125)
    c(41) = _RGBA(50, 50, 30, 40)
    c(42) = _RGBA(20, 30, 15, 40)
    c(43) = _RGBA(75, 45, 15, 40)
    c(44) = _RGBA(40, 60, 30, 40)
    c(45) = _RGB(50, 50, 30)
    c(46) = _RGB(20, 30, 15)
    c(47) = _RGB(55, 45, 15)
    c(48) = _RGB(40, 50, 10)

End Sub

Print this item

  SAC -- Steve's Anorexic Code
Posted by: SMcNeill - 01-08-2023, 03:21 AM - Forum: SMcNeill - Replies (2)

Ahhh...  The smell of the past!  Many thanks to @keybone who dug up this old gem from the long lost days of the original qb64 forums over at .net, when Galleon was still around and in charge of things.

Code: (Select All)
'Steve's Anorexic Code
'This code has a very unique value to us.
'1) This allows us to append files to the end of our exe's very easily, and then extract them and clean them up afterwards.
'2) This works at a command line level, and lets us shell out from inside a program itself.

'To use this, first try it a few times with some BACKED UP copy of test files!!
'BACK EM UP!! BACK EM UP!! BACK EM UP!!

'Got that?  Good.

'Then run this as a standard program.
'Enter the name of the file you'd like to feed stuff to.
'And at first, -SET THE TABLE  Do this only once, as this sets us a counter for number of files "eatten"
'Then feed it something.  -GOBBLE filename$  <-- this is the file we tack to the end of our exe
'Feed it more files if you want.  Watch the exe grow in size as it absorbs the other files...

'Is it fat?  Did you feed it enough?
'If so, then -PUKE or -BARF  Throw them files back up!

'Phew!  Didn't that make a mess?
'Then -CLEAN UP
'See all them files go POOF and disappear again?  We clean up our mess afterwards.

'But this is MAGIC Anorexic Code!  The exe still has all those files in it that it barfed up.
'Tell it to -PUKE again.
'All those files are back once more!!

'Use this as a quick, easy way to tack needed files onto your exe to make certain that an user will always have them.
'I use this to  tack sound files, fonts, even images to my exe, and I extract them as needed.

'NOTE however, that this isn't just limited to EXE files.  You can use this to assemble 100 map files into 1 map compendium,
'  and then extract them when needed.  At the moment, we don't puke single files up -- we puke every file up -- but
'  someone could modify this easily enough to extract single files from a larger collection.

'To use as a shell command, use it like the following:
'  Shell _hide "SAC.exe g.exe -gobble z:\test.txt"    <--- this would add the test.txt file to the end of the g.exe file'
'  syntax is:  SAC.exe file1$ -command file2$
'      file1$ would be the file we want to write to -- or feed.
'      -command is the -command which we want to execute.  -SET THE TABLE, -GOBBLE, -BARF, -CLEAN UP

'Simple, and useful as heck!  :D


Dim Shared SAC_FileName As String
parameter$ = LTrim$(RTrim$(Command$))
If parameter$ <> "" Then
    dash = InStr(parameter$, "-")
    SAC_FileName = LTrim$(RTrim$(Left$(parameter$, dash - 1)))
    parameter$ = RTrim$(LTrim$(Right$(parameter$, Len(parameter$) - dash + 1)))
    Print SAC_FileName, parameter$
    End
    DoSAC parameter$
    System
End If

Print "Give me the name of your file to stuff =>";
Input SAC_FileName
Do
    Cls
    Print SAC_FileName
    Print
    Print "1) Initialize"
    Print "2) Gobble Something"
    Print "3) Puke"
    Print "4) Clean Up"
    Print "5) End"
    a$ = Input$(1)
    a = Val(a$)
    Select Case a
        Case 1: DoSAC "-INIT": Print "Initialized"
        Case 2:
            Print "Name of file to eat:";
            Input NAME$
            NAME$ = "-GOBBLE " + NAME$
            DoSAC NAME$
        Case 3: DoSAC "-BARF"
        Case 4: DoSAC "-CLEAN UP"
        Case 5: System
    End Select
    Sleep
Loop


Sub DoSAC (t$)
    Dim b As _Unsigned _Byte
    Dim text As String * 1
    Dim l(10) As _Unsigned _Integer64, l As _Unsigned _Integer64
    Dim SACfile As String * 255
    f = FreeFile
    Select Case UCase$(t$)
        Case "-SET THE TABLE", "-SET", "-INIT"
            'initialize
            Open SAC_FileName For Binary As #f
            Seek #f, LOF(f) + 1
            b = 0
            Put #f, , b
        Case "-BARF", "-PUKE"
            'puke it all up
            Open SAC_FileName For Binary As #f
            Seek #f, LOF(f)
            Get #f, , b
            If b < 1 Then Print "No files have been gorged on by this program.  FEED ME SOME!!": Beep: Beep: End
            Print b; "files to puke up!"
            CurrentPos = LOF(f) + 1
            AmountAte = b
            For i&& = 1 To AmountAte
                CurrentPos = CurrentPos - 256
                Get #f, CurrentPos, SACfile
                file$ = LTrim$(RTrim$(SACfile))
                Print file$; " barfed up!"
                CurrentPos = CurrentPos - 8
                Get #f, CurrentPos, l
                CurrentPos = CurrentPos - l
                g = FreeFile
                Seek #f, CurrentPos
                Open file$ For Binary As #g
                For j&& = 1 To l
                    Get #f, , b
                    Put #g, , b
                Next
                b = 0
                Put #g, , b
                Close #g
            Next
        Case "-CLEAN UP"
            'clean up the drive of all the puke
            Open SAC_FileName For Binary As #f
            Seek #f, LOF(f)
            Get #f, , b
            If b < 1 Then Print "No files have been gorged on by this program.  FEED ME SOME!!": Beep: Beep: End
            Print b; "puked up files to clean up!"
            CurrentPos = LOF(f) + 1
            AmountAte = b
            For i&& = 1 To AmountAte
                CurrentPos = CurrentPos - 256
                Get #f, CurrentPos, SACfile
                file$ = LTrim$(RTrim$(SACfile))
                Print file$; " cleaned up off the dinner table!"
                CurrentPos = CurrentPos - 8
                Get #f, CurrentPos, l
                CurrentPos = CurrentPos - l
                Kill file$
            Next
        Case Else
            If Left$(t$, 8) = "-GOBBLE " Then
                file$ = Right$(t$, Len(t$) - 8)
                If _FileExists(file$) Then
                    Print "Eatting "; file$
                    'eat stuff
                    Open SAC_FileName For Binary As #f
                    l(0) = LOF(f)
                    Seek #f, l(0)
                    Get #f, , b
                    AmountEat = b
                    g = FreeFile
                    Open file$ For Binary As #g
                    l(1) = LOF(g)
                    For i&& = 1 To l(1)
                        Get #g, , b
                        Put #f, , b
                    Next
                    Close #g
                    Put #f, , l(1)
                    SACfile = file$
                    Put #f, , SACfile
                    b = AmountEat + 1
                    Put #f, , b
                    Print file$, " was tasty!"
                Else
                    'Do nothing as the file doesn't exist.
                    Print "WARNING: "; file$; " does not exist!"
                    Beep: Beep
                End If
            End If
    End Select
    Close #f
End Sub


Steve's Anorexic Code is an utility which eats resource files, stuffs them onto your existing EXE, and then barfs them back up on call.  Want to pack a dozen files into one and ship them all together?  This can do that!  Compile your EXE, and then feed SAC that EXE and resource files, and get one nice and fat file all packaged up together.  When you need those resources, just -barf them back up on demand!  

What's not to love about it?  Just read the comments for ease of usage.  Big Grin

Print this item

  Changing Compile Options
Posted by: bplus - 01-07-2023, 04:09 PM - Forum: GitHub Discussion - Replies (9)

When I changed compile options in QB64 pe 3.4.1 I lost all my recent files!

Was this fixed?

It looks like I have latest release according to this site bottom link for QB64pe

Print this item

  Keypad Entry
Posted by: eoredson - 01-07-2023, 05:33 AM - Forum: Help Me! - Replies (17)

I am working on a project that requires keypad entry.

The problem is that QB64 does not trap them!?

Here is my code:

Code: (Select All)
Rem Keypad-5 = 76
Rem Shift-Keypad-5 = 53
Rem Ctrl-Keypad-5 = 143
Do
  X$ = InKey$
  If Len(X$) Then
      If X$ = Chr$(27) Then End
      If Len(X$) = 2 Then
        X = Asc(Right$(X$, 1))
        Select Case X
            Case 76
              Print "keypad-5"
            Case 53
              Print "shift-keypad-5"
            Case 143
              Print "ctrl-keypad-5"
        End Select
      End If
  End If
Loop
End

Print this item

  better error trapping?
Posted by: madscijr - 01-06-2023, 06:57 PM - Forum: General Discussion - Replies (15)

With http/s capability coming, QB64PE is getting a major feature set. 
With that out of the way, I was thinking that another big feature for an upcoming release would be try/catch functionality. Even basic "on error resume next", like in classic VB/VBA, would be an improvement, or full try/catch like every other modern language. 
Thoughts?

Print this item

Question <solved> QB64 without its IDE GUI ?
Posted by: Fifi - 01-06-2023, 06:32 PM - Forum: General Discussion - Replies (28)

Hello all,

First of all receive my best wishes for this new year 2023.

Some time ago, I had seen somewhere (I think here) a topic with the title "QB64 without GUI" as project.

Can anyone direct me to this topic?

Moreover, is the QB64PE code sufficiently well documented to quickly and easily remove all the code necessary for the IDE, leaving only the translation in C++, the compilation part and the error messages (and maybe the line numbers concerned) as return in the event of a compilation error?

The goal of such an operation being to produce the smallest possible executable for an embedded system.

The first target would be on a framework of Linux system but I guess that could also be used on OS/X and maybe Windows on tiny computer such as the Pi platform.

Thanks in advance for any suggestions on this subject.

Happy new year 2023.

Print this item