10-11-2023, 04:24 PM
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