超立方体と正軸体の中心切断形VB
VB プログラム編

================================================================

'５次元正軸体の中心切断形の位相的展開図

Option Explicit
Const MyLeft As Single = -5               '左の座標
Const MyWidth As Single = 10              '左右のはば
Const MyTop As Single = 5                 '上の座標
Const Pi As Single = 3.14159

Dim MyRight As Single
Dim MyBottom As Single

Dim cx As Single, sx As Single
Dim cz As Single, sz As Single
Dim E1(30) As Integer, E2(30) As Integer

Private Sub Command1_Click()
      
    Dim Xv(30) As Single, Yv(30) As Single, Zv(30) As Single
    Dim E1(9), E2(9), Cl(9) As Integer
    Dim p1 As Single, q1 As Single, p2 As Single, q2 As Single
   
    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
    Dim pp(12) As Integer, k As Integer, n1 As Integer
    Dim c2 As Single, s2 As Single, th As Single
   
    cx = Cos(0.15): sx = Sin(0.15)          'y軸回りの回転
    cz = Cos(0.08): sz = Sin(0.08)          'z軸回りの回転
  
    Xv(1) = Cos(Pi / 6): Yv(1) = Sin(Pi / 6): Zv(1) = 1      '三角柱の頂点
    Xv(2) = Cos(-Pi / 2): Yv(2) = Sin(-Pi / 2): Zv(2) = 1
    Xv(3) = Cos(5 * Pi / 6): Yv(3) = Sin(5 * Pi / 6): Zv(3) = 1
    Xv(4) = Cos(Pi / 6): Yv(4) = Sin(Pi / 6): Zv(4) = -1
    Xv(5) = Cos(-Pi / 2): Yv(5) = Sin(-Pi / 2): Zv(5) = -1
    Xv(6) = Cos(5 * Pi / 6): Yv(6) = Sin(5 * Pi / 6): Zv(6) = -1
    
    E1(1) = 1: E1(2) = 2: E1(3) = 3: E1(4) = 1: E1(5) = 2: E1(6) = 3
    E2(1) = 2: E2(2) = 3: E2(3) = 1: E2(4) = 4: E2(5) = 5: E2(6) = 6
    E1(7) = 4: E1(8) = 5: E1(9) = 6
    E2(7) = 5: E2(8) = 6: E2(9) = 4
    
    For n1 = 1 To 9
        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), vbCyan
    Next n1
    
    Xv(7) = 0: Yv(7) = 0: Zv(7) = 2.7
    Xv(8) = 0: Yv(8) = 0: Zv(8) = -2.7
    
    E1(1) = 1: E1(2) = 2: E1(3) = 3: E1(4) = 8: E1(5) = 8: E1(6) = 8
    E2(1) = 7: E2(2) = 7: E2(3) = 7: E2(4) = 4: E2(5) = 5: E2(6) = 6

    For n1 = 1 To 6                                          '上下の四面体
        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), vbCyan
    Next n1
    
    For n1 = 0 To 5
        Xv(n1 + 9) = 2.7 * Cos(n1 * Pi / 3):
        Yv(n1 + 9) = 2.7 * Sin(n1 * Pi / 3): Zv(n1 + 9) = 0
    Next n1
    
    E1(1) = 1: E1(2) = 2: E1(3) = 14: E1(4) = 14: E1(5) = 9
    E2(1) = 9: E2(2) = 14: E2(3) = 9: E2(4) = 5: E2(5) = 4

    For n1 = 1 To 5                                                '側面の三角柱
        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), vbGreen
    Next n1
    
    E1(1) = 2: E1(2) = 3: E1(3) = 13: E1(4) = 13: E1(5) = 12: E1(6) = 13
    E2(1) = 13: E2(2) = 12: E2(3) = 12: E2(4) = 5: E2(5) = 6: E2(6) = 14

    For n1 = 1 To 5
        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), vbGreen
    Next n1
    
    n1 = 6
    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), vbGreen
    
    
    E1(1) = 1: E1(2) = 3: E1(3) = 10: E1(4) = 11: E1(5) = 9
    E2(1) = 10: E2(2) = 11: E2(3) = 4: E2(4) = 6: E2(5) = 10
    E1(6) = 10: E1(7) = 11
    E2(6) = 11: E2(7) = 12

    For n1 = 1 To 7                                                '後面の三角柱
        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), vbYellow:
    Next n1
    
    Xv(21) = 4 * Cos(-Pi / 6): Yv(21) = 4 * Sin(-Pi / 6): Zv(21) = 4  '大きな三角柱
    Xv(22) = 4 * Cos(Pi / 2): Yv(22) = 4 * Sin(Pi / 2): Zv(22) = 4
    Xv(23) = 4 * Cos(-5 * Pi / 6): Yv(23) = 4 * Sin(-5 * Pi / 6): Zv(23) = 4
    Xv(24) = 4 * Cos(-Pi / 6): Yv(24) = 4 * Sin(-Pi / 6): Zv(24) = -4
    Xv(25) = 4 * Cos(Pi / 2): Yv(25) = 4 * Sin(Pi / 2): Zv(25) = -4
    Xv(26) = 4 * Cos(-5 * Pi / 6): Yv(26) = 4 * Sin(-5 * Pi / 6): Zv(26) = -4
    
    E1(1) = 21: E1(2) = 22: E1(3) = 23: E1(4) = 21: E1(5) = 22
    E2(1) = 22: E2(2) = 23: E2(3) = 21: E2(4) = 24: E2(5) = 25
    E1(6) = 23: E1(7) = 24: E1(8) = 25: E1(9) = 26
    E2(6) = 26: E2(7) = 25: E2(8) = 26: E2(9) = 24
    
    For n1 = 1 To 9                                                '大きな三角柱
        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), vbBlue
    Next n1
        
    n1 = 5
    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), vbYellow:
    

    E1(1) = 21: E1(2) = 22: E1(3) = 23: E1(4) = 8: E1(5) = 8: E1(6) = 8
    E2(1) = 7: E2(2) = 7: E2(3) = 7: E2(4) = 24: E2(5) = 25: E2(6) = 26

    For n1 = 1 To 6                                              '上下の四面体
        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
    
    E1(1) = 21: E1(2) = 21: E1(3) = 23: E1(4) = 23
    E2(1) = 9: E2(2) = 14: E2(3) = 12: E2(4) = 13
    E1(5) = 9: E1(6) = 14: E1(7) = 12: E1(8) = 13
    E2(5) = 24: E2(6) = 24: E2(7) = 26: E2(8) = 26
    
    For n1 = 1 To 8
        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
    
    E1(1) = 22: E1(2) = 22: E1(3) = 25: E1(4) = 25
    E2(1) = 10: E2(2) = 11: E2(3) = 10: E2(4) = 11

    For n1 = 1 To 4
        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), vbYellow
    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 = cz * x - sz * y: y2 = sz * x + cz * y: z2 = z:
    y3 = cx * y2 - sx * z2: z3 = sx * y2 + cx * z2: x3 = x2:
    p = x3: 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
    
    Picture1.AutoRedraw = -1         'True
    Command1.Caption = "開始"
    Command2.Caption = "終了"
    Command3.Caption = "画像の保存"
End Sub
'           --------------------------------------------------

Private Sub Command3_Click()
    Dim message, title, filename, Default As String
    
    message = "ファイル名を入れて下さい" + Chr(13) & Chr(10) + "拡張子は要りません"
    title = "ファイル名"
    filename = InputBox(message, title, Default)
    SavePicture Picture1.Image, "c:\my documents\" + filename + ".bmp"
End Sub



=======================================================================


'角切り五胞体   2004.10.10

Option Explicit
Const MyLeft As Single = -7           '左の座標
Const MyWidth As Single = 14          '左右のはば
Const MyTop As Single = 7             '上の座標
Dim MyRight As Single
Dim MyBottom As Single

Dim cx As Single, sx As Single
Dim cz As Single, sz As Single

Private Sub Command1_Click()
    Dim Xv(20) As Single, Yv(20) As Single, Zv(20) As Single
    Dim Xw(20) As Single, Yw(20) As Single, Zw(20) As Single
    Dim E1(24), E2(24), Cl(24) As Integer
    Dim p1 As Single, q1 As Single, p2 As Single, q2 As Single
   
    Dim pp(12) As Integer, k As Integer, n1 As Integer
    Dim c2 As Single, s2 As Single, th As Single
   
    cx = Cos(0.43): sx = Sin(0.43)          'y軸回りの回転
    cz = Cos(0.18): sz = Sin(0.18)          'z軸回りの回転
  
    Xv(1) = 1: Yv(1) = 1: Zv(1) = 1         '四面体の頂点
    Xv(2) = 1: Yv(2) = 1: Zv(2) = -1
    Xv(3) = 1: Yv(3) = -1: Zv(3) = -1
    Xv(4) = 1: Yv(4) = -1: Zv(4) = 1
    Xv(5) = -1: Yv(5) = 1: Zv(5) = 1
    Xv(6) = -1: Yv(6) = 1: Zv(6) = -1
    Xv(7) = -1: Yv(7) = -1: Zv(7) = -1
    Xv(8) = -1: Yv(8) = -1: Zv(8) = 1
    
    E1(1) = 1: E1(2) = 8: E1(3) = 6: E1(4) = 3: E1(5) = 3: E1(6) = 3
    E2(1) = 8: E2(2) = 6: E2(3) = 1: E2(4) = 1: E2(5) = 8: E2(6) = 6
    E1(7) = 3: E1(8) = 4: E1(9) = 5: E1(10) = 6: E1(11) = 7: E1(12) = 8
    E2(7) = 3: E2(8) = 4: E2(9) = 5: E2(10) = 6: E2(11) = 7: E2(12) = 8
    
    For n1 = 1 To 6
        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), vbBlue
    Next n1
        
    Xw(1) = 6: Yw(1) = 0: Zw(1) = 0        '正八面体の頂点
    Xw(2) = 0: Yw(2) = 6: Zw(2) = 0
    Xw(3) = 0: Yw(3) = 0: Zw(3) = 6
    Xw(4) = -6: Yw(4) = 0: Zw(4) = 0
    Xw(5) = 0: Yw(5) = -6: Zw(5) = 0
    Xw(6) = 0: Yw(6) = 0: Zw(6) = -6
    
    E1(1) = 1: E1(2) = 1: E1(3) = 1: E1(4) = 1: E1(5) = 2: E1(6) = 3
    E2(1) = 2: E2(2) = 3: E2(3) = 5: E2(4) = 6: E2(5) = 3: E2(6) = 5
    E1(7) = 5: E1(8) = 6: E1(9) = 4: E1(10) = 4: E1(11) = 4: E1(12) = 4
    E2(7) = 6: E2(8) = 2: E2(9) = 2: E2(10) = 3: E2(11) = 5: E2(12) = 6

    For n1 = 1 To 12
        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)
    Next n1
    
    '外の八面体と中の四面体をつなぐ
    E1(1) = 1: E1(2) = 1: E1(3) = 1: E1(4) = 3: E1(5) = 3: E1(6) = 3
    E2(1) = 1: E2(2) = 2: E2(3) = 3: E2(4) = 1: E2(5) = 5: E2(6) = 6
    E1(7) = 6: E1(8) = 6: E1(9) = 6: E1(10) = 8: E1(11) = 8: E1(12) = 8
    E2(7) = 2: E2(8) = 4: E2(9) = 6: E2(10) = 3: E2(11) = 4: E2(12) = 5
    
    For n1 = 1 To 12
        Call Henkan(Xv(E1(n1)), Yv(E1(n1)), Zv(E1(n1)), p1, q1)
        Call Henkan(Xw(E2(n1)), Yw(E2(n1)), Zw(E2(n1)), p2, q2)
        Picture1.Line (p1, q1)-(p2, q2), vbMagenta
    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 = cz * x - sz * y: y2 = sz * x + cz * y: z2 = z:
    y3 = cx * y2 - sx * z2: z3 = sx * y2 + cx * z2: x3 = x2:
    p = x3: 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
    
    Picture1.AutoRedraw = -1         'True
    Command1.Caption = "開始"
    Command2.Caption = "終了"
    Command3.Caption = "画像の保存"
End Sub
'          ---------------------------------------------------

Private Sub Command3_Click()
    '画像ファイルとして取り入れる
    Dim message, title, filename, Default As String
    
    message = "ファイル名を入れて下さい" + Chr(13) & Chr(10) + "拡張子は要りません"
    title = "ファイル名"
    filename = InputBox(message, title, Default)
    SavePicture Picture1.Image, "c:\my documents\" + filename + ".bmp"
End Sub

====================================================================