QB64 Phoenix Edition
Planet View - Printable Version

+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Programs (https://staging.qb64phoenix.com/forumdisplay.php?fid=7)
+---- Thread: Planet View (/showthread.php?tid=858)

Pages: 1 2

RE: Planet View - bplus - 09-10-2022

@dbox

I have code down to an error about a token, but where? what line is it finding this?
I got rid of &'s and then the GOSUB, still has a problem.

All I think of is the Function GrowCheese was supposed to return a long type but without & can't do it

This code still works fine in QB64pe, Almost QBJS acceptable (I think):
Code: (Select All)
_Title "Cheese + Sphere = Moon" 'b+ 2022-05-20
Randomize Timer
Const wW = 1280, wH = 720
Screen _NewImage(wW, wH, 32)
'_ScreenMove 80, 0
'_MouseHide
Dim stars As Long
stars = _LoadImage("stars.png")
Dim map(1 To 2) As Long
For i = 1 To 2
    map(i) = growCheese
    _PutImage , map(i), 0
Next
Do While _KeyDown(27) = 0
    Cls
    For i = 1 To 2
        Select Case i
            Case 1: x = 300: y = 175: rr = 120
            Case 2: x = 900: y = 500: rr = 350
            Case 3: x = 1175: y = 525: rr = 90
            Case 4: x = 300: y = 540: rr = 151
        End Select
        xoff = (_Width(map(i)) + xoff - _Height(map(i)) / 360) Mod _Width(map(i))
        projectImagetoSphere map(i), x, y, rr, xoff
    Next
    _Display
    _Limit 60
Loop

Sub projectImagetoSphere (image, x0, y0, sr, xo)
    Dim pc As _Unsigned Long
    r = _Height(image) / 2
    iW = _Width(image) - 20
    iH = _Height(image)
    scale = sr / r
    For y = -r To r
        x1 = Sqr(r * r - y * y)
        tv = (_Asin(y / r) + 1.5) / 3
        For x = -x1 + 1 To x1
            tu = (_Asin(x / x1) + 1.5) / 6
            _Source image
            pc = Point((xo + tu * iW) Mod iW, tv * iH)
            _Dest 0
            PSet (x * scale + x0, y * scale + y0), pc
        Next x
    Next y
End Sub


Function growCheese () 'make this more self contained than first version, all hole stuff just in here
    Dim As Long curr, map
    curr = _Dest
    map = _NewImage(wW, wH, 32)
    _Dest map
    nHoles = Rnd * 200 + 50: maxHoleLife = 10: maxHoleRadius = Rnd * 10 + 7: tfStart = 1
    Dim hx(nHoles), hy(nHoles), hLife(nHoles)
    For i = 1 To nHoles
        hx(i) = wW * Rnd
        hy(i) = wH * Rnd
        If tfStart Then hLife(i) = Int(Rnd * maxHoleLife) Else hLife(i) = 1
    Next
    r = Rnd * 155 + 100: g = Rnd * 255: b = Int(Rnd * 2) * (Rnd * 155 + 100)
    tfStart = 0
    For layr = 1 To 30
        Line (0, 0)-(wW, wH), _RGBA32(r, g, b, 50), BF 'layer of cheese
        For i = 1 To nHoles 'holes in layer
            If hLife(i) + 1 > maxHoleLife Then
                hx(i) = wW * Rnd
                hy(i) = wH * Rnd
                If tfStart Then hLife(i) = Int(Rnd * maxHoleLife) Else hLife(i) = 1
            Else
                hLife(i) = hLife(i) + 1
            End If
            hx(i) = hx(i) + Rnd * 2 - 1
            hy(i) = hy(i) + Rnd * 2 - 1
            If hLife(i) < maxHoleRadius Then
                radius = hLife(i)
            ElseIf maxHoleLife - hLife(i) < maxHoleRadius Then
                radius = maxHoleLife - hLife(i)
            Else
                radius = maxHoleRadius
            End If
            Color _RGBA32(0, 0, 0, 80)
            fcirc hx(i), hy(i), radius
        Next
    Next
    _Dest curr
    growCheese = map
End Function

'Steve McNeil's  copied from his forum   note: Radius is too common a name
Sub fcirc (CX As Long, CY As Long, R As Long)
    Dim subRadius As Long, RadiusError As Long
    Dim X As Long, Y As Long

    subRadius = Abs(R)
    RadiusError = -subRadius
    X = subRadius
    Y = 0

    If subRadius = 0 Then PSet (CX, CY): Exit Sub

    ' Draw the middle span here so we don't draw it twice in the main loop,
    ' which would be a problem with blending turned on.
    Line (CX - X, CY)-(CX + X, CY), , 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), , BF
                Line (CX - Y, CY + X)-(CX + Y, CY + X), , BF
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        Line (CX - X, CY - Y)-(CX + X, CY - Y), , BF
        Line (CX - X, CY + Y)-(CX + X, CY + Y), , BF
    Wend
End Sub


Nope, still allot more stuff to change eg, get rid of BF's that only draw lines or is it the , ,BF it doesn't like?
Everything Dim'd and still problems with code that runs fine in QB64 PE

Code: (Select All)
Option _Explicit
_Title "Cheese + Sphere = Moon" 'b+ 2022-05-20
Randomize Timer
Const wW = 1280, wH = 720
Screen _NewImage(wW, wH, 32)
'_ScreenMove 80, 0
'_MouseHide
Dim As Long stars, i
stars = _LoadImage("stars.png")
Dim map(1 To 2) As Long
For i = 1 To 2
    map(i) = growCheese
    _PutImage , map(i), 0
Next
Dim As Long xoff, x, y, rr
Do While _KeyDown(27) = 0
    Cls
    For i = 1 To 2
        Select Case i
            Case 1: x = 300: y = 175: rr = 120
            Case 2: x = 900: y = 500: rr = 350
            Case 3: x = 1175: y = 525: rr = 90
            Case 4: x = 300: y = 540: rr = 151
        End Select
        xoff = (_Width(map(i)) + xoff - _Height(map(i)) / 360) Mod _Width(map(i))
        projectImagetoSphere map(i), x, y, rr, xoff
    Next
    _Display
    _Limit 60
Loop

Sub projectImagetoSphere (image, x0, y0, sr, xo)
    Dim pc As _Unsigned Long
    Dim r, iW, IH, y, x
    Dim scale, x1, tv, tu
    r = _Height(image) / 2
    iW = _Width(image) - 20
    IH = _Height(image)
    scale = sr / r
    For y = -r To r
        x1 = Sqr(r * r - y * y)
        tv = (_Asin(y / r) + 1.5) / 3
        For x = -x1 + 1 To x1
            tu = (_Asin(x / x1) + 1.5) / 6
            _Source image
            pc = Point((xo + tu * iW) Mod iW, tv * IH)
            _Dest 0
            PSet (x * scale + x0, y * scale + y0), pc
        Next x
    Next y
End Sub

Function growCheese () 'make this more self contained than first version, all hole stuff just in here
    Dim As Long curr, map, nHoles, maxHoleLife, maxHoleRadius, tfStart, i, r, g, b, layr, radius

    curr = _Dest
    map = _NewImage(wW, wH, 32)
    _Dest map
    nHoles = Rnd * 200 + 50: maxHoleLife = 10: maxHoleRadius = Rnd * 10 + 7: tfStart = 1
    Dim hx(nHoles), hy(nHoles), hLife(nHoles)
    For i = 1 To nHoles
        hx(i) = wW * Rnd
        hy(i) = wH * Rnd
        If tfStart Then hLife(i) = Int(Rnd * maxHoleLife) Else hLife(i) = 1
    Next
    r = Rnd * 155 + 100: g = Rnd * 255: b = Int(Rnd * 2) * (Rnd * 155 + 100)
    tfStart = 0
    For layr = 1 To 30
        Line (0, 0)-(wW, wH), _RGBA32(r, g, b, 50), BF 'layer of cheese
        For i = 1 To nHoles 'holes in layer
            If hLife(i) + 1 > maxHoleLife Then
                hx(i) = wW * Rnd
                hy(i) = wH * Rnd
                If tfStart Then hLife(i) = Int(Rnd * maxHoleLife) Else hLife(i) = 1
            Else
                hLife(i) = hLife(i) + 1
            End If
            hx(i) = hx(i) + Rnd * 2 - 1
            hy(i) = hy(i) + Rnd * 2 - 1
            If hLife(i) < maxHoleRadius Then
                radius = hLife(i)
            ElseIf maxHoleLife - hLife(i) < maxHoleRadius Then
                radius = maxHoleLife - hLife(i)
            Else
                radius = maxHoleRadius
            End If
            Color _RGBA32(0, 0, 0, 80)
            fcirc hx(i), hy(i), radius
        Next
    Next
    _Dest curr
    growCheese = map
End Function

'Steve McNeil's  copied from his forum   note: Radius is too common a name
Sub fcirc (CX As Long, CY As Long, R As Long)
    Dim subRadius As Long, RadiusError As Long
    Dim X As Long, Y As Long

    subRadius = Abs(R)
    RadiusError = -subRadius
    X = subRadius
    Y = 0

    If subRadius = 0 Then PSet (CX, CY): Exit Sub

    ' Draw the middle span here so we don't draw it twice in the main loop,
    ' which would be a problem with blending turned on.
    Line (CX - X, CY)-(CX + X, CY)

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

Code: (Select All)
WARN    :    1    :    Missing or unsupported method: 'Option' - ignoring line
ERROR    :    26    :    
Cannot read properties of undefined (reading 'toString')
TypeError: Cannot read properties of undefined (reading 'toString')
    at Object.toString (https://qbjs.org/qb.js:545:40)
    at isNaN ()
    at _color (https://qbjs.org/qb.js:801:19)
    at Object.sub_PSet (https://qbjs.org/qb.js:1815:21)
    at sub_projectImagetoSphere (eval at runProgram (https://qbjs.org/:100:30), :66:13)
    at eval (eval at runProgram (https://qbjs.org/:100:30), :42:16)
    at async runProgram (https://qbjs.org/:356:17)


RE: Planet View - dbox - 09-10-2022

Hey @bplus, that’s interesting, I’ll have to look further when I can get back in front of a computer.

RE: Planet View - dbox - 09-11-2022

Well I got it to run by changing line 46 to:
Code: (Select All)
            pc = Point(Fix((xo + tu * iW) Mod iW), Fix(tv * IH))

Looks like I need to update the Point method to make sure it is converting any floating point numbers to integers.

This is also another good one to add to my list of candidates to test performance enhancement.  It runs, but the processing is taking so long per frame that it is causing a flicker in the rendering.

View on QBJS

RE: Planet View - bplus - 09-11-2022

(09-11-2022, 03:45 AM)dbox Wrote: Well I got it to run by changing line 46 to:
Code: (Select All)
            pc = Point(Fix((xo + tu * iW) Mod iW), Fix(tv * IH))

Looks like I need to update the Point method to make sure it is converting any floating point numbers to integers.

This is also another good one to add to my list of candidates to test performance enhancement.  It runs, but the processing is taking so long per frame that it is causing a flicker in the rendering.

View on QBJS

Good, so POINT at present needs Integers OK. I should start writing this stuff down. Thanks for checking and getting back.

RE: Planet View - James D Jarvis - 09-12-2022

Mmmmm... cheese.

RE: Planet View - bplus - 09-12-2022

@James D Jarvis  here is another version but has a problem with the seam, maybe if the image were lengthened with a mirror image?
Code: (Select All)
_Title "Contour Plot 3S: spacebar for New World, escape to quit" 'b+ trans from SdlBasic to QB64, original from QB64.net
' 2021-11-17 Contour Plot 3: planets
' 2021-11-18 3S try adding shade

' Contour plot using Data Points by Mrwhy
'ref: SdlBasic forum, AndyA, 9-13-2016  http://sdlbasic.epizy.com/showthread.php?tid=302
' AndyA ref:
'http://www.qb64.net/forum/index.php?topic=3714.msg37019#msg37019
'https://en.wikipedia.org/wiki/Richard_V._Southwell
'https://en.wikipedia.org/wiki/Relaxation_(iterative_method)

Dim Shared sw, sh, nC, nP
sw = 800: sh = 400: nC = 32: nP = 12 ' screen Width and Height, number of Colors, number of Points
Screen _NewImage(sw, sh, 32)
_ScreenMove 200, 60 ' at least 60 on each side and to and bottom
_PrintMode _KeepBackground
ReDim Shared pal(nC) As _Unsigned Long, x(50), y(50), z(100), E(50), h(sw, sh)

'color mixing green blue
For i = 1 To nC
    pal(i) = _RGB32(0, i * 255 / nC, 128 / nC * (nC - i))
Next

restart:
ReDim h(sw, sh)
Cls
For i = 1 To nP ' new data points and color assignments
    x(i) = Int((sw - 30) * Rnd + 15): y(i) = Int((sh - 30) * Rnd + 15): z(i) = Int(Rnd * (nC - 2) + 1)
Next
ztot = 0
'display height or potential data points on screen
For i = 1 To nP
    fcirc x(i), sh - y(i), 3, pal(z(i))
    ztot = ztot + z(i)
Next

Color &HFFFFFF40
_Font 8

s$ = "Calculating Contour Map"
x = (_Width - _PrintWidth(s$)) / 2
_PrintString (x, _Height - 14), s$
Line (x - 4, _Height - 18)-(x + _PrintWidth(s$) + 2, _Height - 2), , B

'initialize some variables
zmean = ztot / nP
wo = sw * sh / nP
w = wo / 2

'generate initial Error estimates
For i = 1 To nP
    E(i) = z(i) - zmean
Next
'Legend

'begin Relaxation (iterative method)
For jj = 1 To 9 * nP 'find max error point
    emax = 0
    For i = 1 To nP
        If Abs(E(i)) > emax Then
            emax = Abs(E(i))
            ii = i
        End If
        k = E(ii)
    Next
    'fixit
    For i = 1 To nP
        dx = x(i) - x(ii)
        dy = y(i) - y(ii)
        dsq = dx * dx + dy * dy
        E(i) = E(i) - k * Exp(-(dsq / w))
        If i = ii Then
            'update map with revised height or potential estimates for each pixel
            For fy = 1 To (sh - 1)
                For fx = 1 To (sw - 1)
                    dx = fx - x(ii)
                    dy = fy - y(ii)
                    dsq2 = dx * dx + dy * dy
                    dy = sh - fy
                    h(fx, dy) = h(fx, dy) + k * Exp(-(dsq2 / w))
                Next
            Next
        End If
    Next
Next

'Draw calculated contour map
Color pal(h(1, 1) + zmean)
Line (0, 0)-(sw - 1, 0)
Line (0, 0)-(0, sh - 1)
For fy = 1 To sh - 1
    For fx = 1 To sw - 1
        If Int(h(fx, fy) + zmean) > nC Then
            c~& = pal(nC)
        ElseIf Int(h(fx, fy) + zmean) < 1 Then
            c~& = pal(1)
        Else
            c~& = pal(Int(h(fx, fy) + zmean))
        End If
        PSet (fx, fy), c~&
    Next
Next

'display height or potential data points on contour map
'For i = 1 To nP
'    'fcirc x(i), sh - y(i), 3, &HFF000000
'    fcirc x(i), sh - y(i), 2, pal(z(i))
'Next
'Legend

surface& = _NewImage(_Width, _Height, 32)
mid = Int(sw / 2)
_PutImage (mid - 2, 0)-(sw - 1, sh), 0, surface&
_PutImage (0, 0)-(mid + 2, sh), 0, surface&, (sw - 1, 0)-(0, sh)
_PutImage , surface&, 0
For y = 0 To sh ' fix seam !
    PSet (mid + 2, y), Point(mid - 1, y)
    PSet (mid + 1, y), Point(mid - 1, y)
    PSet (mid, y), Point(mid - 1, y)
Next
_PutImage , 0, surface&
Cls
'_PutImage , surface&, 0  'check

Color &HFF000000 ' be rid of white points at poles
r = sh / 2.5: xc = sw / 2: yc = sh / 2: xo = 0: sr = 200
Do
    For y = -r To r
        x1 = Sqr(r * r - y * y)
        tv = (_Asin(y / r) + 1.5) / 3
        For x = -x1 + 1 To x1
            tu = (_Asin(x / x1) + 1.5) / 6
            _Source surface&
            pc~& = Point((xo + tu * (sw - 1)) Mod sw, tv * sh)
            _Dest 0
            dist = (x * x + y * y) / (r * r) ' for shading
            PSet (x + xc, y + yc), pc~&
            PSet (x + xc, y + yc), _RGBA32(0, 0, 0, 180 * (dist ^ 2)) ' for shading
        Next x
    Next y
    xo = xo - 1 + sw
    xo = xo Mod sw
    If (nC + 1) * 12 <= sh Then Legend
    _Display
    _Limit 30
Loop Until _KeyDown(32) Or _KeyDown(27)
_FreeImage surface&
If _KeyDown(32) Then GoTo restart


'show height or potential value for each color in map
Sub Legend
    posy = 12
    ' just draw a balck box where legend is going
    Line (0, 0)-(37, (nC + 1) * 12), &HFFFF0000, BF
    Line (1, 1)-(36, (nC + 1) * 12 - 2), &HFFFFFF00, B
    Color &HFFFFFF00
    _Font 8
    _PrintString (7, 3), "Key"
    For nn = 1 To nC
        _PrintString (4, posy), Right$(" " + _Trim$(Str$(nn)), 2)
        Line (21, posy + 1)-(32, posy + 5), pal(nn), BF
        posy = posy + 12
    Next
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

   

RE: Planet View - bplus - 09-12-2022

Oh here as an older one, move mouse and change "tunnels" on this crazy satellite:
Code: (Select All)
_Title "Move your mouse" + Space$(53) + "Satellite" 'B+ post 2019-01-10

Const xmax = 600
Const ymax = 600
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 300, 60
map& = _NewImage(xmax, ymax, 32)
'stars& = _LoadImage("stars.png")
r = ymax / 2.5: xc = xmax / 2: yc = ymax / 2: xo = 0
_MouseHide

While _KeyHit <> 27
    While _MouseInput: Wend
    mx = _MouseX / xmax: my = _MouseY / ymax
    _Dest map&
    Color , _RGB32(68, 68, 68): Cls
    For y = 0 To ymax Step 100
        For x = 0 To xmax Step 100
            tct x + 3, y + 3, 94, 94, mx, my
        Next
    Next
    '_PutImage , stars&, 0
    For y = -r To r
        x1 = Sqr(r * r - y * y)
        tv = (_Asin(y / r) + 1.5) / 3
        For x = -x1 + 1 To x1
            tu = (_Asin(x / x1) + 1.5) / 6
            _Source map&
            pc~& = Point((xo + tu * xmax) Mod xmax, tv * ymax)
            _Dest 0
            PSet (x + xc, y + yc), pc~&
        Next x
    Next y
    xo = xo - 1 + xmax
    xo = xo Mod xmax
    _Display
    _Limit 10
Wend

Sub tct (x, y, w, h, fx, fy)
    mx = fx * w
    my = fy * h
    dlx = (mx - 1) / 10: drx = (w - mx - 1) / 10: dty = (my - 1) / 10: dby = (h - my - 1) / 10
    tx = 0: ty = 0
    For i = 10 To 1 Step -1
        Line (x + mx - i * dlx, y + my - i * dty)-(x + mx + i * drx, y + my + i * dby), _RGB32(5 * i, 10 * i, 15 * i), BF
    Next
    Color _RGBA32(155, 140, 40, 120)
    xx = x + w - mx: yy = y + h - my
    PSet (xx, yy)
    tx = 0: ty = 0
    While tx < w - drx - dlx
        tx = tx + drx
        Line -Step(-tx, 0)
        ty = ty + dby
        Line -Step(0, -ty)
        tx = tx + dlx
        Line -Step(tx, 0)
        ty = ty + dty
        Line -Step(0, ty)
    Wend
    Lightning x + mx, y + my, xx, yy, h
End Sub

Sub Lightning (x1, y1, x2, y2, d)
    If d < 5 Then
        Color _RGB(225, 225, 245)
        Line (x1, y1)-(x2, y2)
    Else
        mx = (x2 + x1) / 2
        my = (y2 + y1) / 2
        mx = mx + -.5 * Rnd * d * .4 * rand&&(-2, 2)
        my = my + -.5 * Rnd * d * .4 * rand&&(-2, 2)
        Lightning x1, y1, mx, my, d / 2
        Lightning x2, y2, mx, my, d / 2
    End If
End Sub

Function rand&& (lo&&, hi&&)
    rand&& = Int(Rnd * (hi&& - lo&& + 1)) + lo&&
End Function

   

RE: Planet View - James D Jarvis - 09-13-2022

When manually drawing tiles I mirror opposite sides of the image to each side of the image but I don't do it evenly and then I add a couple extra non-reflected but contiguous details across the seam to break up the butterfly look that can happen when an image is mirrored. The trick here is in selecting what is mirrored when not doing it manually. A variable area of reflection per scan line will work but will end up with a jagged edge unless the image is very low contrast overall.