这是以前找到的一个VB程序,作者已经不可得知。
昨天晚上与朋友聊画图算法的时候我突然想到了这个程序。
算法并不是太难,利用三角函数画出图形轮廓。
接着利用api函数填充图形。
核心算法如下:
Private Sub comp(a As Double, b As Double, c As Double)
Dim j As Long
Dim AA As Double, BB As Double
Dim n As Double, o As Double
Dim w As Double, z As Double
If c > 60 Then ' 花茎
Ds.a = Sin(a * 7) * (13 + 5 / (0.2 + (b * 4) ^ 4)) - Sin(b) * 50
Ds.b = b * f + 50
Ds.c = 625 + Cos(a * 7) * (13 + 5 / (0.2 + (b * 4) ^ 4)) + b * 400
Ds.d = a - b / 2
Ds.e = a
Exit Sub
End If
AA = a * 2 - 1
BB = b * 2 - 1
If AA * AA + BB * BB < 1 Then
If c > 37 Then '花叶
j = Int(c) And 1
n = IIf(j, 6, 4)
o = 0.5 / (a + 0.01) + Cos(b * 125) * 3 - a * 300
w = b * h
Ds.a = o * Cos(n) + w * Sin(n) + j * 610 - 390
Ds.b = o * Sin(n) - w * Cos(n) + 550 - j * 350
Ds.c = 1180 + Cos(BB + AA) * 99 - j * 300
Ds.d = 0.4 - a * 0.1 + ((1 - BB * BB) ^ (-h * 6)) * 0.15 - a * b * 0.4 + Cos(a + b) / 5 + (Cos((o * (a + 1) + (IIf(BB > 0, w, -w))) / 25) ^ 30) * 0.1 * (1 - BB * BB)
Ds.e = o / 1000# + 0.7 - o * w * 0.000003
ElseIf c > 32 Then '萼片
c = c * 1.16 - 0.15
o = a * 45 - 20
w = b * b * h
z = o * Sin(c) + w * Cos(c) + 620
Ds.a = o * Cos(c) - w * Sin(c)
Ds.b = 28 + Cos(BB * 0.5) * 99 - b * b * b * 60 - z / 2 - h
Ds.c = z
Ds.d = (b * b * 0.3 + ((1 - a * a) ^ 7) * 0.15 + 0.3) * b
Ds.e = b * 0.7
Else '花
o = AA * (2 - b) * (80 - c * 2)
w = 99 - Cos(AA) * 120 - Cos(b) * (-h - c * 4.9) + Cos((1 - b) ^ 7) * 50 + c * 2
z = o * Sin(c) + w * Cos(c) + 700
Ds.a = o * Cos(c) - w * Sin(c)
Ds.b = BB * 99 - Cos(b ^ 7) * 50 - c / 3 - z / 1.35 + 450
Ds.c = z
Ds.d = (1 - b / 1.2) * 0.9 + a * 0.1
Ds.e = ((1 - b) ^ 20) / 4 + 0.05
End If
End If
End Sub
Private Sub DrawRose()
Dim x As Long, y As Long
Static i As Long
Dim j As Long
Dim x1 As Long, y1 As Long
Dim z As Long
Dim r As Long, g As Long
Dim b As Long
Dim q As Long
x = 1: y = 1:
x1 = 1: y1 = 1
z = 1
r = 255
j = i Mod 46
comp Rnd, Rnd, j / 0.74
i = i + 1
z = Ds.c
If z = 0 Then z = 1
x = Ds.a * f / z - h
y = Ds.b * f / z - h
x = x / 2
y = y / 2
q = y * f + x
If Not ((Not m(q)) Or m(q) > z) Then Exit Sub
m(q) = z
r = Ds.d * h
g = Ds.e * h
b = Ds.d * Ds.d * (-80)
SetPixel Me.hdc, x, y, RGB(Abs(r), Abs(g), Abs(b))
End Sub
源程序点我下载