Thread Rating:
  • 1 Vote(s) - 5 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Drawing Tools Subs or Functions with Demo
#51
(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!
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.) Big Grin
Please visit my Website at: http://oldendayskids.blogspot.com/
Reply
#52
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


Attached Files
.zip   Roll Box open close 2.zip (Size: 920.03 KB / Downloads: 10)
b = b + ...
Reply
#53
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.
   
b = b + ...
Reply
#54
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:
   
b = b + ...
Reply




Users browsing this thread: 1 Guest(s)