Drawing Tools Subs or Functions with Demo

[bplus]

Vince Image to Sphere fix by bplus

Code: (Select All)

_Title "Vince sphere hold mouse for grid then drag mouse to rotate, wheel to zoom." 'bplus mod vince code 2025-02-09

DefDbl A-Z

Dim Shared pi, p, q, uu, vv



zoom = 200



sw = 800

sh = 600



Screen _NewImage(sw, sh, 32)



'img = _LoadImage("Worldmap.png")

img = _LoadImage("bluemarble_small.png")

w = _Width(img)

h = _Height(img)



pi = 4 * Atn(1)

du = 2 * pi / 24

dv = pi / 14



vv = -pi / 6



drag = 0



_Source img

_Dest 0





Do

    oz = zoom

    Do

        mx = _MouseX

        my = _MouseY

        mb = _MouseButton(1)

        zoom = zoom - 10 * _MouseWheel

    Loop While _MouseInput

    Cls



    'uu = uu + 0.01

    'vv = vv + 0.01





    If mb And drag = 1 Then

        uu = (mx - omx) * pi / sh ' from -mx

        vv = (my - omy) * pi / sh

    End If



    If mb And drag = 0 Then

        omx = mx

        omy = my

        drag = 1

    End If



    If mb = 0 And drag = 1 Then

        drag = 0

    End If



    For v = -pi / 2 To pi / 2 - .5 / zoom Step 1 / zoom '3/zoom    ' bplus fix

        For u = 0 To 2 * pi - .5 / zoom Step 1 / zoom ' 3/zoom    ' bplus fix

            r = Cos(v)

            z = Sin(v)

            x = r * Cos(u)

            y = r * Sin(u)



            xx = x

            yy = y

            zz = z



            rotz x, y, z, uu

            rotx x, y, z, vv



            sx = 0

            sy = -1

            sz = 0



            proj xx, yy, zz

            pp = sw / 2 + zoom * p

            qq = sh / 2 - zoom * q

            If pp > 0 And pp < sw And qq > 0 And qq < sh Then



                If (x * sx + y * sy + z * sz) < 0 Then



                    Dim c As _Unsigned Long

                    cx = (w * u / (2 * pi)) Mod w

                    cy = (h - h * (v + pi / 2) / pi) Mod h

                    c = Point(cx, cy)



                    PSet (sw / 2 - zoom * p, sh / 2 - zoom * q), c ' bplus fix  +zoom in x

                End If

            End If



        Next

    Next





    If drag Or (zoom <> oz) Then

        For v = 0 To 2 * pi Step dv

            For u = 0 To 2 * pi Step du



                r = Cos(v)

                z = Sin(v)

                x = r * Cos(u)

                y = r * Sin(u)



                rotz x, y, z, uu

                rotx x, y, z, vv



                sx = 0

                sy = -1

                sz = 0



                Color _RGB(100, 100, 100)

                If (x * sx + y * sy + z * sz) < 0 Then

                    r = Cos(v)

                    proj r * Cos(u), r * Sin(u), Sin(v)

                    PSet (sw / 2 + zoom * p, sh / 2 - zoom * q)



                    proj r * Cos(u + du), r * Sin(u + du), Sin(v)

                    Line -(sw / 2 + zoom * p, sh / 2 - zoom * q)



                    r = Cos(v + dv)

                    proj r * Cos(u + du), r * Sin(u + du), Sin(v + dv)

                    Line -(sw / 2 + zoom * p, sh / 2 - zoom * q)



                    proj r * Cos(u), r * Sin(u), Sin(v + dv)

                    Line -(sw / 2 + zoom * p, sh / 2 - zoom * q)



                    r = Cos(v)

                    proj r * Cos(u), r * Sin(u), Sin(v)

                    Line -(sw / 2 + zoom * p, sh / 2 - zoom * q)

                End If



            Next

        Next

    End If



    _Limit 30

    _Display

Loop Until _KeyHit = 27

Sleep

System



Sub proj (x, y, z)

    'p = x + 0.707*y

    'q = z + 0.707*y



    rotz x, y, z, uu

    rotx x, y, z, vv





    d = 10

    p = x * d / (10 + y)

    q = z * d / (10 + y)

End Sub



Sub rotx (x, y, z, a)

    xx = x

    yy = y * Cos(a) - z * Sin(a)

    zz = y * Sin(a) + z * Cos(a)



    x = xx

    y = yy

    z = zz

End Sub



Sub roty (x, y, z, a)

    xx = x * Cos(a) + z * Sin(a)

    yy = y

    zz = -x * Sin(a) + z * Cos(a)



    x = xx

    y = yy

    z = zz

End Sub



Sub rotz (x, y, z, a)

    xx = x * Cos(a) - y * Sin(a)

    yy = x * Sin(a) + y * Cos(a)

    zz = z



    x = xx

    y = yy

    z = zz

End Sub

Using bluemarble_small.png (zip file)