04-30-2022, 10:01 PM
(This post was last modified: 05-01-2022, 02:52 AM by bplus.
Edit Reason: Found another arrow
)
4 Arrow styles
I am enclosing the arrows in boxes or circles to give you an idea of area needed for laying out in your application.
Code: (Select All)
Option _Explicit
_Title "Arrow drawing" 'B+ started 2019-06-23
' mods 2022 for TailArrow, BlockArrow and LineArrow
Randomize Timer
Const xmax = 500, ymax = 500
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 300, 100
_Delay .5
Dim a, l
l = 50
For a = 0 To 2 * _Pi Step _Pi / 6
Cls
TailArrow 250, 250, a, l
Circle (250, 250), l + 10
Print "TailArrow:"
Print "Angle, Length:"; Int(_R2D(a) + .5), l
If a = 0 Then _Delay 1
l = l + 10
_Limit 1
Next
Cls
l = 25
For a = 0 To 3
Cls
BlockArrow 250, 250, a, l, &HFFFFFF00
Line (250 - .5 * l - 5, 250 - .5 * l - 5)-(250 + .5 * l + 5, 250 + .5 * l + 5), , B
Print "BlockArrow:"
Print "Angle, Length:"; a * 90, l
l = l + 25
_Limit 1
Next
_Delay 2
Cls
l = 10
For a = 0 To 2 * _Pi Step _Pi(2 / 12)
Cls
LineArrow 250, 250, a, l, &HFF008800
Line (250 - .5 * l - 5, 250 - .5 * l - 5)-(250 + .5 * l + 5, 250 + .5 * l + 5), , B
Print "LineArrow:"
Print "Angle, Length:"; Int(_R2D(a) + .5), l
l = l + 10
If a = 0 Then _Delay 1
_Limit 1
Next
_Delay 2
Cls
l = 10
For a = 0 To 2 * _Pi Step _Pi(2 / 12)
Cls
ArrowTo 250, 250, a, l, &HFF0000FF
Print "ArrowTo:"
Print "Angle, Length:"; Int(_R2D(a) + .5), l
Circle (250, 250), l + 5
l = l + 10
If a = 0 Then _Delay 1
_Limit 1
Next
Print "End of demo"
' For this arrow x0, y0 is at the point of the head, the shaft is drawn back from that for angle at lngth length.
' this arrow mimics an archery arrow with feathers on end, colors are constant.
Sub TailArrow (x0, y0, rAngle, lngth)
'This sub uses many other subs:
' Sub drawLink (x1, y1, r1, x2, y2, r2, c As _Unsigned Long)
' Sub fquad (x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, x3 As Integer, y3 As Integer, x4 As Integer, y4 As Integer, c As _Unsigned Long)
' Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim x1, y1, x2, y2, pi, i As Integer
pi = 3.14159265
x2 = x0 - lngth * Cos(rAngle)
y2 = y0 - lngth * Sin(rAngle)
drawLink x0, y0, .001 * lngth, x2, y2, .01 * lngth, &HFF00BB00
Line (x0, y0)-(x2, y2), &HFF00BB00
x2 = x0 - .1 * lngth * Cos(rAngle - .2 * pi)
y2 = y0 - .1 * lngth * Sin(rAngle - .2 * pi)
x1 = x0 - .1 * lngth * Cos(rAngle + .2 * pi)
y1 = y0 - .1 * lngth * Sin(rAngle + .2 * pi)
ftri x0, y0, x1, y1, x2, y2, &HFFFF8800
For i = .8 * lngth To lngth Step 3
x1 = x0 - i * Cos(rAngle)
y1 = y0 - i * Sin(rAngle)
x2 = x1 - .1 * lngth * Cos(rAngle - .25 * pi)
y2 = y1 - .1 * lngth * Sin(rAngle - .25 * pi)
Line (x1, y1)-(x2, y2), &HFF0000FF
x2 = x1 - .1 * lngth * Cos(rAngle + .25 * pi)
y2 = y1 - .1 * lngth * Sin(rAngle + .25 * pi)
Line (x1, y1)-(x2, y2), &HFF0000FF
Next
End Sub
' This is a blocklike arrow to use instead of a tile any size, any color: cx, cy is center of square.
' It can be only draw in East = 0, South = 1, West = 2, North = 3 Directions for ESWN03 variable.
' Assuming want to put inside a square = sqrSize and of cource c is for color.
Sub BlockArrow (cX, cY, ESWN03, sqrSize, c As _Unsigned Long) ' 4 directions East, South, West, North 0,1,2,3
'This sub needs:
' Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim m14, m13, m12, m23, m34, x0, y0
m14 = sqrSize * .25
m13 = sqrSize * .3333
m12 = sqrSize * .5
m23 = sqrSize * .6667
m34 = sqrSize * .75
x0 = cX - m12
y0 = cY - m12
Select Case ESWN03
Case 0 'east
Line (x0, y0 + m13)-Step(m23, m13), c, BF
ftri x0 + m23, y0, x0 + sqrSize, y0 + m12, x0 + m23, y0 + sqrSize, c
Case 1
Line (x0 + m13, y0)-Step(m13, m23), c, BF
ftri x0, y0 + m23, x0 + m12, y0 + sqrSize, x0 + sqrSize, y0 + m23, c
Case 2
Line (x0 + m13, y0 + m13)-Step(m23, m13), c, BF
ftri x0 + m13, y0, x0, y0 + m12, x0 + m13, y0 + sqrSize, c
Case 3
Line (x0 + m13, y0 + m13)-Step(m13, m23), c, BF
ftri x0, y0 + m13, x0 + m12, y0, x0 + sqrSize, y0 + m13, c
End Select
End Sub
' simplest arrow, xc, yc are at center of shaft of length lngth at angle ra (radian angle)
Sub LineArrow (xc, yc, ra, lngth, c As _Unsigned Long)
Dim x1, y1, x2, y2
x1 = xc + .5 * lngth * (Cos(ra))
y1 = yc + .5 * lngth * (Sin(ra))
x2 = xc + .5 * lngth * (Cos(ra - _Pi))
y2 = yc + .5 * lngth * (Sin(ra - _Pi))
Line (x1, y1)-(x2, y2), c
x2 = x1 + .2 * lngth * (Cos(ra - _Pi(3 / 4)))
y2 = y1 + .2 * lngth * (Sin(ra - _Pi(3 / 4)))
Line (x1, y1)-(x2, y2), c
x2 = x1 + .2 * lngth * (Cos(ra + _Pi(3 / 4)))
y2 = y1 + .2 * lngth * (Sin(ra + _Pi(3 / 4)))
Line (x1, y1)-(x2, y2), c
End Sub
' This version of arrow, x, y are at tail end and arrow point in rAngle (radians) for length of lngth
Sub ArrowTo (BaseX As Long, BaseY As Long, rAngle As Double, lngth As Long, colr As _Unsigned Long)
Dim As Long x1, y1, x2, y2, x3, y3
x1 = BaseX + lngth * Cos(rAngle)
y1 = BaseY + lngth * Sin(rAngle)
x2 = BaseX + .8 * lngth * Cos(rAngle - _Pi(.05))
y2 = BaseY + .8 * lngth * Sin(rAngle - _Pi(.05))
x3 = BaseX + .8 * lngth * Cos(rAngle + _Pi(.05))
y3 = BaseY + .8 * lngth * Sin(rAngle + _Pi(.05))
Line (BaseX, BaseY)-(x1, y1), colr
Line (x1, y1)-(x2, y2), colr
Line (x1, y1)-(x3, y3), colr
End Sub
Sub drawLink (x1, y1, r1, x2, y2, r2, c As _Unsigned Long)
Dim a, a1, a2, x3, x4, x5, x6, y3, y4, y5, y6
a = _Atan2(y2 - y1, x2 - x1)
a1 = a + _Pi(1 / 2)
a2 = a - _Pi(1 / 2)
x3 = x1 + r1 * Cos(a1): y3 = y1 + r1 * Sin(a1)
x4 = x1 + r1 * Cos(a2): y4 = y1 + r1 * Sin(a2)
x5 = x2 + r2 * Cos(a1): y5 = y2 + r2 * Sin(a1)
x6 = x2 + r2 * Cos(a2): y6 = y2 + r2 * Sin(a2)
fquad x3, y3, x4, y4, x5, y5, x6, y6, c
End Sub
'need 4 non linear points (not all on 1 line) list them clockwise so x2, y2 is opposite of x4, y4
Sub fquad (x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, x3 As Integer, y3 As Integer, x4 As Integer, y4 As Integer, c As _Unsigned Long)
ftri x1, y1, x2, y2, x4, y4, c
ftri x3, y3, x4, y4, x1, y1, c
End Sub
'' BEST saves dest and optimized with Static a& and alpha colors work better
'2019-12-16 fix by Steve saves some time with STATIC and saves and restores last dest
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 SubI am enclosing the arrows in boxes or circles to give you an idea of area needed for laying out in your application.
b = b + ...