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: