正六百胞体の位相的展開図を描いたときのプログラムです。
オブジェクトとしては、１つのピクチャー画面と２つのコマンドボタンを
使っています。
'===========================================================
'正六百胞体の位相的展開図
Option Explicit
Const MyLeft As Single = -3.2
Const MyWidth As Single = 6.4
Const MyTop As Single = 3.2
Dim MyRight As Single
Dim MyBottom As Single
Dim cc As Single, ss As Single
Dim c1 As Single, s1 As Single
Dim Xa(8) As Single, Ya(8) As Single, Za(8) As Single
Dim Xv(6) As Single, Yv(6) As Single, Zv(6) As Single
Dim Xw(20) As Single, Yw(20) As Single, Zw(20) As Single
Dim E1(30) As Integer, E2(30) As Integer
Dim p1 As Single, q1 As Single, p2 As Single, q2 As Single
Dim n1 As Integer
Const Tau As Single = (1 + 2.2360679) / 2
Const t2 As Single = Tau / (1 + Tau)
Const t1 As Single = 1 / (1 + Tau)
'------------------------------------------------------------
Private Sub Command1_Click()
Dim x1 As Single, y1 As Single, z1 As Single
Dim x2 As Single, y2 As Single, z2 As Single
Dim x3 As Single, y3 As Single, z3 As Single
cc = Cos(0.15): ss = Sin(0.15)
c1 = Cos(0.25): s1 = Sin(0.25)
Xa(1) = 1: Ya(1) = 1: Za(1) = 1 '立方体の頂点
Xa(2) = 1: Ya(2) = -1: Za(2) = 1
Xa(3) = -1: Ya(3) = -1: Za(3) = 1
Xa(4) = -1: Ya(4) = 1: Za(4) = 1
Xa(5) = 1: Ya(5) = 1: Za(5) = -1
Xa(6) = 1: Ya(6) = -1: Za(6) = -1
Xa(7) = -1: Ya(7) = -1: Za(7) = -1
Xa(8) = -1: Ya(8) = 1: Za(8) = -1
E1(1) = 1: E1(2) = 2: E1(3) = 3: E1(4) = 4: E1(5) = 1: E1(6) = 2
E2(1) = 2: E2(2) = 3: E2(3) = 4: E2(4) = 1: E2(5) = 5: E2(6) = 6
E1(7) = 3: E1(8) = 4: E1(9) = 5: E1(10) = 6: E1(11) = 7: E1(12) = 8
E2(7) = 7: E2(8) = 8: E2(9) = 6: E2(10) = 7: E2(11) = 8: E2(12) = 5
For n1 = 1 To 12
Call Henkan(Xa(E1(n1)), Ya(E1(n1)), Za(E1(n1)), p1, q1)
Call Henkan(Xa(E2(n1)), Ya(E2(n1)), Za(E2(n1)), p2, q2)
Picture1.Line (p1, q1)-(p2, q2), vbGreen:
Next n1
Xv(1) = 0: Yv(1) = 0: Zv(1) = 0 '正八面体の頂点
Xv(2) = Xa(1): Yv(2) = Ya(1): Zv(2) = Za(1)
Xv(3) = Xa(2): Yv(3) = Ya(2): Zv(3) = Za(2)
Xv(4) = Xa(3): Yv(4) = Ya(3): Zv(4) = Za(3)
Xv(5) = Xa(4): Yv(5) = Ya(4): Zv(5) = Za(4)
Xv(6) = 0: Yv(6) = 0: Zv(6) = 3
Octa
Dodeca
Xv(1) = 0: Yv(1) = 0: Zv(1) = 0 '正八面体の頂点
Xv(2) = Xa(1): Yv(2) = Ya(1): Zv(2) = Za(1)
Xv(3) = Xa(4): Yv(3) = Ya(4): Zv(3) = Za(4)
Xv(4) = Xa(8): Yv(4) = Ya(8): Zv(4) = Za(8)
Xv(5) = Xa(5): Yv(5) = Ya(5): Zv(5) = Za(5)
Xv(6) = 0: Yv(6) = 3: Zv(6) = 0
Octa
Dodeca
Xv(1) = 0: Yv(1) = 0: Zv(1) = 0 '正八面体の頂点
Xv(2) = Xa(8): Yv(2) = Ya(8): Zv(2) = Za(8)
Xv(3) = Xa(7): Yv(3) = Ya(7): Zv(3) = Za(7)
Xv(4) = Xa(6): Yv(4) = Ya(6): Zv(4) = Za(6)
Xv(5) = Xa(5): Yv(5) = Ya(5): Zv(5) = Za(5)
Xv(6) = 0: Yv(6) = 0: Zv(6) = -3
Octa
Dodeca
Xv(1) = 0: Yv(1) = 0: Zv(1) = 0 '正八面体の頂点
Xv(2) = Xa(6): Yv(2) = Ya(6): Zv(2) = Za(6)
Xv(3) = Xa(2): Yv(3) = Ya(2): Zv(3) = Za(2)
Xv(4) = Xa(3): Yv(4) = Ya(3): Zv(4) = Za(3)
Xv(5) = Xa(7): Yv(5) = Ya(7): Zv(5) = Za(7)
Xv(6) = 0: Yv(6) = -3: Zv(6) = 0
Octa
Dodeca
End Sub
'--------------------------------------------------------------------
Private Sub Octa()
' 正八面体を描く
E1(1) = 1: E1(2) = 3: E1(3) = 1: E1(4) = 5: E1(5) = 2: E1(6) = 4
E2(1) = 2: E2(2) = 1: E2(3) = 4: E2(4) = 1: E2(5) = 3: E2(6) = 3
E1(7) = 4: E1(8) = 2: E1(9) = 6: E1(10) = 3: E1(11) = 6: E1(12) = 5
E2(7) = 5: E2(8) = 5: E2(9) = 2: E2(10) = 6: E2(11) = 4: E2(12) = 6
For n1 = 1 To 12
Call Henkan(Xv(E1(n1)), Yv(E1(n1)), Zv(E1(n1)), p1, q1)
Call Henkan(Xv(E2(n1)), Yv(E2(n1)), Zv(E2(n1)), p2, q2)
Picture1.Line (p1, q1)-(p2, q2), vbMagenta:
Next n1
End Sub
'---------------------------------------------------------------------
Private Sub Dodeca()
' 正二十面体を描く
E1(1) = 1: E1(2) = 3: E1(3) = 1: E1(4) = 5: E1(5) = 2: E1(6) = 4
E2(1) = 2: E2(2) = 1: E2(3) = 4: E2(4) = 1: E2(5) = 3: E2(6) = 3
E1(7) = 4: E1(8) = 2: E1(9) = 6: E1(10) = 3: E1(11) = 6: E1(12) = 5
E2(7) = 5: E2(8) = 5: E2(9) = 2: E2(10) = 6: E2(11) = 4: E2(12) = 6
For n1 = 1 To 12
Call Henkan(Xv(E1(n1)), Yv(E1(n1)), Zv(E1(n1)), p1, q1)
Call Henkan(Xv(E2(n1)), Yv(E2(n1)), Zv(E2(n1)), p2, q2)
Picture1.Line (p1, q1)-(p2, q2), vbMagenta:
Next n1
For n1 = 1 To 12
Xw(n1) = t2 * Xv(E1(n1)) + t1 * Xv(E2(n1))
Yw(n1) = t2 * Yv(E1(n1)) + t1 * Yv(E2(n1))
Zw(n1) = t2 * Zv(E1(n1)) + t1 * Zv(E2(n1))
Henkan Xw(n1), Yw(n1), Zw(n1), p1, q1
' Picture1.Circle (p1, q1), 0.1, vbRed
Next n1
E1(1) = 1: E1(2) = 3: E1(3) = 1: E1(4) = 8: E1(5) = 1: E1(6) = 2
E2(1) = 2: E2(2) = 1: E2(3) = 4: E2(4) = 1: E2(5) = 5: E2(6) = 5
E1(7) = 2: E1(8) = 2: E1(9) = 3: E1(10) = 3: E1(11) = 3: E1(12) = 3
E2(7) = 10: E2(8) = 6: E2(9) = 2: E2(10) = 6: E2(11) = 7: E2(12) = 4
E1(13) = 4: E1(14) = 4: E1(15) = 8: E1(16) = 5: E1(17) = 5: E1(18) = 10
E2(13) = 7: E2(14) = 12: E2(15) = 4: E2(16) = 8: E2(17) = 9: E2(18) = 5
E1(19) = 6: E1(20) = 11: E1(21) = 6: E1(22) = 7: E1(23) = 12: E1(24) = 8
E2(19) = 10: E2(20) = 6: E2(21) = 7: E2(22) = 11: E2(23) = 7: E2(24) = 12
E1(25) = 8: E1(26) = 9: E1(27) = 11: E1(28) = 9: E1(29) = 10: E1(30) = 11
E2(25) = 9: E2(26) = 12: E2(27) = 9: E2(28) = 10: E2(29) = 11: E2(30) = 12
For n1 = 1 To 30
Call Henkan(Xw(E1(n1)), Yw(E1(n1)), Zw(E1(n1)), p1, q1)
Call Henkan(Xw(E2(n1)), Yw(E2(n1)), Zw(E2(n1)), p2, q2)
Picture1.Line (p1, q1)-(p2, q2), vbBlue:
Next n1
End Sub
'---------------------------------------------------------------------
Private Sub Command2_Click()
End
End Sub
'----------------------------------------------------------------------
' 空間の点を画面の点に変換する
Private Sub Henkan(x As Single, y As Single, z As Single, p As Single, q As Single)
Dim x2 As Single, y2 As Single, z2 As Single
Dim x3 As Single, y3 As Single, z3 As Single
x2 = cc * x - ss * y: y2 = ss * x + cc * y: z2 = z:
z3 = c1 * z2 - s1 * x2: x3 = s1 * z2 + c1 * x2: y3 = y2:
p = y3: q = z3
End Sub
'----------------------------------------------------------------------
Private Sub Form_Load()
Dim w As Single, h As Single, rate As Single
w = Picture1.ScaleWidth
h = Picture1.ScaleHeight
rate = MyWidth / w
Picture1.ScaleMode = 0
Picture1.ScaleWidth = rate * w
Picture1.ScaleHeight = -rate * h
Picture1.ScaleLeft = MyLeft
Picture1.ScaleTop = MyTop
MyRight = MyLeft + Picture1.ScaleWidth
MyBottom = MyTop + Picture1.ScaleHeight
Command1.Caption = "実行"
Command2.Caption = "終了"
End Sub
'======================================================================
前のページ へ戻る。
「ホームページ」 へ戻る。