QB64 Phoenix Edition
Drawing Tools Subs or Functions with Demo - Printable Version

+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://qb64phoenix.com/forum/forumdisplay.php?fid=26)
+---- Forum: bplus (https://qb64phoenix.com/forum/forumdisplay.php?fid=36)
+---- Thread: Drawing Tools Subs or Functions with Demo (/showthread.php?tid=272)

Pages: 1 2 3 4 5 6

RE: Drawing Tools Subs or Functions with Demo - PhilOfPerth - 10-15-2024

(10-15-2024, 04:48 PM)bplus Wrote: 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

Wow, brilliant!! Great job!


RE: Drawing Tools Subs or Functions with Demo - bplus - 10-29-2024

Roll Image Down (opens) or Up (closes)

Should fit any image inside a given box on screen and maintain the images width : height ratio.
Code: (Select All)
_Title "Roll Open and Close an Image" ' b+ 2024-10-29

Const SW = 1200, SH = 700
Screen _NewImage(SW, SH, 32): _ScreenMove 0, 0
i = _LoadImage("New PieSlice.PNG")
Do
    BoxRollDown 10, 10, _Width - 20, _Height - 20, i, 1
    _PrintString (500, _Height - 40), "Press any to roll up."
    Sleep
    Cls
    BoxRollDown 10, 10, _Width - 20, _Height - 20, i, 0
    _PrintString (500, _Height - 40), "Press any to roll down."
    Sleep
    Cls
Loop

Sub BoxRollDown (x, y, w, h, i, DownTF)
    ' not likely the box w, h is same scale as image w, h
    ' so what fits what?
    saveAD = _AutoDisplay
    iw = _Width(i)
    ih = _Height(i)
    wR = w / iw
    hR = h / ih
    If wR < hR Then ' use w scale to accommodate smallest change
        scale = w / iw
        xo = 0: yo = (h - ih * scale) / 2
    Else ' use h to accomadate smallest change
        scale = h / ih
        xo = (w - iw * scale) / 2: yo = 0
    End If
    ' mult scale to fit box
    Line (x, y)-Step(w, h), , B ' draw box
    Line (x + xo, y + yo)-Step(iw * scale, ih * scale), &HFFFFFF00, B ' fit image inside
    If DownTF Then
        For yy = 0 To ih
            _PutImage (x + xo, y + yo)-Step(iw * scale, yy * scale), i, 0, (0, 0)-(iw, yy)
            _Display
            _Limit 120
        Next
    Else
        For yy = ih To 0 Step -1
            Line (x + xo, y + yo)-Step(iw * scale, ih * scale), &HFF000000, BF
            Line (x + xo, y + yo)-Step(iw * scale, ih * scale), &HFFFFFF00, B ' fit image inside
            _PutImage (x + xo, y + yo)-Step(iw * scale, yy * scale), i, 0, (0, 0)-(iw, yy)
            _Display
            _Limit 120
        Next
    End If
    If saveAD Then _AutoDisplay
End Sub
"Preserving width : height ratio", and thereby NOT distorting the images circles or text beyond recognition.

Demo image is in zip

RE: Drawing Tools Subs or Functions with Demo - bplus - 11-01-2024

Text and Text8

Yeah these text subs might come in handy for labeling or jazzing up your print without loading a Font.

Text uses standard 8X16 chars in QB64 and Text8 uses the tiny _Font 8 square block characters.

Here I've updated them since Dav pointed to something and then I discovered background color was being changed. Hopefully all fixed and fit now.

Code: (Select All)
_Title "Text and Text8 tests" ' b+ 2024-11-01

Screen _NewImage(1024, 600, 32): _ScreenMove 0, 0
Color &HFFDDDDFF, &HFF000066: Cls
size = 64
For i = 1 To 20
    Text8 20, row, size, &HFF00FF88, "This is line" + Str$(i)
    row = row + size + 1
    size = 64 * .9 ^ i
Next
row = _Height - 64 - 8
size = 64
For i = 20 To 1 Step -1
    t$ = "This is line" + Str$(i)
    Text _Width - Len(t$) * size / 2 - 20, row, size, &HFFFF8800, "This is line" + Str$(i)
    size = 64 * .9 ^ (21 - i)
    row = row - size - 1
Next
_PrintString (350, _Height - 20), "OK tests done."
Sleep

Sub Text8 (x, y, textHeight, K As _Unsigned Long, txt$)
    Dim fg As _Unsigned Long, bg As _Unsigned Long, cur&, i&, f&
    fg = _DefaultColor: bg = _BackgroundColor: cur& = _Dest: f& = _Font
    i& = _NewImage(8 * Len(txt$), 8, 32)
    _Dest i&: _Font 8: Color K, _RGBA32(0, 0, 0, 0): _PrintString (0, 0), txt$
    _PutImage (x, y)-Step(Len(txt$) * textHeight, textHeight), i&, cur&
    Color fg, bg: _FreeImage i&: _Dest cur&: _Font f&
End Sub

Sub Text (x, y, textHeight, K As _Unsigned Long, txt$)
    Dim fg As _Unsigned Long, bg As _Unsigned Long, cur&, i&
    fg = _DefaultColor: bg = _BackgroundColor: cur& = _Dest
    i& = _NewImage(8 * Len(txt$), 16, 32)
    _Dest i&: Color K, _RGBA32(0, 0, 0, 0): _PrintString (0, 0), txt$
    _PutImage (x, y)-Step(Len(txt$) * textHeight / 2, textHeight), i&, cur&
    Color fg, bg: _FreeImage i&: _Dest cur&
End Sub

Thanks to Phil and Steve for getting me to haul out Text and look it over again.
   

RE: Drawing Tools Subs or Functions with Demo - bplus - 11-01-2024

FatPALline

This is a way to draw lines from a Point x, y at an angle for a given length, fatness and color.

I used it to boldly present the Maze lines in Flipping Hex Maze code. Also included is FatLine which needs the Circle Fill sub FCirc. Here is the demo:

Code: (Select All)
_Title "FatPALline test" 'b+ 2024-11-01

Screen _NewImage(801, 590, 32): _ScreenMove 240, 60
Type BoardType
    As Single x, y, flipped, flipping, a
End Type
Dim Shared ubX, ubY
ubX = 18: ubY = 16
Dim Shared b(ubX, ubY) As BoardType
Dim Shared cellR, xspacing!, yspacing!
cellR = 25
xspacing! = 2 * cellR * Cos(_D2R(30)): yspacing! = cellR * (1 + Sin(_D2R(30)))
Dim xoffset!
Color &HFF000000, &HFFAAAAFF
Do
    m = (m + 1) Mod ubX
    Cls
    For y = 0 To ubY
        If y Mod 2 = 0 Then xoffset! = .5 * xspacing! Else xoffset! = 0
        For x = 0 To ubX
            b(x, y).x = x * xspacing! + xoffset! + .5 * xspacing! - 20
            b(x, y).y = y * yspacing! + .5 * yspacing! - 20
            If Rnd < .002 Then b(x, y).flipping = 1
            showCell x, y
        Next
    Next
    _Display
    _Limit 60
Loop

Sub showCell (c, r)
    If b(c, r).flipping Then b(c, r).a = b(c, r).a + _Pi(1 / 90)
    If b(c, r).a >= _Pi(1 / 3) Then
        b(c, r).flipping = 0: b(c, r).a = 0
        If b(c, r).flipped Then b(c, r).flipped = 0 Else b(c, r).flipped = 1
    End If
    If b(c, r).flipped Then
        For a = _Pi(1 / 6) To _Pi(2) Step _Pi(2 / 3)
            FatPALline b(c, r).x, b(c, r).y, a + b(c, r).a, cellR, 4, &HFF000000
        Next
    Else
        For a = _Pi(.5) To _Pi(2) Step _Pi(2 / 3)
            FatPALline b(c, r).x, b(c, r).y, a + b(c, r).a, cellR, 4, &HFF000000
        Next
    End If
End Sub

'    ++++++++++++++++++ Featured Subroutines for Drawing +++++++++++++++++++++++

' needs Fcirc because needs FatLine
Sub FatPALline (BaseX, BaseY, RAngle, Lngth, Fat, K As _Unsigned Long) ' point angle length line
    Dim x2, y2
    x2 = BaseX + Lngth * Cos(RAngle)
    y2 = BaseY + Lngth * Sin(RAngle)
    FatLine BaseX, BaseY, x2, y2, Fat, K
End Sub

' 2023-09-27 000Test/Graphics/FatLine test and demo
Sub FatLine (x, y, x2, y2, wide As Integer, c As _Unsigned Long)
    ' this sub needs fcirc
    Dim dx, dy, distance, r
    dx = x2 - x
    dy = y2 - y
    distance = _Hypot(dx, dy)
    r = Int(wide / 2)
    If distance Then '  bullet proof
        dx = dx / distance
        dy = dy / distance
        If r = 0 Then
            Line (x, y)-(x2, y2), c
        Else
            Dim i As Long
            While i <= distance
                FCirc x + i * dx, y + i * dy, r, c
                i = i + 1
            Wend
        End If
    Else
        If r = 0 Then ' bullet proof
            PSet (x, y), c
        Else
            FCirc x, y, r, c
        End If
    End If
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

Maze code Before FatPALline:
   

and after:
   

RE: Drawing Tools Subs or Functions with Demo - bplus - 02-10-2025

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)
   
   

RE: Drawing Tools Subs or Functions with Demo - bplus - 02-14-2025

Outlining an Image

Code: (Select All)
_Title "Outline Image:  a few SLEEP steps press any..." 'b+ update OutLine Image 2025-02-13
' original code was from 2020-10-28 when Dav was working on coloring app around Halloween.
' Attempt at making a coloring book outlines.
' Results: well maybe this will help layout your masterpiece :)

' The last image is black outlines with shading or grey level hints

DefLng A-Z
Dim Shared xmax, ymax
iFile$ = _OpenFileDialog$("Select an Image to Outline", _CWD$, "*.png|*.jpg", "Image Files")
If iFile$ <> "" Then
    img = _LoadImage(iFile$, 32)
    xmax = _Width(img&)
    ymax = _Height(img&)
    Screen _NewImage(xmax, ymax, 32)
    _Delay .25
    _ScreenMove _Middle
    Dim gs(xmax, ymax), gs2(xmax, ymax)
    _PutImage , img
    nRound = 64 'this rounds to 4 shades of gray  <<< fiddle with this number dividing 256 for a shade grade
    For y = 0 To ymax - 1
        For x = 0 To xmax - 1
            c~& = Point(x, y)
            r = _Red32(c~&)
            g = _Green32(c~&)
            b = _Blue32(c~&)
            gs(x, y) = Int(((r + g + b) / 3) / nRound) * nRound 'round the grey
        Next
    Next
    Sleep
    Color , &HFFFFFFFF: Cls
    For y = 0 To ymax - 1
        For x = 0 To xmax - 1
            PSet (x, y), _RGB32(gs(x, y), gs(x, y), gs(x, y), 90)
        Next
    Next

    Sleep
    Color , &HFFFFFFFF: Cls
    For y = 0 To ymax - 1
        For x = 0 To xmax - 1
            If gs(x, y) <> gs(x + 1, y) Then PSet (x, y), &HFF000000: gs2(x, y) = 1
        Next
    Next
    For x = 0 To xmax - 1
        For y = 0 To ymax - 1
            If gs(x, y) <> gs(x, y + 1) Then PSet (x, y), &HFF000000: gs2(x, y) = 1
        Next
    Next

    Sleep

    ' adding back in the shades of gray
    'Color , &HFFFFFFFF: Cls
    'For x = 0 To xmax - 1
    '    For y = 0 To ymax - 1
    '        If gs2(x, y) Then PSet (x, y), &HFF000000
    '    Next
    'Next

    'For y = 0 To ymax - 1
    '    For x = 0 To xmax - 1
    '        PSet (x, y), _RGB32(gs(x, y), gs(x, y), gs(x, y), 90)
    '    Next
    'Next
End If

Sample image:
   

It is first grayscaled to this:
   

Sample output:
   

And if we add grayscaled back:
   

RE: Drawing Tools Subs or Functions with Demo - bplus - 04-30-2025

MidInk~& Function
Blend color 2 into color 1 by a fraction, usually it's the fractional distance of color 2 center or edge to color 1 center or edge.


Sometime the most handy routines are the simplest Smile

Code: (Select All)
_Title "midInk test" 'B+ 2019-04-18 remake 2025-04-30

Const xmax = 800
Const ymax = 600
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 250, 60

horizon% = Int(ymax * .6)
For i = 550 To 0 Step -1 '                      the sun
    FC3 400, horizon%, i, midInk~&(255, 255, 0, 50, 50, 208, i / 550)
Next

For i = horizon% To ymax '              the land
    Line (0, i)-(xmax, i), midInk~&(200, 200, 60, 45, 48, 0, (i - horizon%) / (ymax - horizon%))
Next
Sleep

' blend 2 colors according to fractional distance of 2nd to first color
Function midInk~& (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
    midInk~& = _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
End Function

Sub FC3 (cx As Long, cy As Long, r As Long, clr~&) ' fill circle #3 mod
    Dim As Long r2, x, y ' for Option _Explicit
    If r < 1 Then Exit Sub
    Line (cx - r, cy)-(cx + r, cy), clr~&, BF
    r2 = r * r
    Do
        y = y + 1
        x = Sqr(r2 - y * y)
        Line (cx - x, cy + y)-(cx + x, cy + y), clr~&, BF
        Line (cx - x, cy - y)-(cx + x, cy - y), clr~&, BF
    Loop Until y = r
End Sub


   

RE: Drawing Tools Subs or Functions with Demo - bplus - 04-30-2025

Here's a try at a Rainbow:
Code: (Select All)
_Title "Rainbow test" ' b+ 2025-04-30
Screen _NewImage(800, 600, 32)
_ScreenMove 250, 60
Const xmax = 800
Const ymax = 600

horizon% = Int(ymax * .6)
For i = 550 To 0 Step -1 '                      the sun
    FC3 400, horizon%, i, midInk~&(255, 255, 0, 50, 50, 208, i / 550)
Next

For i = horizon% To ymax '              the land
    Line (0, i)-(xmax, i), midInk~&(200, 200, 60, 45, 48, 0, (i - horizon%) / (ymax - horizon%))
Next

For r = 450 To 350 Step -.25
    drawArc 400, horizon% + 50, r, _Pi, _Pi, rainbow~&((r - 350) / 100, 40)
Next
Sleep

' blend 2 colors according to fractional distance of 2nd to first color
Function midInk~& (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
    midInk~& = _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
End Function

Sub FC3 (cx As Long, cy As Long, r As Long, clr~&) ' fill circle #3 mod
    Dim As Long r2, x, y ' for Option _Explicit
    If r < 1 Then Exit Sub
    Line (cx - r, cy)-(cx + r, cy), clr~&, BF
    r2 = r * r
    Do
        y = y + 1
        x = Sqr(r2 - y * y)
        Line (cx - x, cy + y)-(cx + x, cy + y), clr~&, BF
        Line (cx - x, cy - y)-(cx + x, cy - y), clr~&, BF
    Loop Until y = r
End Sub

Function rainbow~& (fraction, alpha)
    radians = fraction * 2 * _Pi
    b = Sin(radians) * 127 + 128
    g = Sin(radians - 2 / 3 * _Pi) * 127 + 128
    r = Sin(radians + 2 / 3 * _Pi) * 127 + 128
    rainbow~& = _RGB32(r, g, b, alpha)
End Function

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

Update: added an Alpha setting to the Rainbow~&(fraction) coloring Function.

RE: Drawing Tools Subs or Functions with Demo - bplus - 05-03-2025

OK a better? Rainbow with Modified MidInk~& for Alpha control and Modified ROY G BIV adding a much needed Cyan after Green and before Blue.

Code: (Select All)
_Title "Rainbow Test 2 Modified MidInk and ROY G BIV" ' b+ 2025-05-03 ROY G Cyan BIV with modified MidInk~&
Screen _NewImage(800, 600, 32)
_ScreenMove 250, 60
Const xmax = 800
Const ymax = 600

horizon% = Int(ymax * .6)
For a = 0 To 255 Step 5
    Cls
    For i = 600 To 0 Step -1 '                      the sun
        FC3 400, horizon% + 50, i, midInk~&(255, 255, 0, 50, 50, 208, i / 600, 200)
    Next

    For i = horizon% To ymax '              the land
        Line (0, i)-(xmax, i), midInk~&(200, 200, 60, 45, 48, 0, (i - horizon%) / (ymax - horizon%), 255)
    Next
    For r = 400 To 331 Step -.25
        If r > 390 Then
            c~& = midInk~&(255, 0, 0, 255, 127, 0, 1 - ((r - 390) / 10), a)
        ElseIf r > 380 Then
            c~& = midInk~&(255, 127, 0, 255, 255, 0, 1 - ((r - 380) / 10), a)
        ElseIf r > 370 Then
            c~& = midInk~&(255, 255, 0, 0, 255, 0, 1 - ((r - 370) / 10), a)
        ElseIf r > 360 Then
            c~& = midInk~&(0, 255, 0, 0, 255, 255, 1 - ((r - 360) / 10), a)
        ElseIf r > 350 Then
            c~& = midInk~&(0, 255, 255, 0, 0, 255, 1 - ((r - 350) / 10), a)
        ElseIf r > 340 Then
            c~& = midInk~&(0, 0, 255, 75, 0, 230, 1 - ((r - 340) / 10), a)
        Else
            c~& = midInk~&(75, 0, 230, 248, 0, 211, 1 - ((r - 330) / 10), a)
        End If

        drawArc 400, horizon% + 50, r, _Pi, _Pi, c~&
    Next
    _Display
    ' _Limit 100
Next
Sleep

' 2025-05-03 Modified MidInk~& to control Alpha out put
' blend 2 colors according to fractional distance of 2nd to first color
Function midInk~& (r1%, g1%, b1%, r2%, g2%, b2%, fr##, A%)
    midInk~& = _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##, A%)
End Function

Sub FC3 (cx As Long, cy As Long, r As Long, clr~&) ' fill circle #3 mod
    Dim As Long r2, x, y ' for Option _Explicit
    If r < 1 Then Exit Sub
    Line (cx - r, cy)-(cx + r, cy), clr~&, BF
    r2 = r * r
    Do
        y = y + 1
        x = Sqr(r2 - y * y)
        Line (cx - x, cy + y)-(cx + x, cy + y), clr~&, BF
        Line (cx - x, cy - y)-(cx + x, cy - y), clr~&, BF
    Loop Until y = r
End Sub

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

   

Update:
At first I thought this was better than the Rainbow~&(fraction) coloring Function but now with Alpha setting added to maybe not better at all. Rainbow~&(fraction) coloring Function spreads color span very evenly OR I used a too dark a Green for MidInk~&() color Function.

Tweaking numbers and using less alpha, BTW this MidInk~&(fraction) coloring Function is also modified with an Alpha setting!
Code: (Select All)
_Title "Rainbow Test 2 Modified MidInk and ROY G BIV" ' b+ 2025-05-03 ROY G Cyan BIV with modified MidInk~&
Screen _NewImage(800, 600, 32)
_ScreenMove 250, 60
Const xmax = 800
Const ymax = 600

horizon% = Int(ymax * .6)
For a = 0 To 10 Step 5
    Cls
    For i = 600 To 0 Step -1 '                      the sun
        FC3 400, horizon% + 50, i, midInk~&(255, 255, 0, 50, 50, 208, i / 600, 200)
    Next

    For i = horizon% To ymax '              the land
        Line (0, i)-(xmax, i), midInk~&(200, 200, 60, 45, 48, 0, (i - horizon%) / (ymax - horizon%), 255)
    Next
    For r = 400 To 331 Step -.25
        If r > 390 Then
            c~& = midInk~&(255, 50, 50, 255, 127, 100, 1 - ((r - 390) / 10), a)
        ElseIf r > 380 Then
            c~& = midInk~&(255, 127, 100, 255, 255, 0, 1 - ((r - 380) / 10), a)
        ElseIf r > 370 Then
            c~& = midInk~&(255, 255, 0, 100, 255, 100, 1 - ((r - 370) / 10), a)
        ElseIf r > 360 Then
            c~& = midInk~&(100, 255, 100, 0, 255, 255, 1 - ((r - 360) / 10), a)
        ElseIf r > 350 Then
            c~& = midInk~&(0, 255, 255, 100, 100, 255, 1 - ((r - 350) / 10), a)
        ElseIf r > 340 Then
            c~& = midInk~&(100, 100, 255, 75, 0, 230, 1 - ((r - 340) / 10), a)
        Else
            c~& = midInk~&(75, 0, 230, 248, 0, 211, 1 - ((r - 330) / 10), a)
        End If

        drawArc 400, horizon% + 50, r, _Pi, _Pi, c~&
    Next
    _Display
    ' _Limit 100
Next
Sleep

' 2025-05-03 Modified MidInk~& to control Alpha out put
' blend 2 colors according to fractional distance of 2nd to first color
Function midInk~& (r1%, g1%, b1%, r2%, g2%, b2%, fr##, A%)
    midInk~& = _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##, A%)
End Function

Sub FC3 (cx As Long, cy As Long, r As Long, clr~&) ' fill circle #3 mod
    Dim As Long r2, x, y ' for Option _Explicit
    If r < 1 Then Exit Sub
    Line (cx - r, cy)-(cx + r, cy), clr~&, BF
    r2 = r * r
    Do
        y = y + 1
        x = Sqr(r2 - y * y)
        Line (cx - x, cy + y)-(cx + x, cy + y), clr~&, BF
        Line (cx - x, cy - y)-(cx + x, cy - y), clr~&, BF
    Loop Until y = r
End Sub

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

   

Its very important to get your rainbows right Smile

RE: Drawing Tools Subs or Functions with Demo - bplus - 01-27-2026

Mr Amazing Cubed!
This my first attempt at running a gif image. Thank you Wiki and Zom B for setting up code to run Gif Images! For my first attempt lets try running the images thru _MapTriangle!

Code: (Select All)
_Title "Mr Amazing Cubed" ' b+ 2026-01-27    Thank you Wiki and Zom-B !!





'#######################################################################################

'# Animated GIF decoder v1.0                                                          #

'# By Zom-B                                                                            #

'#######################################################################################



DefInt A-Z

'$Dynamic



Dim Shared Dbg: Dbg = 0

Dim Shared powerOf2&(11)

For a = 0 To 11: powerOf2&(a) = 2 ^ a: Next a



Type GIFDATA

    file As Integer

    sigver As String * 6

    width As _Unsigned Integer

    height As _Unsigned Integer

    bpp As _Unsigned _Byte

    sortFlag As _Byte ' Unused

    colorRes As _Unsigned _Byte

    colorTableFlag As _Byte

    bgColor As _Unsigned _Byte

    aspect As Single ' Unused

    numColors As _Unsigned Integer

    palette As String * 768

End Type



Type FRAMEDATA

    addr As Long

    left As _Unsigned Integer

    top As _Unsigned Integer

    width As _Unsigned Integer

    height As _Unsigned Integer

    localColorTableFlag As _Byte

    interlacedFlag As _Byte

    sortFlag As _Byte ' Unused

    palBPP As _Unsigned _Byte

    minimumCodeSize As _Unsigned _Byte

    transparentFlag As _Byte 'GIF89a-specific (animation) values

    userInput As _Byte ' Unused

    disposalMethod As _Unsigned _Byte

    delay As Single

    transColor As _Unsigned _Byte

End Type



Type xy

    As Single x, y

End Type



Screen _NewImage(700, 700, 32)

_ScreenMove 300, 0



' draw points for cube 3 faces showing

Dim c(0 To 6) As xy

c(0).x = 350: c(0).y = 350

For i = 1 To 6

    c(i).x = 350 + 340 * Cos(i * _Pi / 3)

    c(i).y = 350 + 340 * Sin(i * _Pi / 3)

Next



Dim sb As Long ' image container

sb = _NewImage(_Width, _Height, 32)



' Open gif file. This reads the headers and palette but not the image data.

' The array will be redimentioned to fit the exact number of frames in the file.

Dim gifData As GIFDATA, frameData(0 To 0) As FRAMEDATA



filename$ = "steve1973.gif" '<<<<<<<<<<<< Enter a file name here!!!



If Len(filename$) = 0 Then End

openGif filename$, gifData, frameData()



' Loop away.

frame = 0

Cls , &HFF771017

Do While _KeyDown(27) = 0



    ' Request a frame. If it has been requested before, it is re-used,

    ' otherwise it is read and decoded from the file.

    '_PutImage (0, 0), getGifFrame&(gifData, frameData(), frame)

    _PutImage , getGifFrame&(gifData, frameData(), frame), sb ' store image in sb container

    _Delay frameData(frame).delay

    frame = (frame + 1) Mod (UBound(frameData) + 1)



    'top face

    _MapTriangle _Seamless(0, 0)-(_Width(sb) - 1, 0)-(_Width(sb) - 1, _Height(sb) - 1), sb To(c(4).x, c(4).y)-(c(5).x, c(5).y)-(c(6).x, c(6).y), 0

    _MapTriangle _Seamless(0, 0)-(0, _Height(sb) - 1)-(_Width(sb) - 1, _Height(sb) - 1), sb To(c(4).x, c(4).y)-(c(0).x, c(0).y)-(c(6).x, c(6).y), 0



    'right face

    _MapTriangle _Seamless(0, 0)-(_Width(sb) - 1, 0)-(_Width(sb) - 1, _Height(sb) - 1), sb To(c(0).x, c(0).y)-(c(6).x, c(6).y)-(c(1).x, c(1).y), 0

    _MapTriangle _Seamless(0, 0)-(0, _Height(sb) - 1)-(_Width(sb) - 1, _Height(sb) - 1), sb To(c(0).x, c(0).y)-(c(2).x, c(2).y)-(c(1).x, c(1).y), 0

    ftri c(0).x, c(0).y, c(6).x, c(6).y, c(1).x, c(1).y, &H99000000

    ftri c(1).x, c(1).y, c(2).x, c(2).y, c(0).x, c(0).y, &H99000000



    ' front face

    _MapTriangle _Seamless(0, 0)-(_Width(sb) - 1, 0)-(_Width(sb) - 1, _Height(sb) - 1), sb To(c(3).x, c(3).y)-(c(4).x, c(4).y)-(c(0).x, c(0).y), 0

    _MapTriangle _Seamless(0, 0)-(0, _Height(sb) - 1)-(_Width(sb) - 1, _Height(sb) - 1), sb To(c(3).x, c(3).y)-(c(2).x, c(2).y)-(c(0).x, c(0).y), 0

    ftri c(4).x, c(4).y, c(0).x, c(0).y, c(2).x, c(2).y, &H55000000

    ftri c(2).x, c(2).y, c(3).x, c(3).y, c(4).x, c(4).y, &H55000000

    _Display

Loop



'Close the file and free the allocated frames.

codeGif gifData, frameData()

End



'########################################################################################



Sub openGif (filename$, gifData As GIFDATA, frameData() As FRAMEDATA) Static

    file = FreeFile: gifData.file = file

    Open "B", gifData.file, filename$



    Get file, , gifData.sigver

    Get file, , gifData.width

    Get file, , gifData.height

    Get file, , byte~%%

    gifData.bpp = (byte~%% And 7) + 1

    gifData.sortFlag = (byte~%% And 8) > 0

    gifData.colorRes = (byte~%% \ 16 And 7) + 1

    gifData.colorTableFlag = (byte~%% And 128) > 0

    gifData.numColors = 2 ^ gifData.bpp

    Get file, , gifData.bgColor

    Get file, , byte~%%

    If byte~%% = 0 Then gifData.aspect = 0 Else gifData.aspect = (byte~%% + 15) / 64



    If gifData.sigver <> "GIF87a" And gifData.sigver <> "GIF89a" Then _Dest 0: Print "Invalid version": End

    If Not gifData.colorTableFlag Then _Dest 0: Print "No Color Table": End



    palette$ = Space$(3 * gifData.numColors)

    Get file, , palette$

    gifData.palette = palette$

    If Dbg And 1 Then

        Print "sigver        ="; gifData.sigver

        Print "width          ="; gifData.width

        Print "height        ="; gifData.height

        Print "bpp            ="; gifData.bpp

        Print "sortFlag      ="; gifData.sortFlag

        Print "colorRes      ="; gifData.colorRes

        Print "colorTableFlag ="; gifData.colorTableFlag

        Print "bgColor        ="; gifData.bgColor

        Print "aspect        ="; gifData.aspect

        Print "numColors      ="; gifData.numColors

        For i = 0 To gifData.numColors - 1

            Print Using "pal(###) = "; i;

            Print Hex$(_RGB32(Asc(gifData.palette, i * 3 + 1), Asc(gifData.palette, i * 3 + 2), Asc(gifData.palette, i * 3 + 3)))

        Next

    End If

    Do

        Get file, , byte~%%

        If Dbg And 2 Then Print "Chunk: "; Hex$(byte~%%)

        Select Case byte~%%

            Case &H2C ' Image Descriptor

                If frame > UBound(frameData) Then

                    ReDim _Preserve frameData(0 To frame * 2 - 1) As FRAMEDATA

                End If



                Get file, , frameData(frame).left

                Get file, , frameData(frame).top

                Get file, , frameData(frame).width

                Get file, , frameData(frame).height

                Get file, , byte~%%

                frameData(frame).localColorTableFlag = (byte~%% And 128) > 0

                frameData(frame).interlacedFlag = (byte~%% And 64) > 0

                frameData(frame).sortFlag = (byte~%% And 32) > 0

                frameData(frame).palBPP = (byte~%% And 7) + 1

                frameData(frame).addr = Loc(file) + 1



                If frameData(frame).localColorTableFlag Then

                    Seek file, Loc(file) + 3 * 2 ^ frameData(frame).palBPP + 1

                End If

                Get file, , frameData(frame).minimumCodeSize

                If Dbg And 2 Then

                    Print "addr                ="; Hex$(frameData(frame).addr - 1)

                    Print "left                ="; frameData(frame).left

                    Print "top                ="; frameData(frame).top

                    Print "width              ="; frameData(frame).width

                    Print "height              ="; frameData(frame).height

                    Print "localColorTableFlag ="; frameData(frame).localColorTableFlag

                    Print "interlacedFlag      ="; frameData(frame).interlacedFlag

                    Print "sortFlag            ="; frameData(frame).sortFlag

                    Print "palBPP              ="; frameData(frame).palBPP

                    Print "minimumCodeSize    ="; frameData(frame).minimumCodeSize

                End If

                If localColors Then _Dest 0: Print "Local color table": End

                If frameData(frame).disposalMethod > 2 Then Print "Unsupported disposalMethod: "; frameData(frame).disposalMethod: End

                skipBlocks file



                frame = frame + 1

            Case &H3B ' Trailer

                Exit Do

            Case &H21 ' Extension Introducer

                Get file, , byte~%% ' Extension Label

                If Dbg And 2 Then Print "Extension Introducer: "; Hex$(byte~%%)

                Select Case byte~%%

                    Case &HFF, &HFE ' Application Extension, Comment Extension

                        skipBlocks file

                    Case &HF9

                        If frame > UBound(frameData) Then

                            ReDim _Preserve frameData(0 To frame * 2 - 1) As FRAMEDATA

                        End If



                        Get 1, , byte~%% ' Block Size (always 4)

                        Get 1, , byte~%%

                        frameData(frame).transparentFlag = (byte~%% And 1) > 0

                        frameData(frame).userInput = (byte~%% And 2) > 0

                        frameData(frame).disposalMethod = byte~%% \ 4 And 7

                        Get 1, , delay~%

                        If delay~% = 0 Then frameData(frame).delay = 0.1 Else frameData(frame).delay = delay~% / 100

                        Get 1, , frameData(frame).transColor

                        If Dbg And 2 Then

                            Print "frame          ="; frame

                            Print "transparentFlag ="; frameData(frame).transparentFlag

                            Print "userInput      ="; frameData(frame).userInput

                            Print "disposalMethod  ="; frameData(frame).disposalMethod

                            Print "delay          ="; frameData(frame).delay

                            Print "transColor      ="; frameData(frame).transColor

                        End If

                        skipBlocks file

                    Case Else

                        Print "Unsupported extension Label: "; Hex$(byte~%%): End

                End Select

            Case Else

                Print "Unsupported chunk: "; Hex$(byte~%%): End

        End Select

    Loop



    ReDim _Preserve frameData(0 To frame - 1) As FRAMEDATA

End Sub



Sub skipBlocks (file)

    Do

        Get file, , byte~%% ' Block Size

        If Dbg And 2 Then Print "block size ="; byte~%%

        Seek file, Loc(file) + byte~%% + 1

    Loop While byte~%%

End Sub



Function getGifFrame& (gifData As GIFDATA, frameData() As FRAMEDATA, frame)

    If frameData(frame).addr > 0 Then

        If Dbg And 4 Then

            Print "addr                ="; Hex$(frameData(frame).addr - 1)

            Print "left                ="; frameData(frame).left

            Print "top                ="; frameData(frame).top

            Print "width              ="; frameData(frame).width

            Print "height              ="; frameData(frame).height

            Print "localColorTableFlag ="; frameData(frame).localColorTableFlag

            Print "interlacedFlag      ="; frameData(frame).interlacedFlag

            Print "sortFlag            ="; frameData(frame).sortFlag

            Print "palBPP              ="; frameData(frame).palBPP

            Print "minimumCodeSize    ="; frameData(frame).minimumCodeSize

            Print "transparentFlag    ="; frameData(frame).transparentFlag

            Print "userInput          ="; frameData(frame).userInput

            Print "disposalMethod      ="; frameData(frame).disposalMethod

            Print "delay              ="; frameData(frame).delay

            Print "transColor          ="; frameData(frame).transColor

        End If

        w = frameData(frame).width

        h = frameData(frame).height

        img& = _NewImage(w, h, 256)

        frame& = _NewImage(gifData.width, gifData.height, 256)



        _Dest img&

        decodeFrame gifData, frameData(frame)



        _Dest frame&

        If frameData(frame).localColorTableFlag Then

            _CopyPalette img&

        Else

            For i = 0 To gifData.numColors - 1

                _PaletteColor i, _RGB32(Asc(gifData.palette, i * 3 + 1), Asc(gifData.palette, i * 3 + 2), Asc(gifData.palette, i * 3 + 3))

            Next

        End If



        If frame Then

            Select Case frameData(frame - 1).disposalMethod

                Case 0, 1

                    _PutImage , frameData(frame - 1).addr

                Case 2

                    Cls , gifData.bgColor

                    _ClearColor gifData.bgColor

            End Select

        Else

            Cls , gifData.bgColor

        End If



        If frameData(frame).transparentFlag Then

            _ClearColor frameData(frame).transColor, img&

        End If

        _PutImage (frameData(frame).left, frameData(frame).top), img&

        _FreeImage img&



        frameData(frame).addr = frame&

        _Dest 0

    End If



    getGifFrame& = frameData(frame).addr

End Function



'############################################################################################



Sub decodeFrame (gifdata As GIFDATA, framedata As FRAMEDATA)

    Dim byte As _Unsigned _Byte

    Dim prefix(4095), suffix(4095), colorStack(4095)



    startCodeSize = gifdata.bpp + 1

    clearCode = 2 ^ gifdata.bpp

    endCode = clearCode + 1

    minCode = endCode + 1

    startMaxCode = clearCode * 2 - 1

    nvc = minCode

    codeSize = startCodeSize

    maxCode = startMaxCode



    If framedata.interlacedFlag Then interlacedPass = 0: interlacedStep = 8

    bitPointer = 0

    blockSize = 0

    blockPointer = 0

    x = 0

    y = 0



    file = gifdata.file

    Seek file, framedata.addr



    If framedata.localColorTableFlag Then

        palette$ = Space$(3 * 2 ^ framedata.palBPP)

        Get 1, , palette$



        For i = 0 To gifdata.numColors - 1

            c& = _RGB32(Asc(palette$, i * 3 + 1), Asc(palette$, i * 3 + 2), Asc(palette$, i * 3 + 3))

            _PaletteColor i, c&

        Next

    End If



    Get file, , byte ' minimumCodeSize



    Do

        GoSub GetCode

        stackPointer = 0

        If code = clearCode Then 'Reset & Draw next color direct

            nvc = minCode '          \

            codeSize = startCodeSize ' Preset default codes

            maxCode = startMaxCode '  /



            GoSub GetCode

            currentCode = code



            lastColor = code

            colorStack(stackPointer) = lastColor

            stackPointer = 1

        ElseIf code <> endCode Then 'Draw direct color or colors from suffix

            currentCode = code

            If currentCode = nvc Then 'Take last color too

                currentCode = oldCode

                colorStack(stackPointer) = lastColor

                stackPointer = stackPointer + 1

            End If



            While currentCode >= minCode 'Extract colors from suffix

                colorStack(stackPointer) = suffix(currentCode)

                stackPointer = stackPointer + 1

                currentCode = prefix(currentCode) 'Next color from suffix is described in

            Wend '                                the prefix, else prefix is the last col.



            lastColor = currentCode '              Last color is equal to the

            colorStack(stackPointer) = lastColor ' last known code (direct, or from

            stackPointer = stackPointer + 1 '      Prefix)

            suffix(nvc) = lastColor 'Automatically, update suffix

            prefix(nvc) = oldCode 'Code from the session before (for extracting from suffix)

            nvc = nvc + 1



            If nvc > maxCode And codeSize < 12 Then

                codeSize = codeSize + 1

                maxCode = maxCode * 2 + 1

            End If

        End If



        For i = stackPointer - 1 To 0 Step -1

            PSet (x, y), colorStack(i)

            x = x + 1

            If x = framedata.width Then

                x = 0

                If framedata.interlacedFlag Then

                    y = y + interlacedStep

                    If y >= framedata.height Then

                        Select Case interlacedPass

                            Case 0: interlacedPass = 1: y = 4

                            Case 1: interlacedPass = 2: y = 2

                            Case 2: interlacedPass = 3: y = 1

                        End Select

                        interlacedStep = 2 * y

                    End If

                Else

                    y = y + 1

                End If

            End If

        Next



        oldCode = code

    Loop Until code = endCode



    Get file, , byte

    Exit Sub



    GetCode:

    If bitPointer = 0 Then GoSub ReadByteFromBlock: bitPointer = 8

    WorkCode& = LastChar \ powerOf2&(8 - bitPointer)

    While codeSize > bitPointer

        GoSub ReadByteFromBlock



        WorkCode& = WorkCode& Or LastChar * powerOf2&(bitPointer)

        bitPointer = bitPointer + 8

    Wend

    bitPointer = bitPointer - codeSize

    code = WorkCode& And maxCode

    Return



    ReadByteFromBlock:

    If blockPointer = blockSize Then

        Get file, , byte: blockSize = byte

        a$ = Space$(blockSize): Get file, , a$

        blockPointer = 0

    End If

    blockPointer = blockPointer + 1

    LastChar = Asc(Mid$(a$, blockPointer, 1))

    Return

End Sub



Sub codeGif (gifData As GIFDATA, frameData() As FRAMEDATA)

    For i = 0 To UBound(frameData)

        If frameData(i).addr < 0 Then _FreeImage frameData(i).addr

    Next



    Close gifData.file

End Sub



Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)

    Dim D As Long

    Static a&

    D = _Dest

    If a& = 0 Then a& = _NewImage(1, 1, 32)

    _Dest a&

    _DontBlend a& '  '<<<< new 2019-12-16 fix

    PSet (0, 0), K

    _Blend a& '<<<< new 2019-12-16 fix

    _Dest D

    _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)

End Sub
zip with gif image and source