RotoLine line drawing

[James D Jarvis]

Line drawing using Rotoline a routine made possible by RotoZoom

Code: (Select All)

'RotoLine Demo
'by James D, Jarvis October 11,2023
'a program that demonstrates how to use rotozoom and related commands to draw lines thicker than one pixel

'$dynamic
_Title "RotoLine Demo"
Screen _NewImage(800, 500, 32)
Dim Shared dot&
dot& = _NewImage(1, 1, 32) 'ALL rotoline routines all need this defiend as so
Dim a(10, 2)
Randomize Timer
Locate 1, 10: Print "Draw lines with thickness other than 1.   Press any key to continue"
RotoLine 300, 50, 700, 90, 32, _RGB32(100, 100, 0)
RotoLineEC 100, 100, 200, 100, 7, _RGB32(250, 0, 200)
RotoLineEC 200, 100, 300, 300, 7, _RGB32(250, 0, 200)
a(1, 1) = 0: a(1, 2) = 0
a(2, 1) = 50: a(2, 2) = 60
a(3, 1) = 55: a(3, 2) = 70
a(4, 1) = 100: a(4, 2) = 80
a(5, 1) = 101: a(5, 2) = 78
a(6, 1) = 108: a(6, 2) = 176
a(7, 1) = 111: a(7, 2) = 200
a(8, 1) = 113: a(8, 2) = 232
a(9, 1) = 112: a(9, 2) = 370
a(10, 1) = 110: a(10, 2) = 400
rline a(), 4, _RGB32(60, 120, 0)

'making a circle with rline
ReDim a(180, 2)
cx = 400: cy = 300: rad = 80: r = 0
For p = 1 To 180
    a(p, 1) = cx + (rad * Cos(0.01745329 * r))
    a(p, 2) = cy + (rad * Sin(0.01745329 * r))
    r = r + 2
Next p
rline a(), 3, _RGB32(0, 100, 200)
_PrintString (290, 200), "a circle from an array"
Sleep
'draw regular polygon with rpoly
cx = 200
For s = 3 To 40
    _Limit 4
    Cls
    Locate 1, 1: Print "sides "; s; ",radius "; s * 5; ", line thickness "; Int((s + 1) / 3)
    rpoly cx, 250, s * 5, s, s * 2, Int((s + 1) / 3), _RGB32(0, 200, 100)
    cx = cx + 10
    _Display
Next s
_AutoDisplay
Locate 2, 1: Print "Press any key to continue"
Sleep
Cls
t1 = Timer
dlimit = 64000
For n = 1 To dlimit
    RotoLine Int(Rnd * _Width), Int(Rnd * _Height), Int(Rnd * _Width), Int(Rnd * _Height), Int(1 + Rnd * 12), _RGB32(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256))
Next n
t2 = Timer
Print t2 - t1; " seconds to draw "; dlimit; " randomly generated lines"
Sleep
Cls
Print "roto_rect, roto_rectEC and rpolyFT"
roto_rect 101, 101, 200, 100, 3, 0, _RGB32(0, 100, 100), _RGB32(0, 200, 200)
'Line (101, 101)-(300, 200), _RGB32(250, 250, 250), B
roto_rectEC 101, 301, 200, 100, 12, 25, _RGB32(0, 200, 100), _RGB32(0, 230, 230)
rpolyFT 550, 250, 50, 5, 0, 3, _RGB32(0, 100, 70), _RGB32(0, 200, 140)


Sub roto_rect (rx, ry, ww, hh, thk, rtn, lklr As _Unsigned Long, fklr As _Unsigned Long)
    Dim sb&
    sb& = _NewImage(ww + thk * 2, hh + thk * 2, 32) 'make a scratchboard
    o& = _Dest
    _Dest sb&
    x1 = thk: x2 = thk + ww - 1
    y1 = thk: y2 = thk + hh - 1
    Line (x1, y1)-(x2, y2), fklr, BF
    RotoLine x1, y1, x2, y1, thk, lklr
    RotoLine x2, y1, x2, y2, thk, lklr
    RotoLine x2, y2, x1, y2, thk, lklr
    RotoLine x1, y2, x1, y1, thk, lklr
    _Dest o&
    RotoZoom23d rx + ww / 2, ry + hh / 2, sb&, 1, 1, rtn
    _FreeImage sb&
End Sub
Sub roto_rectEC (rx, ry, ww, hh, thk, rtn, lklr As _Unsigned Long, fklr As _Unsigned Long)
    Dim sb&
    sb& = _NewImage(ww + thk * 2, hh + thk * 2, 32) 'make a scratchboard
    o& = _Dest
    _Dest sb&
    x1 = thk: x2 = thk + ww - 1
    y1 = thk: y2 = thk + hh - 1
    Line (x1, y1)-(x2, y2), fklr, BF
    RotoLineEC x1, y1, x2, y1, thk, lklr
    RotoLineEC x2, y1, x2, y2, thk, lklr
    RotoLineEC x2, y2, x1, y2, thk, lklr
    RotoLineEC x1, y2, x1, y1, thk, lklr
    _Dest o&
    RotoZoom23d rx + ww / 2, ry + hh / 2, sb&, 1, 1, rtn
    _FreeImage sb&
End Sub



Sub rpoly (cx As Single, cy As Single, rad As Single, sides As Integer, rtn As Single, thk As Single, klr As _Unsigned Long)
    'use build and draw an equilateral polygon of radius rad from cx,cy with sides # os sides
    'start with a rotation of rtn , draw theshape with a line of thickness thk in color klr
    Dim a(sides + 1, 2)
    rstep = 360 / sides
    pmax = sides + 1
    r = rtn
    'build the points gor polygon perimieter an store in array a()
    For p = 1 To pmax
        a(p, 1) = cx + (rad * Cos(0.01745329 * (r)))
        a(p, 2) = cy + (rad * Sin(0.01745329 * (r)))
        r = r + rstep
    Next p
    rline a(), thk, _RGB32(0, 100, 200)
End Sub


Sub rpolyFT (cx As Single, cy As Single, rad As Single, sides As Integer, rtn As Single, thk As Single, lklr As _Unsigned Long, fklr As _Unsigned Long)
    'use build and draw an equilateral polygon of radius rad from cx,cy with sides # os sides
    'start with a rotation of rtn , draw theshape with a line of thickness thk in color klr
    Dim a(sides + 1, 2)
    rstep = 360 / sides
    pmax = sides + 1
    r = rtn
    'build the points gor polygon perimieter an store in array a()
    For p = 1 To pmax
        a(p, 1) = cx + (rad * Cos(0.01745329 * (r)))
        a(p, 2) = cy + (rad * Sin(0.01745329 * (r)))
        r = r + rstep
    Next p
    'draw the fill triangles
    For p = 1 To sides - 1
        ftri cx, cy, a(p, 1), a(p, 2), a(p + 1, 1), a(p + 1, 2), fklr
    Next p
    ftri cx, cy, a(sides, 1), a(sides, 2), a(1, 1), a(1, 2), fklr
    'draw the perimeter if lklr <> 0
    If lklr <> 0 Then rline a(), thk, _RGB32(0, 100, 200)
End Sub






Sub rline (la(), thk As Single, klr As _Unsigned Long)
    'draw a line described in an array
    p = UBound(la)
    For n = 1 To p - 1
        RotoLineEC la(n, 1), la(n, 2), la(n + 1, 1), la(n + 1, 2), thk, klr
    Next n
End Sub
Sub RotoLineEC (x1 As Single, y1 As Single, x2 As Single, y2 As Single, thk As Single, klr As _Unsigned Long)
    'use rotozoom to draw a line of thickness thk of color klr from x1,y1 to x2,y2
    'uses filled circles to make endcaps for the lines
    cx = (x1 + x2) / 2
    cy = (y1 + y2) / 2
    o& = _Dest
    _Dest dot&
    PSet (0, 0), klr
    _Dest o&
    rtn = DegTo!(x1, y1, x2, y2)
    lnth = Sqr(Abs(x2 - x1) * Abs(x2 - x1) + Abs(y2 - y1) * Abs(y2 - y1))
    RotoZoom23d cx, cy, dot&, lnth, thk, rtn
    fcirc x1, y1, thk / 2, klr
    fcirc x2, y2, thk / 2, klr
End Sub
Sub RotoLine (x1 As Single, y1 As Single, x2 As Single, y2 As Single, thk As Single, klr As _Unsigned Long)
    'use rotozoom to draw a line of thickness thk of color klr from x1,y1 to x2,y2
    cx = (x1 + x2) / 2
    cy = (y1 + y2) / 2
    o& = _Dest
    _Dest dot&
    PSet (0, 0), klr
    _Dest o&
    rtn = DegTo!(x1, y1, x2, y2)
    lnth = Sqr(Abs(x2 - x1) * Abs(x2 - x1) + Abs(y2 - y1) * Abs(y2 - y1))
    RotoZoom23d cx, cy, dot&, lnth, thk, rtn
End Sub

Sub RotoZoom23d (centerX As Single, centerY As Single, Image As Long, xScale As Single, yScale As Single, Rotation As Single)
    'rotate an image with Rotation defined in units of degrees, 0 is along x axis to the right gogin clockwise
    Dim px(3) As Single: Dim py(3) As Single
    Wi& = _Width(Image&): Hi& = _Height(Image&)
    W& = Wi& / 2 * xScale
    H& = Hi& / 2 * yScale
    px(0) = -W&: py(0) = -H&: px(1) = -W&: py(1) = H&
    px(2) = W&: py(2) = H&: px(3) = W&: py(3) = -H&
    sinr! = Sin(-0.01745329 * Rotation): cosr! = Cos(-0.01745329 * Rotation)
    For i& = 0 To 3
        x2& = (px(i&) * cosr! + sinr! * py(i&)) + centerX: y2& = (py(i&) * cosr! - px(i&) * sinr!) + centerY
        px(i&) = x2&: py(i&) = y2&
    Next
    _MapTriangle (0, 0)-(0, Hi& - 1)-(Wi& - 1, Hi& - 1), Image& To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
    _MapTriangle (0, 0)-(Wi& - 1, 0)-(Wi& - 1, Hi& - 1), Image& To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End Sub
Function DegTo! (x1, y1, x2, y2)
    ' returns an angle in degrees from point x1,y1 to point x2,y2
    DegTo! = _Atan2((y2 - y1), (x2 - x1)) / 0.01745329
End Function
Sub fcirc (CX As Single, CY As Single, R, klr As _Unsigned Long)
    'draw a filled circle with the quickest filled circle routine in qb64, not my development
    Dim subRadius As Long, RadiusError As Long
    Dim X As Long, Y As Long
    subRadius = Abs(R)
    RadiusError = -subRadius
    X = subRadius
    Y = 0
    If subRadius = 0 Then PSet (CX, CY), klr: Exit Sub
    Line (CX - X, CY)-(CX + X, CY), klr, 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), klr, BF
                Line (CX - Y, CY + X)-(CX + Y, CY + X), klr, BF
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        Line (CX - X, CY - Y)-(CX + X, CY - Y), klr, BF
        Line (CX - X, CY + Y)-(CX + X, CY + Y), klr, BF
    Wend
End Sub

Sub ftri (xx1, yy1, xx2, yy2, xx3, yy3, c As _Unsigned Long)
    'Andy Amaya's triangle fill modified for QB64
    Dim x1 As Single, y1 As Single, x2 As Single, y2 As Single, x3 As Single, y3 As Single
    Dim slope1 As Single, slope2 As Single, length As Single, x As Single, lastx%, y As Single
    Dim slope3 As Single
    'make copies before swapping
    x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2: x3 = xx3: y3 = yy3
    'triangle coordinates must be ordered: where x1 < x2 < x3
    If x2 < x1 Then Swap x1, x2: Swap y1, y2
    If x3 < x1 Then Swap x1, x3: Swap y1, y3
    If x3 < x2 Then Swap x2, x3: Swap y2, y3
    If x1 <> x3 Then slope1 = (y3 - y1) / (x3 - x1)
    'draw the first half of the triangle
    length = x2 - x1
    If length <> 0 Then
        slope2 = (y2 - y1) / length
        For x = 0 To length
            Line (Int(x + x1), Int(x * slope1 + y1))-(Int(x + x1), Int(x * slope2 + y1)), c
            lastx% = Int(x + x1)
        Next
    End If
    'draw the second half of the triangle
    y = length * slope1 + y1: length = x3 - x2
    If length <> 0 Then
        slope3 = (y3 - y2) / length
        For x = 0 To length
            If Int(x + x2) <> lastx% Then
                Line (Int(x + x2), Int(x * slope1 + y))-(Int(x + x2), Int(x * slope3 + y2)), c
            End If
        Next
    End If
End Sub