Thread Rating:
  • 1 Vote(s) - 5 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Drawing Tools Subs or Functions with Demo
#41
(09-07-2024, 12:51 AM)bplus Wrote: @TerryRitchie the escape worked fine in your demo but when I tried

while _keydown(27) = 0

to loop the rotation of the checkered glode it would not draw anytyhing.

This is my mod of your code included in the zip. I rotated the checkered globe like the first worldmap globe to check speed for one thing and to see how easy it was to adopt your version image2sphere for another reason.

The checkerboard image is square. If you want to rotate it you'll need to change the code to make the image twice as wide.

Edit: oops, that's only if you need something like a globe of Mars or Earth for instance. Never mind, getting late, tired.
New to QB64pe? Visit the QB64 tutorial to get started.
QB64 Tutorial
Reply
#42
I have dived deeper into this rabbit hole and come up with even faster (much faster) code for the fake sphere mapping.

This time the code creates a precalculated x coordinate translation array which removes the need to calculate latitude and longitude coordinates every time the sphere is redrawn. Next, the translation array and images are all handled in memory using _MEM commands for speed.

I'm getting very close to 100 frames per second rotating a 953x953 sphere!

I'm exploring ways of turning this proof on concept code into a workable subroutine or function.

The downside to this approach is that the map image needs to be doubled in width. Essentially two of the images need to be next to each other since there is no way to do what MOD is performing in the previous code above. I'm exploring ways of overcoming this as well, perhaps through some clever memory address manipulation.

The ZIP file below contains the world map image that is 954 pixels high.

Code: (Select All)
' Fake Sphere Mapping
'
' Proof of concept using a precalculated x coordinate translation array and _MEM memory buffers.
' This demo achieves almost 100 frames per second creating and rotating a 953x953 spehere.
' This was achieved on an older test system running an i7-6700K at 4Ghz.
' Results on more modern equipment should be even more impressive.

OPTION _EXPLICIT

DIM imageWidth AS INTEGER '     width of initial image
DIM imageHeight AS INTEGER '    height of initial image
DIM baseImage AS LONG '         initial image (temporary)
DIM image AS LONG '             working image (2 base images next to each other)
DIM sphere AS LONG '            output image
DIM Mapx AS INTEGER '           calculation map x coordinate
DIM x AS INTEGER '              horizontal counter
DIM y AS INTEGER '              vertical counter
DIM xOffset AS INTEGER '        horizontal drawing offset within image
DIM mMap AS _MEM '              texture map x coordinate array
DIM mMapOffset AS _OFFSET '     memory location of calculation map array
DIM mImage AS _MEM '            image array
DIM mImageOffset AS _OFFSET '   memory location of image array
DIM mSphere AS _MEM '           sphere output image array
DIM mSphereOffset AS _OFFSET '  memory location of sphere output image array
DIM Pixel AS _UNSIGNED LONG '   image pixel

baseImage = _LOADIMAGE("worldmap2.png", 32) '                                load image to map
imageWidth = _WIDTH(baseImage) '                                             record image width
imageHeight = _HEIGHT(baseImage) '                                           record image height
image = _NEWIMAGE(imageWidth * 2, imageHeight, 32) '                         create texture image (2 base images side by side)
_PUTIMAGE (0, 0), baseImage, image '                                         draw first image onto texture image
_PUTIMAGE (imageWidth, 0), baseImage, image '                                draw second image onto texture image
_FREEIMAGE baseImage '                                                       map image no longer needed
mImage = _MEMIMAGE(image) '                                                  create image array in memory from texture image
sphere = _NEWIMAGE(imageHeight, imageHeight, 32) '                           create image array in memory from output image
mMap = _MEMNEW(imageHeight * imageHeight * 2) '                              create texture map x coordinate array in memory
mSphere = _MEMIMAGE(sphere) '                                                create sphere array in memory
SCREEN _NEWIMAGE(imageHeight, imageHeight, 32) '                             screen same height as output image
initMapPos '                                                                 create texture map x coordinate array
xOffset = 0 '                                                                reset image x offset
DO '                                                                         begin demo
    $CHECKING:OFF
    y = 0 '                                                                  reset vertical counter
    DO '                                                                     begin vertical loop
        mMapOffset = mMap.OFFSET + (y * imageHeight * 2) '                   start memory location of horizontal line within map
        mSphereOffset = mSphere.OFFSET + (y * imageHeight * 4) '             start memory location of horizontal line within sphere
        mImageOffset = mImage.OFFSET + (y * imageWidth * 8) '                start memory location of horizontal line within image
        x = 0 '                                                              reset horizontal counter
        DO '                                                                 begin horizontal loop
            _MEMGET mMap, mMapOffset + (x * 2), Mapx '                       get x texture coordinate
            IF Mapx <> -1 THEN '                                             valid coordinate?
                _MEMGET mImage, mImageOffset + (Mapx + xOffset) * 4, Pixel ' yes, get pixel from image
                _MEMPUT mSphere, mSphereOffset + (x * 4), Pixel '            apply pixel to output image
            END IF
            x = x + 1 '                                                      increment horizontal counter
        LOOP UNTIL x = imageHeight '                                         leave when entire horizontal line processed
        y = y + 1 '                                                          increment vertical counter
    LOOP UNTIL y = imageHeight '                                             leave when entire vertical line processed
    xOffset = xOffset + 1 '                                                  increment image x offset
    IF xOffset > imageWidth - 1 THEN xOffset = 0 '                           reset image x offset when needed
    _PUTIMAGE (0, 0), sphere '                                               display output image
    _DISPLAY '                                                               update screen with changes
    '_LIMIT 60
    $CHECKING:ON
LOOP UNTIL _KEYDOWN(27) '                                                    leave demo when ESC pressed
_MEMFREE mMap '                                                              free memory assets
_MEMFREE mSphere
_MEMFREE mImage
_FREEIMAGE image '                                                           free image assets
_FREEIMAGE sphere
SYSTEM '                                                                     return to operating system


'-----------------------------------------------------------------------------------------------------------------------------------------+
SUB initMapPos () '                                                                                                                       |
    '+------------------------------------------------------------------------------------------------------------------------------------+
    '| Create an x coordinate translation array so latitude and longitude calculations only need to be peformed once.                     |
    '+------------------------------------------------------------------------------------------------------------------------------------+

    CONST HALFPI = _PI * .5 '         half of Pi
    CONST rPI = 1 / _PI '             Pi reciprocated
    SHARED imageWidth AS INTEGER '    need width of image
    SHARED imageHeight AS INTEGER '   need height of image
    SHARED mMap AS _MEM '             need access to texture map x coordinate array
    DIM radius AS SINGLE '            sphere radius
    DIM Index AS _UNSIGNED LONG '     array memory offset for each value
    DIM sLongitude AS SINGLE '        sine longitude calculation
    DIM longitude AS SINGLE '         longitude calculation
    DIM x AS INTEGER '                horizontal counter
    DIM y AS INTEGER '                vertical counter

    radius = imageHeight * .5 '                                                        calculate sphere radius
    y = 0 '                                                                            reset vertical counter
    DO '                                                                               begin vetical loop
        x = 0 '                                                                        reset horizontal counter
        DO '                                                                           begin horizontal loop
            Index = (y * imageHeight + x) * 2 '                                        value memory location
            sLongitude = (x - radius) / (radius * COS(_ASIN((y - radius) / radius))) ' calculate sine longitude of pixel
            IF sLongitude >= -1 AND sLongitude <= 1 THEN '                             is pixel inside the circle?
                longitude = _ASIN(sLongitude) + HALFPI '                               yes, complete longitude calculation
                _MEMPUT mMap, mMap.OFFSET + Index, (longitude * imageWidth * .5) * rPI AS INTEGER ' store corresponding image x coordinate
            ELSE '                                                                     no, pixel is outside of circle
                _MEMPUT mMap, mMap.OFFSET + Index, -1 AS INTEGER '                     mark x coordinate as outside of circle
            END IF
            x = x + 1 '                                                                increment horizontal counter
        LOOP UNTIL x = imageHeight '                                                   leave when entire horizontal line processed
        y = y + 1 '                                                                    increment vertical counter
    LOOP UNTIL y = imageHeight '                                                       leave when entire vertical line processed

END SUB


Attached Files
.zip   Worldmap2.zip (Size: 373.14 KB / Downloads: 14)
New to QB64pe? Visit the QB64 tutorial to get started.
QB64 Tutorial
Reply
#43
check out this mod, B+, drag mouse and use mousewheel

Code: (Select All)

defdbl a-z
dim shared pi, p, q, uu, vv

zoom = 200

sw = 800
sh = 600

screen _newimage(sw, sh, 32)

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
        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 step 3/zoom
        for u=0 to 2*pi step 3/zoom
            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
            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


Attached Files Image(s)
   
Reply
#44
+1 @vince allot of nice features you have, rotate glode all 3 axis and use mousewheel to expand and shrink. All the black lines and interferrence patterns detract from image though:
   

I tried Worldmap image from our previous posts, true the image does not have great contrast but lines drown image:
   

Wait... did that get reversed???
b = b + ...
Reply
#45
maybe try this mod, B+

Code: (Select All)

defdbl a-z
dim shared pi, p, q, uu, vv

zoom = 350

sw = 1024
sh = 768

screen _newimage(sw, sh, 32)

img = _loadimage("bluemarble_small.png")
'img = _loadimage("mars_huge.png")
w = _width(img)
h = _height(img)

pi = 4*atn(1)
du = 2*pi/24
dv = pi/14

uu = pi
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
        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 step 0.001
        for u=0 to 2*pi step 0.001
            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 - 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
            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

i will eventually invert the coordinate systems to get pixel by pixel rendering but it will be so slow per frame, im not yet sure how to approach it, maybe a qbjs solution
Reply
#46
Sorry I ran out of time for playing.

I want to try this, vince's, and Terry's and rotozoom a disk at all sorts of angles Smile
b = b + ...
Reply
#47
I have revised my PieSlice drawing tools towards Steve's method only mine goes CW around the Center Point like the rest of the Trig Functions in Basic (but unlike an arc drawn with Circle Sub). In Basic Trig Functions angles increase around center point in Clockwise (CW) direction from East = 0 degrees/radians.

Code: (Select All)
' bplus mod to Steve way of coding 2024-10-13 but for East = 0 And CW arcs 10-14 rev Fill Paint tests
Sub PieSlice (CX As Long, CY As Long, R As Long, RAStart!, RAEnd!, C As _Unsigned Long, Fill As Long)
    Dim As Long x, y, x1, y1, xt, yt
    Dim As Single i, REnd ' rend to copy RAEnd! before changing value
    If RAStart! > RAEnd! Then REnd = RAEnd! + _Pi * 2 Else REnd = RAEnd! ' rev 10-14
    x1 = Cos(RAStart!) * R
    y1 = Sin(RAStart!) * R
    Line (CX, CY)-Step(x1, y1), C
    For i = RAStart! To REnd Step _D2R(Sgn(REnd - RAStart!))
        x = Cos(i) * R
        y = Sin(i) * R
        Line -(CX + x, CY + y), C
        If x <> x1 And y <> y1 And xt = 0 Then 'choose a point inside the arc to fill
            xt = CX + Cos(i) * R / 2
            yt = CY + Sin(i) * R / 2
        End If
    Next
    Line -(CX, CY), C
    If xt <> 0 And Fill <> 0 Then Paint (xt, yt), C ' rev 10-14  don't Paint unless found a free pixel inside slice
    'Circle ( xt,  yt), c
End Sub

Demo comparing Steve's Math Graph and mine consistent with Basic Funbctions and Screen Y axis:
Code: (Select All)
Option _Explicit
_Title "PieSlice Tests with Steve coding" ' bplus 2024-10-13 rev 10-14 option _explicit and paint test
$Color:32
Screen _NewImage(1200, 600, 32)
_ScreenMove 40, 60
Dim degree10, xc1, xc, yc, xc2, r, a, x1, y1, at, sa$, xoff, yoff, x2, y2
degree10 = _Pi(2 / 36) ' like hours on clock
xc1 = 300: xc2 = 900: yc = 300: r = 200
_PrintString (xc1 - _PrintWidth("CW  Regular East = 0 Deg/Rads Calcs") / 2, 292), "CW  Regular East = 0 Deg/Rads Calcs"
_PrintString (xc2 - _PrintWidth("CCW Steve's East = 0 Deg/Rads Calcs") / 2, 292), "CCW Steve's East = 0 Deg/Rads Calcs"

For a = 0 To _Pi(1.999) Step degree10

    ' Regular East = 0 calcs
    x1 = xc1 + r * Cos(a)
    y1 = yc + r * Sin(a)
    at = Int(_R2D(_Atan2(y1 - yc, x1 - xc1)) + .0001)
    If at < 0 Then at = at + 360
    sa$ = _Trim$(Str$(at))
    xoff = _PrintWidth(sa$) / 2
    yoff = 16 / 2
    _PrintString (x1 - xoff, y1 - yoff), sa$

    ' East = 0 calcs but Counter Clockwise
    x2 = xc2 + r * Sin(a + _Pi / 2)
    y2 = yc + r * Cos(a + _Pi / 2)
    at = Int(AtanSteve(xc2, yc, x2, y2))
    sa$ = _Trim$(Str$(at))
    xoff = _PrintWidth(sa$) / 2
    yoff = 16 / 2
    _PrintString (x2 - xoff, y2 - yoff), sa$

    _Limit 10
Next

PieSlice 80, 90, 80, _D2R(45), 0, Red, 1 ' 1 for fill
PieSlice 200, 200, 50, _D2R(270), _D2R(120), Green, 1 ' 1 for fill
PieSlice 400, 400, 50, _D2R(120), _D2R(270), Gold, 1 ' 1 for fill
PieSliceSteve 620, 90, 80, 45, 0, Red
PieSliceSteve 800, 200, 50, 270, 120, Green
PieSliceSteve 1000, 400, 50, 120, 270, Gold
Locate 33, 1: Print "PieSlice 80, 90, 80, _D2R(45), 0, Red, 1 ' 1 for fill";
Locate 34, 1: Print "PieSlice 200, 200, 50, _D2R(270), _D2R(120), Green, 1 ' 1 for fill";
Locate 35, 1: Print "PieSlice 400, 400, 50, _D2R(120), _D2R(270), Gold, 1 ' 1 for fill";
Locate 33, 76: Print "PieSliceSteve 620, 90, 80, 45, 0, Red";
Locate 34, 76: Print "PieSliceSteve 800, 200, 50, 270, 120, Green";
Locate 35, 76: Print "PieSliceSteve 1000, 400, 50, 120, 270, Gold";

' nice method for PieSlice but goes CCW not CW
Sub PieSliceSteve (cx As Long, cy As Long, r As Long, startAngle As Long, endAngle As Long, c As _Unsigned Long)
    Dim As Long x, y, x1, y1, i, xt, yt
    If startAngle > endAngle Then endAngle = endAngle + 360
    x1 = Sin(_D2R(startAngle + 90)) * r
    y1 = Cos(_D2R(startAngle + 90)) * r
    Line (cx, cy)-Step(x1, y1), c
    For i = startAngle To endAngle Step Sgn(endAngle - startAngle)
        x = Sin(_D2R(i + 90)) * r
        y = Cos(_D2R(i + 90)) * r
        Line -(cx + x, cy + y), c ' <<< bplus fixed cy + y not cx + y !!!!
        If x <> x1 And y <> y1 And xt = 0 Then 'chose a point inside the arc to fill
            xt = Sin(_D2R(i + 90)) * r / 2
            yt = Cos(_D2R(i + 90)) * r / 2
        End If
    Next
    Line -(cx, cy), c
    Paint (cx + xt, cy + yt), c
End Sub

Function AtanSteve (x1, y1, x2, y2)
    AtanSteve = (360 - _R2D(_Atan2(y2 - y1, x2 - x1))) Mod 360
End Function

' bplus mod to Steve way of coding 2024-10-13 but for East = 0 And CW arcs 10-14 rev Fill Paint tests
Sub PieSlice (CX As Long, CY As Long, R As Long, RAStart!, RAEnd!, C As _Unsigned Long, Fill As Long)
    Dim As Long x, y, x1, y1, xt, yt
    Dim As Single i, REnd ' rend to copy RAEnd! before changing value
    If RAStart! > RAEnd! Then REnd = RAEnd! + _Pi * 2 Else REnd = RAEnd! ' rev 10-14
    x1 = Cos(RAStart!) * R
    y1 = Sin(RAStart!) * R
    Line (CX, CY)-Step(x1, y1), C
    For i = RAStart! To REnd Step _D2R(Sgn(REnd - RAStart!))
        x = Cos(i) * R
        y = Sin(i) * R
        Line -(CX + x, CY + y), C
        If x <> x1 And y <> y1 And xt = 0 Then 'choose a point inside the arc to fill
            xt = CX + Cos(i) * R / 2
            yt = CY + Sin(i) * R / 2
        End If
    Next
    Line -(CX, CY), C
    If xt <> 0 And Fill <> 0 Then Paint (xt, yt), C ' rev 10-14  don't Paint unless found a free pixel inside slice
    'Circle ( xt,  yt), c
End Sub
b = b + ...
Reply
#48
Oh heck I just found a fix I made in 2022, instead of EndRadianAngle it adds a arc measure in radians to the StartRadianAngle:

Code: (Select All)
Sub drawArc (xc, yc, radius, rStart, rMeasure, colr As _Unsigned Long)
    ' xc, yc Center for arc circle
    ' rStart is the Radian Start Angle, use _D2R for conversion from Degrees to Radians
    ' rMeasure is the measure of Arc in Radain units, use _D2R for conversion from Degrees to Radians
    ' Arc will start at rStart and go clockwise around for rMeasure Radians

    Dim rEnd, stepper, a, x, y

    rEnd = rStart + rMeasure
    stepper = 1 / radius ' the bigger the radius the smaller  the steps
    For a = rStart To rEnd Step stepper
        x = xc + radius * Cos(a)
        y = yc + radius * Sin(a)
        If a > rStart Then Line -(x, y), colr Else PSet (x, y), colr
    Next
End Sub

'Arc New 2022-09-28 independent of constants and routines
Sub drawPieSlice (xc, yc, radius, rStart, rMeasure, colr As _Unsigned Long)
    ' xc, yc Center for arc circle
    ' rStart is the Radian Start Angle, use _D2R for conversion from Degrees to Radians
    ' rMeasure is the measure of Arc in Radain units, use _D2R for conversion from Degrees to Radians
    ' Arc will start at rStart and go clockwise around for rMeasure Radians

    Dim rEnd, stepper, a, x, y

    rEnd = rStart + rMeasure
    Line (xc, yc)-(xc + radius * Cos(rStart), yc + radius * Sin(rStart)), colr
    Line (xc, yc)-(xc + radius * Cos(rEnd), yc + radius * Sin(rEnd)), colr
    stepper = 1 / radius ' the bigger the radius the smaller  the steps
    For a = rStart To rEnd Step stepper
        x = xc + radius * Cos(a)
        y = yc + radius * Sin(a)
        If a > rStart Then Line -(x, y), colr Else PSet (x, y), colr
    Next
    Paint (xc + .5 * radius * Cos(rStart + .5 * rMeasure), yc + .5 * radius * Sin(rStart + .5 * rMeasure)), colr, colr
End Sub
b = b + ...
Reply
#49
EDIT: turns out there was a problem with filling PieSlices that I didn't catch until I attempted to use transparent colors. Then I found out the fills weren't always happening.

So I have completely revised my PieSlice code and tested for fills with both solid and transparent color.
see next reply.
b = b + ...
Reply
#50
Arcs and PieSlices

These routines follow Basic Trig functions that start 0 Degrees/Radians Due East and go Clock wise around the screen from there:
Code: (Select All)
Option _Explicit
_Title "Arc & PieSlice (Filled) testing, escape for 2nd test" ' bplus rev 2024-10-15
Randomize Timer

Screen _NewImage(800, 600, 32)
_ScreenMove 250, 60
Dim As Single xc, yc, a, x1, y1, s, e, r, degree10, at, xoff, yoff, radius, x, y, cnt
Dim sa$
Dim cc As _Unsigned Long
degree10 = _Pi(2 / 36)
xc = 400: yc = 300
r = 250
Do
    Cls
    cc = _RGB32(Rnd * 155 + 100, Rnd * 255, Rnd * 255, Rnd * 200 + 55)
    s = Rnd * _Pi(2): e = Rnd * _Pi(2)
    For a = 0 To _Pi(1.999) Step degree10

        ' Regular East = 0 calcs
        x1 = xc + r * Cos(a)
        y1 = yc + r * Sin(a)
        at = Int(_R2D(_Atan2(y1 - yc, x1 - xc)) + .0001)
        If at < 0 Then at = at + 360
        sa$ = _Trim$(Str$(at))
        xoff = _PrintWidth(sa$) / 2
        yoff = 16 / 2
        _PrintString (x1 - xoff, y1 - yoff), sa$
    Next
    radius = Rnd * 100 + 100
    Arc 400, 300, radius, s, e, cc
    PieSlice 400, 300, radius - 10, s, e, cc, 1 ' test all fills !!!!
    Print "Start Angle:"; Int(_R2D(s)) ' covert to degrees
    Print "End Angle:"; Int(_R2D(e))
    Print: Print "zzz, Press any...."
    Sleep
Loop Until _KeyDown(27)
Cls
_KeyClear
_Title "Failure if the Screen floods by a bad Paint Job, any ky quits."
Do
    cc = _RGB32(Rnd * 155 + 100, Rnd * 255, Rnd * 255, Rnd * 200 + 55)
    s = Rnd * _Pi(2): e = Rnd * _Pi(2)
    radius = Rnd * 100 + 10
    x = Rnd * _Width: y = Rnd * _Height
    Arc x, y, radius, s, e, cc
    PieSlice x, y, radius - 5, s, e, cc, 1 ' test all fills !!!!
    _Limit 1
    cnt = cnt + 1
    If cnt Mod 50 = 49 Then Cls
Loop While InKey$ = ""

Sub Arc (CX, CY, R, RAStart, RAStop, C~&) ' rev 2024-10-14
    'CX, CY Center Circle point, R = radius, C~& = color
    ' RaStart and RAStop are Radian angles,
    ' RAStart is first angle clockwise from due East = 0 Radians
    ' Arc will start drawing there and go clockwise until raEnd is reached
    'note in Basic: degrees start due East = 0 and go clockwise

    Dim raEnd, stepper, a
    If RAStop < RAStart Then raEnd = RAStop + _Pi(2) Else raEnd = RAStop
    stepper = 1 / R
    For a = RAStart To raEnd Step stepper
        If (a - RAStart) < stepper Then
            PSet (CX + R * Cos(a), CY + R * Sin(a)), C~&
        Else
            Line -(CX + R * Cos(a), CY + R * Sin(a)), C~&
        End If
    Next
End Sub

Sub PieSlice (XC, YC, R, RStart, REnd, C As _Unsigned Long, FillTF) 'rev 2024-10-15
    ' XC, YC Center for arc circle with radius R
    ' RStart is the Radian Start Angle, use _D2R for conversion from Degrees to Radians
    ' REnd is Radian End Angle
    ' Arc will start at rStart and go clockwise around to rEnd Radians

    Dim rStop, rMid, stepper, a, x, y
    Dim bc As _Unsigned Long
    bc = _RGB32(_Red32(C), _Green32(C), _Blue32(C))
    If REnd < RStart Then rStop = REnd + _Pi(2) Else rStop = REnd
    rMid = rStop - RStart
    Line (XC, YC)-(XC + R * Cos(RStart), YC + R * Sin(RStart)), bc
    Line (XC, YC)-(XC + R * Cos(rStop), YC + R * Sin(rStop)), bc
    stepper = 1 / R ' the bigger the radius the smaller  the steps
    For a = RStart To rStop Step stepper
        x = XC + R * Cos(a)
        y = YC + R * Sin(a)
        If a > RStart Then Line -(x, y), bc Else PSet (x, y), bc
    Next
    If FillTF Then Paint (XC + R / 2 * Cos(RStart + rMid / 2), YC + R / 2 * Sin(RStart + rMid / 2)), C, bc
End Sub
   

More Newly revised PieSlice and testing code, works for transparent colors with more dependable Fills.
Code: (Select All)
Option _Explicit
_Title "Arc & PieSlice (Filled) testing, escape for 2nd test" ' bplus rev 2024-10-15
Randomize Timer

Screen _NewImage(800, 600, 32)
_ScreenMove 250, 60
Dim As Single xc, yc, a, x1, y1, s, e, r, degree10, at, xoff, yoff, radius, x, y, cnt
Dim sa$
Dim cc As _Unsigned Long
degree10 = _Pi(2 / 36)
xc = 400: yc = 300
r = 250
Do
    Cls
    cc = _RGB32(Rnd * 155 + 100, Rnd * 255, Rnd * 255, Rnd * 200 + 55)
    s = Rnd * _Pi(2): e = Rnd * _Pi(2)
    For a = 0 To _Pi(1.999) Step degree10

        ' Regular East = 0 calcs
        x1 = xc + r * Cos(a)
        y1 = yc + r * Sin(a)
        at = Int(_R2D(_Atan2(y1 - yc, x1 - xc)) + .0001)
        If at < 0 Then at = at + 360
        sa$ = _Trim$(Str$(at))
        xoff = _PrintWidth(sa$) / 2
        yoff = 16 / 2
        _PrintString (x1 - xoff, y1 - yoff), sa$
    Next
    radius = Rnd * 100 + 100
    Arc 400, 300, radius, s, e, cc
    PieSlice 400, 300, radius - 10, s, e, cc, 1 ' test all fills !!!!
    Print "Start Angle:"; Int(_R2D(s)) ' covert to degrees
    Print "End Angle:"; Int(_R2D(e))
    Print: Print "zzz, Press any...."
    Sleep
Loop Until _KeyDown(27)
Cls
_KeyClear
_Title "Failure if the Screen floods by a bad Paint Job, any ky quits."
Do
    cc = _RGB32(Rnd * 155 + 100, Rnd * 255, Rnd * 255, Rnd * 200 + 55)
    s = Rnd * _Pi(2): e = Rnd * _Pi(2)
    radius = Rnd * 100 + 10
    x = Rnd * _Width: y = Rnd * _Height
    Arc x, y, radius, s, e, cc
    PieSlice x, y, radius - 5, s, e, cc, 1 ' test all fills !!!!
    _Limit 1
    cnt = cnt + 1
    If cnt Mod 50 = 49 Then Cls
Loop While InKey$ = ""

Sub Arc (CX, CY, R, RAStart, RAStop, C~&) ' rev 2024-10-14
    'CX, CY Center Circle point, R = radius, C~& = color
    ' RaStart and RAStop are Radian angles,
    ' RAStart is first angle clockwise from due East = 0 Radians
    ' Arc will start drawing there and go clockwise until raEnd is reached
    'note in Basic: degrees start due East = 0 and go clockwise

    Dim raEnd, stepper, a
    If RAStop < RAStart Then raEnd = RAStop + _Pi(2) Else raEnd = RAStop
    stepper = 1 / R
    For a = RAStart To raEnd Step stepper
        If (a - RAStart) < stepper Then
            PSet (CX + R * Cos(a), CY + R * Sin(a)), C~&
        Else
            Line -(CX + R * Cos(a), CY + R * Sin(a)), C~&
        End If
    Next
End Sub

Sub PieSlice (XC, YC, R, RStart, REnd, C As _Unsigned Long, FillTF) 'rev 2024-10-15
    ' XC, YC Center for arc circle with radius R
    ' RStart is the Radian Start Angle, use _D2R for conversion from Degrees to Radians
    ' REnd is Radian End Angle
    ' Arc will start at rStart and go clockwise around to rEnd Radians

    Dim rStop, rMid, stepper, a, x, y
    Dim bc As _Unsigned Long
    bc = _RGB32(_Red32(C), _Green32(C), _Blue32(C))
    If REnd < RStart Then rStop = REnd + _Pi(2) Else rStop = REnd
    rMid = rStop - RStart
    Line (XC, YC)-(XC + R * Cos(RStart), YC + R * Sin(RStart)), bc
    Line (XC, YC)-(XC + R * Cos(rStop), YC + R * Sin(rStop)), bc
    stepper = 1 / R ' the bigger the radius the smaller  the steps
    For a = RStart To rStop Step stepper
        x = XC + R * Cos(a)
        y = YC + R * Sin(a)
        If a > RStart Then Line -(x, y), bc Else PSet (x, y), bc
    Next
    If FillTF Then Paint (XC + R / 2 * Cos(RStart + rMid / 2), YC + R / 2 * Sin(RStart + rMid / 2)), C, bc
End Sub

   
b = b + ...
Reply




Users browsing this thread: 6 Guest(s)