编程实现 画心形，古董 WordBasic 实现

[yksoft1]

看了 知乎 上这个主题 如何用C语言画一个“心形”？（http://www.zhihu.com/question/20187195），我觉得很有意思
作为abandonware专家 我自然也弄了一个 实现了微积分书上那个最简单的笛卡尔心形
用的是WordBasic，Word for Windows 1.0-7.0时期Word支持的脚本语言，8.0之后被基于VB5的VBA取代。
使用了Win16的API，在32位的Word 6.0或者7.0上跑要自己修改。。
'API函数声明
Declare Function GetFocus Lib "user"() As Integer
Declare Function GetDC Lib "user"(hwnd As Integer) As Integer
Declare Function ReleaseDC Lib "user"(hwnd As Integer, hdc As Integer) As Integer
Declare Function MoveTo Lib "gdi"(hdc As Integer, x As Integer, y As Integer) As Integer
Declare Function LineTo Lib "gdi"(hdc As Integer, x As Integer, y As Integer) As Integer
Declare Function SetPixel Lib "gdi"(hdc As Integer, x As Integer, y As Integer, color As Long) As
Integer
Declare Function FloodFill Lib "gdi"(hdc As Integer, x As Integer, y As Integer, rgb As Long) As
Integer
Declare Function CreatePen Lib "gdi"(style As Integer, width As Integer, rgb As Long) As Integer
Declare Function CreateSolidBrush Lib "gdi"(rgb As Long) As Integer
Declare Function CreateHatchBrush Lib "gdi"(type As Integer, rgb As Long) As Integer

Declare Function SelectObject Lib "gdi"(hdc As Integer, hobj As Integer) As Integer
Declare Function DeleteObject Lib "gdi"(hobj As Integer) As Integer
'因为WordBasic没有数学库，就自己写了个简单的泰勒展开sin和cos，但是在这个环境下实在太慢了
Function tsin(x)
a = 1 : b = 1 : i = 1 : s = 0
a = x
tl:
s = s +(a / b)
a = - 1 * a * x * x
b = b * 2 * i *(2 * i + 1)
i = i + 1
If a / b >= 0.005 Or a / b <= - 0.005 Then Goto tl
tsin = s
End Function
Function tcos(x)
s = 1 : t = 1 : f = 1 : v = 1 : i = 2
While t > 0.005 Or t < - 0.005
f = f *(- 1 * x * x)
v = v *((i - 1) * i)
i = i + 2
t = f / v
s = s + t
Wend
tcos = s
End Function
Sub MAIN
hw = getfocus
hd = getdc(hw)
hp = createpen(0, 6, 255 * 65536)
hpo = selectobject(hd, hp)
'生成笛卡尔心形线
r = moveto(hd, 200 + 50 *(2 * tsin(0) - tsin(0)), 100 - 50 *(2 * tcos(0) - tcos(0)))
For i = 1 To 314
ty = 100 - 50 *(2 * tcos(i / 50) - tcos(i / 25))
tx = 200 + 50 *(2 * tsin(i / 50) - tsin(i / 25))
'Print Str$(tx) + " " + Str$(ty)
r = lineto(hd, tx, ty)
Next
hbr = createhatchbrush(5, 224 * 65536 + 64 * 256 + 64)
hobr = selectobject(hd, hbr)
r = floodfill(hd, tx, ty + 8, 255 * 65536)
r = selectobject(hd, hobr)
r = selectobject(hd, hpo)
r = deleteobject(hp)
r = deleteobject(hbr)
r = releasedc(0, hd)
End Sub

运行截图x2
 

[openroc]

关于这个心形‘背后的故事，更有意思。：）

[shense]

@openroc 那个逼格矿泉水百岁山的广告创意，传说就来源于这个公式背后的故事。